diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,349 @@ # Revision history for mcp-server -## 0.1.0.21 - ??? +## 0.3.0.1 - 2026-10-20 +Handlers can ask the user for input part-way through a request: the +multi round-trip requests of MCP 2026-07-28 (ADR 0009). + +### Upgrading from 0.3.0.0 + +* Derived handlers (`derive*Handler`) need no changes. +* Hand-written `ToolCallHandler`, `PromptGetHandler` and + `ResourceReadHandler` functions return `Outcome`: wrap results in + `Complete`, e.g. `Right (Complete result)`. +* Code that builds a `ClientContext` by hand should start from + `anonymousContext` and record-update it; the type gained fields. +* `mcpApplication` returns `IO Application`: bind it before handing it + to Warp. +* Code that calls `handleMcpMessage` directly passes a `StateCodec` after + the `CacheHints`; `handlePromptsGet`, `handleResourcesRead` and + `handleToolsCall` take one as their first argument. One from + `ephemeralStateCodec` will do. +* `MCP.Server` now exports the names of `MCP.Server.Ask` (`Ask`, `elicit`, + `elicitUrl`, `step`, `Form`, `Answer(..)`, `HandlerMonad`, `runAsk`, + `askContext`): hide or qualify them where they clash with your own. +* `MCP.Server.Derive` now exports aeson's `Value`, so a module that also + imports `Value` from `Data.Aeson` may get a redundant-import warning; + drop one of the two. + +### Asking for input + +* Derived handlers can ask: the `derive*Handler` functions accept + handlers returning `Ask` as well as `IO` (through the new + `HandlerMonad` class), so a handler starts asking by changing its + type. `elicit` asks for a form and `elicitUrl` sends the user to a URL; + the answer is `Accepted`, `Declined`, `Cancelled` or, without a round + trip when the client cannot ask, `Unavailable`. +* `deriveForm`, `deriveFormWithDescription` and `deriveFormWithOptions` + (labels and defaults, via `FormFieldOptions`) derive the new `Form` + class from flat records. Fields a form cannot hold, options for unknown + fields and defaults that do not fit their field are compile-time + errors. `MCP.Server.Derive` re-exports aeson's `Value` for writing + defaults. +* The `Ask` monad (new module `MCP.Server.Ask`, re-exported by + `MCP.Server`) runs a handler from the start on every round against a + journal of earlier rounds: answers and `step` results are recorded once + and replayed. A handler that asks something different at a position + fails rather than receiving the wrong answer. `runAsk` runs one from a + hand-written handler. +* Low level: call handlers return `Outcome` (`Complete`, or + `InputRequired` with requests and state), answered as an + `input_required` result. Retries carry the answers in + `clientInputResponses` and the handler's state in + `clientRequestState`; `clientSupportsInput` checks the client's + protocol revision and declared capabilities. +* The `requestState` sent to clients is sealed by a `StateCodec` (new + module `MCP.Server.RequestState`): ChaCha20-Poly1305, bound to the + caller, the request's parameters and an expiry (60 minutes by + default), and verified before the handler runs. The default key is + random per process; multi-instance HTTP deployments set a shared key + with `httpStateCodec` and `aeadStateCodec`, which supports rotation. + `stdioStateCodec` does the same for stdio. +* New example `ask-example` (`examples/Ask`): a table-booking server whose + tools ask the user for details and confirmation. + +### Other changes + +* `deriveToolHandlerWithOutput` and its variants no longer need + `toJSON`, `object` and `.=` from `Data.Aeson` in scope where they are + spliced: the generated serializer looked those names up in the user's + module. +* Documentation: every module has a header and every export a doc + comment, and Haddock links that were ambiguous or out of scope are + fixed. +* New dependencies: `crypton` (1.1.4 to 2.2), `ram` and `time`. + +### Breaking changes, in full + +* `ToolCallHandler`, `PromptGetHandler` and `ResourceReadHandler` return + `Outcome`. +* `ClientContext` gains `clientInputResponses` and `clientRequestState`; + `StdioConfig` and `HttpConfig` gain `stdioStateCodec` and + `httpStateCodec`. +* `handleMcpMessage`, `handlePromptsGet`, `handleResourcesRead` and + `handleToolsCall` take a `StateCodec`. +* `mcpApplication` returns `IO Application`, creating the default key + once. +* `MCP.Server` exports `MCP.Server.Ask`, and `MCP.Server.Derive` exports + aeson's `Value`: new names that can clash with or duplicate yours. + +## 0.3.0.0 - 2026-10-16 + +* Raw JSON Schema keywords (ADR 0014): `SchemaRaw` is a new `SchemaType` + that serializes its keywords as given, for schemas the other shapes + cannot express, such as `null`, `anyOf`, `$defs`/`$ref` or numeric + bounds. A `schemaDescription` alongside it replaces any `description` + among the keywords. BREAKING: exhaustive matches on `SchemaType` need a + case for it. + +## 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 +hours before this line landed and was never adopted, so rather than +burning a major version on a release nobody used, 0.2.0.1 replaces it — +including changes that would ordinarily demand a major bump. Anyone +explicitly pinning the deprecated 0.2.0.0 should move here. The unreleased +0.2.1.0 line below is folded in as well.) + +* Request cancellation (ADR 0008): in-flight requests can now actually be + interrupted, per the spec's "stop work as soon as practical, send nothing + further for that request". On stdio every request runs in its own task + and `notifications/cancelled` cancels the referenced one (unknown or + completed ids are ignored); on HTTP, closing an SSE response stream + cancels the running handler (detected within one keep-alive interval, + now 5s). Single-JSON HTTP responses only detect a disconnect at the + final write, so clients wanting cancellable calls should opt into + streaming via a `progressToken`. Cancellation is delivered as an + asynchronous exception, so handlers acquiring resources should use + `bracket` — documented in the README. BREAKING (behavioral): stdio + requests are now served concurrently rather than strictly + sequentially — handlers touching shared mutable state must + synchronize, as was already required with the HTTP transport. New + dependency: `async`. +* Progress notifications and per-request SSE (ADR 0007): handlers can + call `reportProgress` and `logToClient` on the `ClientContext` — both + safe unconditionally. `reportProgress` emits `notifications/progress` + only when the request carried a `progressToken`; `logToClient` emits + `notifications/message` only when the request declared + `io.modelcontextprotocol/logLevel` (per spec MUST NOT otherwise), + filtered to the declared threshold (new `LogLevel` type, RFC 5424 + ordering). On stdio the notifications interleave before the response; + on HTTP a request that opted in is answered with an SSE response + stream (notifications, then the final response), while other requests + keep the single-JSON response. BREAKING: `ClientContext` carries the + two actions and loses its `Show`/`Eq` instances; + `MCP.Server.Handlers.handleMcpMessage` takes the transport's + notification sink. +* Definition metadata (ADR 0006): + * `ToolAnnotations` — `readOnlyHint`/`destructiveHint`/`idempotentHint`/ + `openWorldHint` behavioral hints (2025-03-26+) plus a title, all unset + by default (`defaultToolAnnotations`), carried on `ToolDefinition` and + driving client permission UX. + * `Icon` lists (2025-11-25+) on tool, prompt, resource and + resource-template definitions. + * Content `Annotations` (`audience`/`priority`/`lastModified`, + 2025-03-26+) attached via the new `ContentAnnotated` wrapper, whose + annotations merge into the inner block's JSON (and parse back out). +* New `WithOptions` derivations for all five derive families, taking + per-constructor `DefinitionOptions` (description, title, icons, tool + annotations, and **constructor-scoped field descriptions** — two + constructors can now describe a same-named field differently, fixing the + global-namespace wart of the flat description list, which remains + supported unchanged). +* BREAKING: `ToolDefinition`, `PromptDefinition`, `ResourceDefinition` and + `ResourceTemplateDefinition` gain fields, and `Content` gains the + `ContentAnnotated` constructor. New smart constructors + (`mkToolDefinition`, `mkPromptDefinition`, `mkResourceDefinition`, + `mkResourceTemplateDefinition`) build definitions from required fields + only — construct through them and record-update, so future optional + fields stop breaking your code. All new JSON fields are omitted when + unset, so wire output for existing servers is unchanged. + +* Derived output schemas and structured content (ADR 0005): the new + `deriveToolHandlerWithOutput` (and `...WithOutputDescription`) take a + result record type, derive the tools' `outputSchema` from it (same field + rules as input derivation: primitives, `Maybe`, lists, all-nullary + enums, nested records), and serialize the handler's typed values into + `structuredContent` — the generated serializer mirrors the generated + schema, so the two cannot drift. Handlers return the new + `ToolOutput` type: `ToolOutput` (structured value; the JSON is also + returned as a text content block per the spec's recommendation), + `ToolOutputWith` (custom content blocks), `ToolOutputError` (isError), + or `ToolOutputRaw` (plain `ToolResult` escape hatch). Existing + `ToToolResult` handlers are untouched. The conformance corpus gains an + `echo_structured` reference tool with cases in both eras. + +* The HTTP transport's WAI application is now exported (`mcpApplication`, + re-exported from `MCP.Server`), so the MCP endpoint can be embedded into + an existing WAI stack — your own Warp settings, TLS, middleware or router + — instead of `transportRunHttp` running its own server. `httpPort`/ + `httpHost` are ignored when embedding; everything else (endpoint path, + Origin validation, bearer auth, `subscriptions/listen` streaming) applies + as usual. +* The golden wire fixtures are now a self-describing, API-agnostic + conformance corpus: each case under `test/golden/` is a + `.request.json`/`.response.json` pair on disk, enumerated by + `manifest.json`, with the reference server documented in + `test/golden/README.md`. Other MCP implementations can replay the + requests and diff the responses without touching any Haskell; the + fixtures themselves are unchanged. + +## 0.2.0.0 - 2026-07-31 + +A major overhaul of the handler API. The headline changes: the handler +boundary is no longer stringly typed, and the server is dual-era — it speaks +both the legacy initialize-handshake revisions and the stateless +`2026-07-28` revision. + +### Dual-era protocol support (2026-07-28) + +* Requests that declare a protocol revision in their params `_meta` + (`io.modelcontextprotocol/protocolVersion`) are served statelessly with + the modern result envelope: `resultType: "complete"`, the server identity + in result `_meta`, and — on `tools/list`, `prompts/list`, + `resources/list`, `resources/read` and `server/discover` — the required + `ttlMs`/`cacheScope` fields (configurable via `CacheHints` on the + transport configs; default: no caching, private). Requests without modern + `_meta` are served byte-identically to before under the revision + negotiated by `initialize`. +* New `server/discover` method (mandatory in 2026-07-28, and the + backwards-compatibility probe): supported revisions of both eras, + handler-gated capabilities, server identity and instructions. +* Declaring an unsupported revision returns + `UnsupportedProtocolVersionError` (`-32022`) listing the supported set. +* A legacy client proposing `2026-07-28` via `initialize` negotiates down + to `2025-11-25`: an initializing client is legacy by definition. +* Handlers can read the declared revision, client info and client + capabilities from the `ClientContext` + (`clientProtocolVersion`/`clientInfo`/`clientCapabilities`); the new + `anonymousContext` builds an empty context. +* HTTP: modern requests get the 2026-07-28 request-metadata validation — + the `MCP-Protocol-Version` header must match the body's declared + revision, `Mcp-Method` must match the body method, and `Mcp-Name` must + match `params.name`/`params.uri` for `tools/call`/`resources/read`/ + `prompts/get` (with `=?base64?…?=` sentinel decoding); violations return + `400` with `HeaderMismatch` (`-32020`). Unknown methods return HTTP 404 + and unsupported revisions HTTP 400, so era-probing clients can + distinguish them. Legacy requests keep the relaxed pre-2026 rules. + +### Change notifications and subscriptions/listen + +* New `MCP.Server.Notifications`: create an `McpNotifier` with + `newMcpNotifier`, hand its `NotificationSource` to a transport + (`stdioNotifications`/`httpNotifications`), and call + `notifyToolsListChanged`/`notifyPromptsListChanged`/ + `notifyResourcesListChanged`/`notifyResourceUpdated` when things change. +* `subscriptions/listen` (2026-07-28) is served on both transports: the + mandatory acknowledgment comes first with the honored filter, every + message is tagged with the subscription id, only opted-into types are + delivered, and streams end gracefully (closure responses at stdio EOF; + closing the SSE stream cancels over HTTP, `notifications/cancelled` over + stdio). HTTP streams send periodic keep-alive comments and + `X-Accel-Buffering: no`. +* Legacy stdio clients receive spontaneous untagged notifications after + `initialize`. Capabilities are era- and transport-aware: `listChanged` is + advertised only where delivery is possible (stdio legacy push, or + modern `subscriptions/listen`), and `subscribe` only to modern clients. +* `defaultHttpConfig` is now re-exported from `MCP.Server`. + +### Resource templates and completions + +* Record constructors of a resource type now derive as resource /templates/ + (`UserProfile { userId :: Text }` → + `resource://user_profile/{userId}`): the derived read handler matches + template URIs, percent-decodes the path segments, and parses them into + the constructor's (typed) fields. `deriveResourceTemplates` derives the + `resources/templates/list` handler advertising them; the method carries + the modern cacheability envelope. +* New `completions` handler slot serving `completion/complete` for prompt + arguments and resource-template parameters (`CompletionRef`, + `CompletionResult`, capped at 100 values per the spec). The + `completions` capability is advertised automatically. +* `McpServerHandlers` gains `resourceTemplates` and `completions` fields; + the new `noHandlers` value lets you construct handler sets by record + update so future fields don't break your code. + +### Typed tool arguments and results (BREAKING) + +* Tool arguments arrive as full JSON values (`Map Text Value`). The Template + Haskell derivation decodes records recursively and now supports **list + fields**, **enumeration fields** (all-nullary data types, wired as string + enums), and **nested record fields** in addition to the primitives. + Primitive parsing is lenient: native JSON types or their string + representations are both accepted (many clients send numbers/booleans as + strings). Prompt arguments remain string-valued per the MCP specification. +* `inputSchema` is generated as a real JSON Schema (`Schema`/`SchemaType` + ADT with `enum`, `items` and nested `object`s), replacing the flat + `InputSchemaDefinition*` types that silently typed every non-primitive + field as a string. +* Tool handlers produce a `ToolResult`: multiple content blocks, + `structuredContent`, `_meta`, and `isError`. Tool *execution* failures + should be reported via `isError` (see `toolError`) so the model can see + them — per spec — instead of surfacing as JSON-RPC protocol errors. + The `ToToolResult` class keeps simple handlers simple: returning + `Content` or `Text` still works unchanged. +* Prompt handlers produce a `PromptResult` (optional description plus a + multi-message conversation with user/assistant roles) via the analogous + `ToPromptResult` class. +* `Content` gains `audio` and `resource_link` variants; embedded resources + now carry their full contents as the spec requires. +* `ToolDefinition` gains `outputSchema`; `tools/call` responses carry + `structuredContent`. +* Handler types are fixed to `IO` — the monad parameter was unusable + through the public API (both transports required `IO`). + +### Transport fixes + +* stdio: a blank line on stdin no longer terminates the server, EOF shuts + down cleanly instead of crashing, and malformed input is answered with + proper JSON-RPC error responses (`-32700`/`-32600`, `id: null`). +* stdio: raw request bodies are no longer logged to stderr by default + (tool arguments may carry sensitive data) — only message summaries. + `runMcpServerStdioWithConfig` with `stdioVerbose = True` restores full + body logging. +* JSON-RPC: messages are classified by shape (method/id presence) instead + of parse-fallthrough, so a request with a malformed `id` is answered + with an error rather than silently dropped as a notification. Request + ids must be integral. +* HTTP: new `httpAllowedOrigins` policy on `HttpConfig` (Origin + validation / DNS-rebinding protection, a spec MUST); accepted + notifications return `202` with no body; malformed bodies get JSON-RPC + error responses; the `Access-Control-Allow-Origin` header is set + consistently on every response and echoes the validated origin (with + `Vary: Origin`) when a policy is configured. +* HTTP (BREAKING): the non-spec GET "discovery" endpoint is removed — the + MCP endpoint now answers GET with `405 Method Not Allowed`, matching the + spec (no revision defines a GET discovery response, and `2026-07-28` + requires 405 here). +* Integer tool arguments bound the scientific-notation exponent (1024, the + same bound aeson uses) so a tiny payload like `1e1000000000` cannot force + allocation of a gigabyte-sized `Integer`. + +## 0.1.0.21 - 2026-07-31 + * **BREAKING**: every handler (prompt/resource/tool; list and get/read/call) now receives a `ClientContext` as its first argument, so a server can behave differently depending on who is calling. On stdio the context is anonymous; @@ -25,7 +367,7 @@ * `http-simple-example` is now built with `-threaded`, which Warp requires; previously every request crashed with a `TimerManager` error. -## 0.1.0.20 - ??? +## 0.1.0.20 - 2026-07-31 * Fix protocol version negotiation: echo back any compatible revision the client proposes (`2024-11-05`, `2025-03-26`, `2025-06-18`, `2025-11-25`) instead of diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,282 +1,809 @@ # 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**: Negotiates MCP protocol revisions `2024-11-05` through `2025-11-25` (the shared wire format for tool/resource/prompt operations) -- **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 -- ✅ **Tools**: Model-controlled callable functions -- ✅ **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`](https://github.com/drshade/haskell-mcp-server/blob/main/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; a +field without a description is described by its name): + +```json +{ + "name": "checkout", + "description": "Checkout", + "annotations": { "destructiveHint": true }, + "inputSchema": { + "type": "object", + "required": ["speed", "shipTo"], + "properties": { + "speed": { "type": "string", "enum": ["standard", "express", "overnight"], + "description": "speed" }, + "shipTo": { + "type": "object", + "description": "shipTo", + "required": ["street", "city"], + "properties": { + "street": { "type": "string", "description": "street" }, + "city": { "type": "string", "description": "city" }, + "zipCode": { "type": "string", "description": "zipCode" } + } + } + } + } +} +``` + +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). +## Connecting to a client + +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. + +### Claude Code + +```bash +# stdio: everything after -- is the command Claude Code spawns +claude mcp add my-server -- "$(cabal list-bin exe:simple-example)" + +# pass environment variables with --env +claude mcp add my-server --env API_KEY=secret -- /path/to/my-server + +# Streamable HTTP +claude mcp add --transport http my-server http://localhost:3000/mcp +``` + +Verify with `claude mcp list` or `/mcp` inside a session. Add +`--scope project` to write a `.mcp.json` you can commit for your team: + +```json +{ + "mcpServers": { + "my-server": { + "type": "stdio", + "command": "/path/to/my-server", + "env": { "API_KEY": "${API_KEY}" } + } + } +} +``` + +Cursor and several other clients read the same `mcpServers` shape. + +### Codex + +```bash +codex mcp add my-server --env API_KEY=secret -- /path/to/my-server +``` + +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" +``` + +### Claude Desktop + +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`](https://github.com/drshade/haskell-mcp-server/blob/main/Dockerfile) builds all the 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 -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +data Color = Red | Green | Blue -- all-nullary type: string enum +data Filters = Filters -- record: nested JSON object + { tags :: [Text] -- list: JSON array + , maxCount :: Maybe Int -- Maybe: optional field + } -import MCP.Server -import MCP.Server.Derive +data MyTool + = SearchItems -- "search_items" + { query :: Text + , color :: Color -- "red" | "green" | "blue" + , filters :: Filters -- { "tags": [...], "maxCount": ... } + , limit :: Maybe Int + } +``` --- Define your data types +Primitive fields (`Int`, `Integer`, `Double`, `Float`, `Bool`, `Text`) are +parsed leniently: `42` and `"42"` are both accepted, since many clients send +numbers and booleans as strings. + +A constructor may also wrap a single record type, which is unwrapped +recursively until a record is found: + +```haskell +data SetValueParams = SetValueParams { setKey :: Text, setValue :: Text } + +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 _ (SearchItems q _ _ _) + | T.null q = pure $ toolError "query must not be empty" + | otherwise = pure $ toolResult [ContentText ("Results for " <> q)] +``` + +Content blocks can carry annotations (`audience`, `priority`, +`lastModified`) via the `ContentAnnotated` wrapper: + +```haskell +ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 } + (ContentText "important result") +``` + +### 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 -- omitted when Nothing + } + +handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport) +handleTool _ (GetWeather city) = pure $ ToolOutput (lookupWeather city) +handleTool _ (BrokenTool _) = pure $ ToolOutputError "sensor offline" + +tools = Just $(deriveToolHandlerWithOutput ''MyTool 'handleTool ''WeatherReport) +``` + +`ToolOutputWith` supplies custom content blocks alongside the structured +value; `ToolOutputRaw` is the escape hatch back to a plain `ToolResult`. + +### Descriptions, annotations and icons + +Every `derive*Handler` and `deriveResourceTemplates` 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 +descriptions = + [ ("SearchItems", "Search the catalog") -- constructor + , ("query", "Search terms") -- field + ] +tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) +``` + +```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")] + }) + ]) +``` + +## Defining prompts + +Prompts derive the same way. Arguments are string-valued per the spec, so +prompt records are limited to primitive and enumeration fields: + +```haskell data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text } -data MyResource = Menu | Specials -data MyTool = Search { query :: Text } | Order { item :: Text } --- 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 _ (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items +prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) +``` + +Return a `PromptResult` instead of `Content` for a description and a +multi-message conversation with user and assistant roles. + +## 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 -- resource://menu + | ProductDetail { sku :: Text } -- resource://product_detail/{sku} + | OrderItem { orderId :: Int, itemName :: Text } -- resource://order_item/{orderId}/{itemName} + 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..." +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) = ... -handleTool :: ClientContext -> MyTool -> IO Content -handleTool _ (Search query) = pure $ ContentText $ "Search results for " <> query -handleTool _ (Order item) = pure $ ContentText $ "Ordered " <> item +resources = Just $(deriveResourceHandler ''MyResource 'handleResource) +resourceTemplates = Just $(deriveResourceTemplates ''MyResource) +``` --- 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" - } - handlers = McpServerHandlers - { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) - , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) - , tools = Just $(deriveToolHandler ''MyTool 'handleTool) - } +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. The capability is advertised +automatically when the handler is present: + +```haskell +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 [] + +handlers = noHandlers { completions = Just handleComplete, ... } ``` -### Advanced Template Haskell Features +## Assembling the server -#### Automatic Naming Conventions +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. -Constructor names are automatically converted to snake_case for MCP names: +```haskell +handlers = noHandlers + { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) + , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) + , resourceTemplates = Just $(deriveResourceTemplates ''MyResource) + , tools = Just $(deriveToolHandler ''MyTool 'handleTool) + , completions = Just handleComplete + } +``` +Two Template Haskell details to know: + +- A `derive*` splice can only see types declared in an earlier declaration + group. Either put the types in their own module (as the + [examples](https://github.com/drshade/haskell-mcp-server/tree/main/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. + +### 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 -data MyTool = GetValue | SetValue | SearchItems --- Becomes: "get_value", "set_value", "search_items" +promptListHandler :: ClientContext -> IO [PromptDefinition] +promptGetHandler :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error (Outcome PromptResult)) + +handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) } ``` -#### Automatic Type Conversion +`tools/call`, `prompts/get` and `resources/read` handlers return an +`Outcome`: `Complete result`, or a request for input (see +[Asking the user for input](#asking-the-user-for-input)). -The derivation system automatically converts Text arguments to appropriate Haskell types: +Tool schemas built by hand can use `SchemaRaw` for anything the typed +shapes cannot express — `null`, `anyOf`, `$defs` and `$ref`, numeric bounds +— and it is serialized as given: ```haskell -data MyTool = Calculate { number :: Int, factor :: Double, enabled :: Bool } --- Text "42" -> Int 42 --- Text "3.14" -> Double 3.14 --- Text "true" -> Bool True +import Data.Aeson (object, (.=)) +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Text (Text) + +nullableCount :: Schema +nullableCount = schema $ SchemaRaw $ KeyMap.fromList + [ "anyOf" .= [object ["type" .= ("null" :: Text)], object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]] ] ``` -Supported conversions: `Int`, `Integer`, `Double`, `Float`, `Bool`, and `Text` (no conversion). +A `$ref` such as `#/$defs/node` resolves against the root of the whole +input schema, not the raw fragment it appears in, so a recursive schema is +best written raw from the root down. -#### Nested Parameter Types +## Transports -You can nest parameter types with automatic unwrapping: +### 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 --- Parameter record types -data GetValueParams = GetValueParams { _gvpKey :: Text } -data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text } +import MCP.Server --- Main tool type -data SimpleTool - = GetValue GetValueParams - | SetValue SetValueParams - deriving (Show, Eq) +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 ``` -The Template Haskell derivation recursively unwraps single-parameter constructors until it reaches a record type, then extracts all fields for the MCP schema. +`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. -#### Resource URI Generation +**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. -Resources automatically get `resource://` URIs based on constructor names: +```haskell +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 + } +``` +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. + +### Embedding in an existing WAI stack + +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: + ```haskell -data MyResource = Menu | Specials --- Generates: "resource://menu", "resource://specials" +import MCP.Server (mcpApplication, defaultHttpConfig) +import qualified Network.Wai.Handler.Warp as Warp + +main = do + mcp <- mcpApplication defaultHttpConfig serverInfo handlers + Warp.runSettings mySettings $ \req respond -> + -- route /mcp to the MCP endpoint, everything else to your app + mcp req respond ``` -#### Unsupported Patterns +Build the application once: it holds the key that protects multi +round-trip state. `httpPort` and `httpHost` are ignored when embedding; the +endpoint path, Origin validation, bearer auth and streaming all apply as +usual. -We do not support positional (unnamed) parameters: +## 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 --- ❌ This won't work - no field names -data SimpleTool - = GetValue Int - | SetValue Int Text +handleTool ctx (ImportData file) = do + reportProgress ctx 0.0 (Just 1.0) (Just "starting import") + logToClient ctx LogInfo (String "opening file") + ... + reportProgress ctx 1.0 (Just 1.0) Nothing ``` -All parameter types must ultimately resolve to records with named fields to generate proper MCP schemas. +- `reportProgress` emits `notifications/progress` only when the request + carried a `progressToken`. Progress values must increase call over call. +- `logToClient` emits `notifications/message` only when the request declared + `io.modelcontextprotocol/logLevel`, as the spec requires, and drops + messages below the declared level. -## Custom Descriptions +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. -You can provide custom descriptions for constructors and fields using the `*WithDescription` variants: +### Cancellation +In-flight requests can be cancelled, after which the server stops work as soon +as practical and sends nothing further for that request: + +- **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 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 --- 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 - ] +handleTool ctx (ImportData file) = + bracket (openFile file ReadMode) hClose $ \h -> do + ... +``` --- Use in derivation -handlers = McpServerHandlers - { prompts = Just $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt descriptions) - , tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) - , resources = Just $(deriveResourceHandlerWithDescription ''MyResource 'handleResource descriptions) +Critical sections can be shielded with `mask`, but keep them short: cancellation +waits for them. + +### Concurrency + +Requests are served concurrently on both transports. Handlers touching shared +mutable state must synchronize with `MVar`, `STM` or similar. + +## Asking the user for input + +A tool, prompt or resource handler can stop part-way through and ask the +user something: a form to fill in, or a URL to visit. This uses the +2026-07-28 multi round-trip requests. Give the handler the type `Ask` +instead of `IO`, derive forms from the records you want back, and write +the questions in order, as if the handler could wait for the answers: + +```haskell +data Environment = Staging | Production + +data DeployTarget = DeployTarget + { environment :: Environment -- a choice: staging, production + , reason :: Text + , notify :: Maybe Bool -- optional } + +newtype Confirm = Confirm { proceed :: Bool } + +data OpsTool = Deploy { service :: Text } | Status { service :: Text } + +$(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")]) +$(deriveForm ''Confirm) + +handleTool :: ClientContext -> OpsTool -> Ask Content +handleTool _ (Deploy svc) = do + target <- elicit ("Where should " <> svc <> " deploy to?") + case target of + Accepted t -> do + plan <- step (planDeploy svc (environment t)) -- runs once + ok <- elicit ("Apply " <> describePlan plan <> "?") + case ok of + Accepted (Confirm True) -> ContentText <$> step (applyPlan plan) + _ -> pure (ContentText "Deployment cancelled") + Unavailable -> pure (ContentText "This client cannot ask where to deploy") + _ -> pure (ContentText "No target chosen") +handleTool _ (Status svc) = ContentText <$> liftIO (currentStatus svc) + +tools = Just $(deriveToolHandler ''OpsTool 'handleTool) ``` -## Manual Handler Implementation +`elicit` picks the form from the type the code expects back, so +`Accepted (Confirm True)` is all it takes to ask the `Confirm` form. The +answer is `Accepted` with the submitted record, `Declined` or `Cancelled`, +or `Unavailable`, without a round trip, when the client cannot ask: it +speaks an older protocol revision or did not declare form elicitation. +`elicitUrl` sends the user to a URL instead. -For fine-grained control, implement handlers manually: +The `derive*Handler` functions take `IO` and `Ask` handlers alike, so a +handler switches by changing its type. A tool that never asks, like +`Status`, finishes in one round; plain IO runs in `Ask` through `liftIO`. +Structured output works the same way: return `Ask (ToolOutput a)`. -```haskell -import MCP.Server +### Forms --- Manual handler implementation. Every handler receives the per-request --- 'ClientContext' as its first argument. -promptListHandler :: ClientContext -> IO [PromptDefinition] -promptGetHandler :: ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content) --- ... implement your custom logic +`deriveForm` builds the form's schema and its parser from a record. +Elicitation forms are flat, so the fields can be `Text`, `Int`, `Integer`, +`Double`, `Float`, `Bool`, enumerations (offered as snake_cased choices), +lists of enumerations (several choices) and `Maybe` of these for optional +fields. Anything else, such as a nested record, is a compile-time error +naming the field. `deriveFormWithDescription` adds help text per field, and +`deriveFormWithOptions` also sets labels and starting values: -main :: IO () -main = runMcpServerStdio serverInfo handlers - where - handlers = McpServerHandlers - { prompts = Just (promptListHandler, promptGetHandler) - , resources = Nothing -- Not supported - , tools = Nothing -- Not supported - } +```haskell +$(deriveFormWithOptions ''DeployTarget + [ ("environment", defaultFormFieldOptions + { formFieldTitle = Just "Environment", formFieldDefault = Just "staging" }) + , ("reason", defaultFormFieldOptions { formFieldDescription = Just "Why deploy now?" }) + ]) ``` -## HTTP Transport (NEW!) +A default that does not fit its field, or an option for a field the record +does not have, is also a compile-time error. `deriveForm` is a declaration splice, and +Template Haskell lets later splices see only the types declared above the +last declaration splice, so declare the tool, prompt and resource types +before the `deriveForm` lines (or in another module). For a form a record cannot +describe, write the `Form` instance by hand: a schema and a parser. -The library supports the MCP Streamable HTTP transport. Compile your -executable with `ghc-options: -threaded` — Warp requires the threaded runtime: +### How it works, and the rules that follow +The handler does not pause between rounds. Each round ends the request: +the client asks the user, then sends the request again with the answer, +possibly to another server instance. So the handler runs again from the +start, and the library replays a journal of what earlier rounds produced, +kept in the state the client carries: `elicit` returns the recorded +answer, or ends the round with its question; `step` returns its recorded +result instead of running the action again. + +- **Ask the same questions and run the same steps in the same order on + every round.** A handler that strays from its journal fails with an + internal error naming the position, rather than receiving the answer to + a different question. +- **`step` is at-least-once.** A client that retries from an earlier state + runs later steps again. Make effects that must happen once idempotent. +- **`step` results travel to the client and back**, encrypted, on every + later round: return an id rather than the whole object. Plain `liftIO` is + not journaled and runs on every round; use it for reads. + +### Protecting the state + +The library protects the state the client carries between rounds: it is +encrypted, and bound to the caller, the request's arguments and an expiry +(60 minutes by default), and a retry presenting tampered, expired or +misdirected state is rejected before the handler runs. By default the key +is random per process, which suits stdio and a single HTTP instance. HTTP +deployments with several instances must share a key: + ```haskell -import MCP.Server.Transport.Http +main = do + secret <- readSecret -- 32 bytes, shared by every instance + key <- maybe (fail "state key must be 32 bytes") pure (stateKey "2026-10" secret) + runMcpServerHttpWithConfig defaultHttpConfig + { httpStateCodec = Just (aeadStateCodec key []) } -- to rotate: aeadStateCodec new [old] + serverInfo handlers +``` --- Simple HTTP server (localhost:3000/mcp) -main = runMcpServerHttp serverInfo handlers +### Low-level handlers --- Custom configuration -main = runMcpServerHttpWithConfig customConfig serverInfo handlers +Hand-written call handlers return an `Outcome`: `Complete` with the result, +or `InputRequired` with requests keyed by ids of the handler's choosing and +some state of its own. On the retry the handler sees the answers in +`clientInputResponses` and its state in `clientRequestState`: + +```haskell +deploy :: ToolCallHandler +deploy ctx _ _ = pure $ Right $ + case Map.lookup "confirm" (clientInputResponses ctx) of + Nothing | clientSupportsInput ctx question -> + InputRequired (Map.singleton "confirm" question) (Just "step-1") + Just (ElicitResponse ElicitAccept (Just answer)) + | Map.lookup "ok" answer == Just (Bool True) -> + Complete (toolResult [ContentText "Deployed"]) + _ -> Complete (toolError "Not confirmed") where - customConfig = HttpConfig - { httpPort = 8080 - , httpHost = "0.0.0.0" - , httpEndpoint = "/api/mcp" - , httpVerbose = True -- Enable detailed logging - , httpAuthorize = Nothing -- No authentication (see below) - } + question = ElicitForm "Deploy to production?" + (schema (SchemaObject [("ok", schema SchemaBoolean)] ["ok"])) ``` -**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: +`clientSupportsInput` says whether the client can answer: it must speak +2026-07-28 and have declared the elicitation mode (or sampling, or roots) +in question. Asking a client that cannot answer is reported as an internal +error, so check first and fall back. A low-level handler can also run an +`Ask` computation with `runAsk`, which is what the derived handlers do. +## 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 - 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 - } +main = do + (notifier, source) <- newMcpNotifier + _ <- forkIO $ appLogic notifier -- calls notifyToolsListChanged etc. + runMcpServerStdioWithConfig + defaultStdioConfig { stdioNotifications = Just source } + serverInfo handlers ``` -**Features:** -- CORS enabled for web clients -- GET `/mcp` for server discovery -- POST `/mcp` for JSON-RPC messages -- Protocol-version negotiation across supported revisions (`2024-11-05`–`2025-11-25`) -- Optional pluggable bearer-token authentication via `httpAuthorize` +Delivery is transport- and era-aware, and the `listChanged` and `subscribe` +capabilities are advertised only where delivery is possible: -## Examples +- **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 + `notifications/resources/updated` for watched URIs. +- **Legacy stdio clients** receive spontaneous untagged notifications once + their `notifications/initialized` arrives. +- **Legacy HTTP clients** have no delivery channel, so nothing is advertised. -The library includes several examples: +## Protocol support -- **`examples/Simple/`**: Basic key-value store using Template Haskell derivation (STDIO) -- **`examples/Complete/`**: Full-featured example with prompts, resources, and tools (STDIO) -- **`examples/HttpSimple/`**: HTTP version of the simple key-value store +| 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) | +| Asking for input (multi round-trip requests) | — | `Ask` handlers and derived forms, protected `requestState` | +| Result typing and cacheability hints | — | `resultType`, `httpCacheHints` | +| HTTP request-metadata headers | — | `MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` validated | -## Docker Usage +Design decisions and planned work (OAuth resource metadata, pagination, +the tasks extension) live as ADRs under +[`specs/`](https://github.com/drshade/haskell-mcp-server/blob/main/specs/README.md), ordered by [`specs/ROADMAP.md`](https://github.com/drshade/haskell-mcp-server/blob/main/specs/ROADMAP.md). -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 -```bash -# Build the image -docker build -t haskell-mcp-server . +- [`examples/Simple/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/Simple): a key-value store with two tools over stdio. +- [`examples/Complete/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/Complete): prompts, resources, a resource + template, tools with enum, nested and list arguments, `isError`, + annotations, progress and completions. +- [`examples/Ask/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/Ask): tools that ask the user for input + part-way through: a table booking with a derived form, a confirmation + and a fallback for clients that cannot ask. +- [`examples/HttpSimple/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/HttpSimple): the key-value store over + Streamable HTTP. -# Run different examples -docker run -i --entrypoint="/usr/local/bin/simple-example" haskell-mcp-server +```bash +cabal run simple-example # stdio; type JSON-RPC on stdin +cabal run ask-example # stdio; asks for input (2026-07-28 clients) +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/`](https://github.com/drshade/haskell-mcp-server/blob/main/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 -- [MCP Specification](https://modelcontextprotocol.io/specification/2025-11-25/) -- [API Documentation](https://hackage.haskell.org/package/mcp-server) -- [Examples](examples/) +- [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/) ## 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](https://github.com/drshade/haskell-mcp-server/blob/main/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/examples/Ask/Main.hs b/examples/Ask/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Ask/Main.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Tools that ask the user for input part-way through (multi round-trip +-- requests, MCP 2026-07-28). Run it, then watch stderr while a client +-- books a table: the handler replays from the top on every round, but each +-- 'step' runs once in a normal booking, its result replayed afterwards. +-- +-- 'step' is at-least-once, though: a client that retries a round with an +-- earlier state (say, after losing a reply) runs the steps after that point +-- again. A real 'confirmBooking' must therefore be idempotent, for example +-- by keying the booking on something the retry repeats. +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import MCP.Server +import MCP.Server.Derive +import System.IO (hPutStrLn, hSetEncoding, stderr, + stdout, utf8) +import Types + +-- Returning 'Ask' instead of 'IO' is all it takes to ask questions. +handleTool :: ClientContext -> BookingTool -> Ask Content +handleTool _ (BookTable place) = do + -- Ask for the details. 'elicit' picks the form from the type the + -- answer is used at: BookingDetails. + answer <- elicit ("Booking a table at " <> place <> ". What do you need?") + case answer of + Accepted details -> do + -- Work between questions goes in 'step': it runs once, and + -- its result is replayed on later rounds. + offer <- step (findTable place details) + ok <- elicit ("Book " <> offer <> "?") + case ok of + Accepted (Confirm True) -> do + ref <- step (confirmBooking offer) + pure $ ContentText $ "Booked " <> offer <> ". Your reference is " <> ref <> "." + _ -> pure $ ContentText "No problem, nothing was booked." + Declined -> pure $ ContentText "No problem, nothing was booked." + Cancelled -> pure $ ContentText "Booking cancelled." + -- The client cannot show forms (an older protocol revision, or no + -- elicitation capability): no round trip happens, so say what to do. + Unavailable -> pure $ ContentText $ + "I can't ask for booking details in this client. Please call " + <> place <> " to book." + +handleTool _ (CancelBooking ref) = do + ok <- elicit ("Cancel booking " <> ref <> "? This cannot be undone.") + case ok of + Accepted (Confirm True) -> do + _ <- step (cancelBooking ref) + pure $ ContentText $ "Booking " <> ref <> " is cancelled." + -- Cancelling without confirmation would be destructive: refuse. + Unavailable -> pure $ ContentText "Cancelling needs confirmation, which this client can't ask for." + _ -> pure $ ContentText $ "Booking " <> ref <> " is unchanged." + +-- A tool that never asks finishes in one round; plain IO goes through liftIO. +handleTool _ (OpeningHours place) = + ContentText <$> liftIO (lookupHours place) + +-- The "back end". Each logs to stderr so you can see when it runs. + +findTable :: Text -> BookingDetails -> IO Text +findTable place details = do + logLine $ "finding a table at " <> place <> " for " <> T.pack (show details) + pure $ "a table for " <> T.pack (show (partySize details)) <> " at " <> place + <> ", " <> slotTime (slot details) + <> (if null (dietary details) then "" else " (kitchen notified: " + <> T.intercalate ", " (map dietLabel (dietary details)) <> ")") + <> (if highChair details == Just True then " with a high chair" else "") + +-- Not idempotent: a retried final round would book again under a new +-- reference. Fine for a demo; see the note at the top of the module. +confirmBooking :: Text -> IO Text +confirmBooking offer = do + now <- getPOSIXTime + let ref = "BK-" <> T.pack (show (floor now `mod` (100000 :: Integer))) + logLine $ "booked " <> offer <> " as " <> ref + pure ref + +cancelBooking :: Text -> IO () +cancelBooking ref = logLine $ "cancelled " <> ref + +lookupHours :: Text -> IO Text +lookupHours place = pure $ place <> " is open 12:00-15:00 and 17:30-23:00, Tuesday to Sunday." + +slotTime :: Slot -> Text +slotTime Lunch = "13:00" +slotTime EarlyDinner = "18:00" +slotTime LateDinner = "20:30" + +dietLabel :: Diet -> Text +dietLabel Vegetarian = "vegetarian" +dietLabel Vegan = "vegan" +dietLabel GlutenFree = "gluten-free" +dietLabel NutAllergy = "nut allergy" + +logLine :: Text -> IO () +logLine = hPutStrLn stderr . ("[bookings] " <>) . T.unpack + +main :: IO () +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + runMcpServerStdio + McpServerInfo + { serverName = "Table Booking Example" + , serverVersion = "0.1.0" + , serverInstructions = "Books restaurant tables, asking the user for the details." + } + noHandlers + { tools = Just $(deriveToolHandlerWithOptions ''BookingTool 'handleTool + [ ("BookTable", defaultDefinitionOptions + { optDescription = Just "Book a table at a restaurant; asks the user for the details" }) + , ("CancelBooking", defaultDefinitionOptions + { optDescription = Just "Cancel a booking by its reference, after confirming with the user" + , optToolAnnotations = Just defaultToolAnnotations { toolDestructiveHint = Just True } }) + , ("OpeningHours", defaultDefinitionOptions + { optDescription = Just "A restaurant's opening hours" + , optToolAnnotations = Just defaultToolAnnotations { toolReadOnlyHint = Just True } }) + ]) + } diff --git a/examples/Ask/Types.hs b/examples/Ask/Types.hs new file mode 100644 --- /dev/null +++ b/examples/Ask/Types.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Types where + +import Data.Text (Text) +import MCP.Server.Derive + +-- The tools. Declared above the deriveForm splices below: a splice only +-- sees the types declared above the last declaration splice. +data BookingTool + = BookTable { restaurant :: Text } + | CancelBooking { reference :: Text } + | OpeningHours { restaurant :: Text } + deriving (Show, Eq) + +-- The forms: plain records whose answers the handlers want back. + +-- An enumeration is offered as a choice ("lunch", "early_dinner", ...) +data Slot = Lunch | EarlyDinner | LateDinner + deriving (Show, Eq) + +data Diet = Vegetarian | Vegan | GlutenFree | NutAllergy + deriving (Show, Eq) + +data BookingDetails = BookingDetails + { partySize :: Int + , slot :: Slot + , dietary :: [Diet] -- a list of an enumeration: pick several + , highChair :: Maybe Bool -- Maybe: the user may leave it out + } deriving (Show, Eq) + +-- A yes/no question is a one-field form +newtype Confirm = Confirm { confirmed :: Bool } + deriving (Show, Eq) + +-- Labels, help text and starting values for the form's fields. A default +-- that does not fit its field is a compile-time error. +$(deriveFormWithOptions ''BookingDetails + [ ("partySize", defaultFormFieldOptions + { formFieldTitle = Just "Party size", formFieldDefault = Just (Number 2) }) + , ("slot", defaultFormFieldOptions + { formFieldTitle = Just "Time", formFieldDefault = Just "early_dinner" }) + , ("dietary", defaultFormFieldOptions + { formFieldTitle = Just "Dietary requirements" + , formFieldDescription = Just "Tick any that apply to your party" }) + , ("highChair", defaultFormFieldOptions { formFieldTitle = Just "Need a high chair?" }) + ]) + +$(deriveFormWithDescription ''Confirm [("confirmed", "Tick to confirm")]) diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -3,6 +3,9 @@ module Main where +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Text as T import MCP.Server import MCP.Server.Derive import System.IO (hSetEncoding, stderr, stdout, utf8) @@ -23,19 +26,45 @@ pure $ ResourceText uri "text/plain" "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf" handleResource _ uri HeadlineBannerAd = pure $ ResourceText uri "text/plain" "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎" +handleResource _ uri (ProductDetail sku) = + pure $ ResourceText uri "text/plain" $ "Details for product " <> sku <> ": in stock, $9.99" -handleTool :: ClientContext -> MyTool -> IO Content -handleTool _ (SearchForProduct q category) = - case category of - Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories" - Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products" -handleTool _ (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items" -handleTool _ Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!" +-- Tool handlers return a full ToolResult: execution failures are reported +-- with isError so the model can see them (returning plain Content works too +-- for simple tools — see the other examples). +handleTool :: ClientContext -> MyTool -> IO ToolResult +handleTool ctx (SearchForProduct q category) = do + -- Progress reporting is safe to call unconditionally: it is a no-op + -- unless the request carried a progressToken + reportProgress ctx 0.5 (Just 1.0) (Just "searching the catalog") + result <- case category of + Nothing -> pure $ toolResult [ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"] + Just cat -> pure $ toolResult [ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"] + reportProgress ctx 1.0 (Just 1.0) Nothing + pure result +handleTool _ (AddToCart sku quantities) + | any (<= 0) quantities = pure $ toolError "Quantities must be positive" + | otherwise = pure $ toolResult + [ContentText $ "Added " <> T.pack (show (sum quantities)) <> " of item " <> sku <> " to your cart"] +handleTool _ (Checkout speed (Address street city zipCode)) = + pure $ toolResult + [ ContentText $ "Checkout completed! Order #12345 will ship " + <> T.pack (show speed) <> " to " <> street <> ", " <> city + <> maybe "" (" " <>) zipCode + ] handleTool _ (ComplexTool field1 field2 field3 field4 field5) = - pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> + pure $ toolResult + [ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> maybe "" (", " <>) field3 <> ", " <> field4 <> - maybe "" (", " <>) field5 + maybe "" (", " <>) field5] +-- Argument autocompletion for the Recipe prompt's idea argument +handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult) +handleComplete _ (CompletionRefPrompt "recipe") "idea" partial _ = + pure $ Right $ completionResult $ + filter (T.isPrefixOf (T.toLower partial)) ["pancakes", "pasta", "pizza"] +handleComplete _ _ _ _ _ = pure $ Right $ completionResult [] + main :: IO () main = do -- Set UTF-8 encoding to handle Unicode characters properly @@ -44,15 +73,32 @@ -- Derive the handlers using Template Haskell let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) - tools = $(deriveToolHandler ''MyTool 'handleTool) + templates = $(deriveResourceTemplates ''MyResource) + -- Per-constructor options: descriptions, behavioral hints for + -- client permission UX, icons, and constructor-scoped argument + -- descriptions + tools = $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("SearchForProduct", defaultDefinitionOptions + { optDescription = Just "Search the product catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optFieldDescriptions = [("q", "Search terms"), ("category", "Restrict to a category")] + }) + , ("Checkout", defaultDefinitionOptions + { optToolAnnotations = Just defaultToolAnnotations + { toolDestructiveHint = Just True } + }) + ]) in runMcpServerStdio McpServerInfo { serverName = "Complete Example MCP Server" , serverVersion = "0.3.0" , serverInstructions = "An example MCP server that handles prompts, resources, and tools." } - McpServerHandlers + noHandlers { prompts = Just prompts , resources = Just resources + , resourceTemplates = Just templates , tools = Just tools + , completions = Just handleComplete } diff --git a/examples/Complete/Types.hs b/examples/Complete/Types.hs --- a/examples/Complete/Types.hs +++ b/examples/Complete/Types.hs @@ -4,7 +4,7 @@ import Data.Text (Text) --- High-level data type definitions from SPEC.md +-- High-level data type definitions (see specs/ADR_0001_original_spec.md) data MyPrompt = Recipe { idea :: Text } @@ -15,11 +15,29 @@ = ProductCategories | SaleItems | HeadlineBannerAd + -- A record constructor becomes a resource template: + -- resource://product_detail/{productSku} + | ProductDetail { productSku :: Text } deriving (Show, Eq) +-- An enumeration argument: all-nullary data types become string enums in +-- the generated schema ("standard", "express", "overnight") +data ShippingSpeed + = Standard + | Express + | Overnight + deriving (Show, Eq) + +-- A nested record argument: appears as a JSON object in the schema +data Address = Address + { street :: Text + , city :: Text + , zipCode :: Maybe Text + } deriving (Show, Eq) + data MyTool = SearchForProduct { q :: Text, category :: Maybe Text } - | AddToCart { sku :: Text } - | Checkout + | AddToCart { sku :: Text, quantities :: [Int] } + | Checkout { speed :: ShippingSpeed, shipTo :: Address } | ComplexTool { field1 :: Text, field2 :: Text, field3 :: Maybe Text, field4 :: Text, field5 :: Maybe Text } deriving (Show, Eq) diff --git a/examples/HttpSimple/Main.hs b/examples/HttpSimple/Main.hs --- a/examples/HttpSimple/Main.hs +++ b/examples/HttpSimple/Main.hs @@ -23,9 +23,7 @@ Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found" Just v -> pure $ ContentText v handleTool _ (SetValue k v) = do - pairs <- readIORef store - let newPairs = (k, v) : filter ((/= k) . fst) pairs - writeIORef store newPairs + atomicModifyIORef' store $ \pairs -> ((k, v) : filter ((/= k) . fst) pairs, ()) pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'" -- Derive the tool handlers using Template Haskell with descriptions @@ -36,8 +34,6 @@ , serverVersion = "1.0.0" , serverInstructions = "A simple HTTP key-value store with GetValue and SetValue tools" } - McpServerHandlers - { prompts = Nothing -- No prompts in this example - , resources = Nothing -- No resources in this example - , tools = Just tools -- Only tools in this example + noHandlers + { tools = Just tools -- Only tools in this example } diff --git a/examples/Simple/Main.hs b/examples/Simple/Main.hs --- a/examples/Simple/Main.hs +++ b/examples/Simple/Main.hs @@ -23,9 +23,7 @@ Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found" Just v -> pure $ ContentText v handleTool _ (SetValue k v) = do - pairs <- readIORef store - let newPairs = (k, v) : filter ((/= k) . fst) pairs - writeIORef store newPairs + atomicModifyIORef' store $ \pairs -> ((k, v) : filter ((/= k) . fst) pairs, ()) pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'" -- Derive the tool handlers using Template Haskell with descriptions @@ -36,8 +34,6 @@ , serverVersion = "1.0.0" , serverInstructions = "A simple key-value store with GetValue and SetValue tools" } - McpServerHandlers - { prompts = Nothing -- No prompts in this example - , resources = Nothing -- No resources in this example - , tools = Just tools -- Only tools in this example + noHandlers + { tools = Just tools -- Only tools in this example } 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.1.0.21 +version: 0.3.0.1 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -49,9 +49,14 @@ || == 9.8.4 || == 9.10.3 || == 9.12.2 + || == 9.14.1 -- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: SPEC.md +extra-source-files: + test/golden/README.md + test/golden/manifest.json + test/golden/legacy/*.json + test/golden/modern/*.json -- Source repository information source-repository head type: git @@ -66,16 +71,21 @@ -- Modules exported by the library. exposed-modules: MCP.Server + MCP.Server.Ask MCP.Server.Derive MCP.Server.Handlers MCP.Server.JsonRpc + MCP.Server.Notifications MCP.Server.Protocol + MCP.Server.RequestState MCP.Server.Transport.Http MCP.Server.Transport.Stdio MCP.Server.Types other-modules: MCP.Server.Derive.Internal + MCP.Server.Internal.InputRound + MCP.Server.Internal.Json -- Modules included in this library but not exported. -- other-modules: @@ -84,13 +94,20 @@ -- Other library packages from which modules are imported. build-depends: aeson >=2 && <3, + async >=2.2 && <2.3, base >=4.18 && <4.23, + base64-bytestring >=1.0 && <1.3, bytestring >=0.10 && <0.13, containers >=0.6 && <0.9, + crypton >=1.1.4 && <2.3, http-types >=0.12 && <1, network-uri >=2.6 && <2.8, + ram >=0.20.1 && <0.23, + scientific >=0.3 && <0.4, + stm >=2.5 && <2.6, template-haskell >=2.16 && <2.25, text >=1.2 && <3, + time >=1.9 && <1.17, wai >=3.2 && <4, warp >=3.3 && <4, @@ -131,6 +148,7 @@ -- Other library packages from which modules are imported. build-depends: base, + containers, mcp-server, text, @@ -139,6 +157,25 @@ -- Base language which the package is written in. default-language: GHC2021 +executable ask-example + -- Import common warning flags. + import: warnings + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + -- Modules included in this executable, other than Main. + other-modules: Types + -- Other library packages from which modules are imported. + build-depends: + base, + mcp-server, + text, + time, + + -- Directories containing source files. + hs-source-dirs: examples/Ask + -- Base language which the package is written in. + default-language: GHC2021 + executable http-simple-example -- Import common warning flags. import: warnings @@ -168,14 +205,31 @@ default-language: GHC2021 -- Modules included in this executable, other than Main. other-modules: + AskTypes Spec.AdvancedDerivation + Spec.AskMonad Spec.BasicDerivation + Spec.Cancellation + Spec.DefinitionMetadata + Spec.DerivedAsk + Spec.DerivedOutput + Spec.GoldenWire + Spec.HandlerExceptions + Spec.HttpTransport + Spec.InputRequired Spec.JSONConversion + Spec.ModernEra + Spec.Progress Spec.ProtocolVersionNegotiation + Spec.RawSchema Spec.SchemaValidation + Spec.Subscriptions + Spec.TemplatesCompletions Spec.ToolCallParsing + Spec.TypedArgs Spec.UnicodeHandling TestData + TestHelpers TestTypes -- LANGUAGE extensions used by modules in this package. @@ -190,9 +244,16 @@ build-depends: QuickCheck, aeson, + async, base, bytestring, + containers, + directory, hspec, + http-types, mcp-server, network-uri, + stm, + template-haskell, text, + wai, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -1,51 +1,69 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Build an MCP server: run it over stdio or HTTP, or mount it as a WAI +-- application, with the handler and definition types re-exported from +-- "MCP.Server.Types". "MCP.Server.Derive" generates handlers from data +-- types. module MCP.Server ( -- * Server Runtime runMcpServerStdio + , runMcpServerStdioWithConfig , runMcpServerHttp , runMcpServerHttpWithConfig -- * Transport Configuration + , StdioConfig(..) + , defaultStdioConfig , HttpConfig(..) + , defaultHttpConfig + , mcpApplication - -- * Utility Functions - , jsonValueToText + -- * Handlers that ask the client for input + , module MCP.Server.Ask + -- * Request state (multi round-trip requests) + , StateCodec(..) + , StateError(..) + , StateKey + , stateKey + , stateKeyId + , aeadStateCodec + , ephemeralStateCodec + , defaultStateLifetime + + -- * Change Notifications + , McpNotifier(..) + , NotificationSource + , newMcpNotifier + -- * Re-exports , module MCP.Server.Types ) where -import Data.Aeson -import Data.Text (Text) -import qualified Data.Text as T - -import MCP.Server.Transport.Stdio (transportRunStdio) -import MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig) +import MCP.Server.Ask +import MCP.Server.Notifications (McpNotifier (..), NotificationSource, + newMcpNotifier) +import MCP.Server.Transport.Stdio (StdioConfig (..), defaultStdioConfig, + transportRunStdio, + transportRunStdioWithConfig) +import MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig, + mcpApplication) +import MCP.Server.RequestState import MCP.Server.Types --- | Convert JSON Value to Text representation suitable for handlers -jsonValueToText :: Value -> Text -jsonValueToText (String t) = t -jsonValueToText (Number n) = - -- Check if it's a whole number, if so format as integer - if fromInteger (round n) == n - then T.pack $ show (round n :: Integer) - else T.pack $ show n -jsonValueToText (Bool True) = "true" -jsonValueToText (Bool False) = "false" -jsonValueToText Null = "" -jsonValueToText v = T.pack $ show v - -- | Run an MCP server using STDIO transport -runMcpServerStdio :: McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerStdio serverInfo handlers = transportRunStdio serverInfo handlers +runMcpServerStdio :: McpServerInfo -> McpServerHandlers -> IO () +runMcpServerStdio = transportRunStdio +-- | Run an MCP server using STDIO transport with custom configuration +runMcpServerStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO () +runMcpServerStdioWithConfig = transportRunStdioWithConfig + -- | Run an MCP server using HTTP transport with default configuration -runMcpServerHttp :: McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerHttp serverInfo handlers = transportRunHttp defaultHttpConfig serverInfo handlers +runMcpServerHttp :: McpServerInfo -> McpServerHandlers -> IO () +runMcpServerHttp = transportRunHttp defaultHttpConfig -- | Run an MCP server using HTTP transport with custom configuration -runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerHttpWithConfig config serverInfo handlers = transportRunHttp config serverInfo handlers +runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () +runMcpServerHttpWithConfig = transportRunHttp diff --git a/src/MCP/Server/Ask.hs b/src/MCP/Server/Ask.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Ask.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Handlers that ask the client questions part-way through, written as +-- straight-line code. +-- +-- A multi round-trip request ends each round that needs input: the client +-- answers and retries the request, possibly on another server instance. +-- So an t'Ask' handler does not pause at a question. It runs from the start +-- on every round, against a /journal/ of what earlier rounds produced, which +-- the library keeps sealed in the request state: +-- +-- * 'elicit' returns the answer recorded for it, or ends the round with the +-- question when there is none yet. +-- * 'step' runs its action once, records the result, and returns the +-- recorded result on later rounds. +-- +-- > confirmDelete :: ClientContext -> Text -> Ask ToolResult +-- > confirmDelete _ name = do +-- > size <- step (fileSize name) +-- > answer <- elicit ("Delete " <> name <> " (" <> showSize size <> ")?") +-- > case answer of +-- > Accepted (Confirm True) -> do +-- > step (deleteFile name) +-- > pure (toolResult [ContentText "Deleted"]) +-- > Unavailable -> pure (toolError "Confirmation needed: this client cannot ask") +-- > _ -> pure (toolResult [ContentText "Kept"]) +-- +-- Three rules follow from replay: +-- +-- * __Ask the same questions in the same order.__ Each 'elicit' and 'step' +-- takes the next position in the journal. If a round asks something +-- different at a position, the request fails with an internal error that +-- names the position, rather than passing an answer to the wrong question. +-- * __'step' is at-least-once.__ If a round's reply is lost and the client +-- retries with an earlier state, the step runs again. Effects that must +-- happen once must be idempotent or guarded on the server. +-- * __'step' results travel to the client and back__ (encrypted) on every +-- later round. Keep them small: an id rather than the object. +-- +-- Plain 'liftIO' is not journaled: it runs on every round. Use it for reads +-- that may change between rounds without changing which questions are +-- asked. +-- +-- Derived handlers ("MCP.Server.Derive") may return t'Ask' instead of +-- 'IO', and 'MCP.Server.Derive.deriveForm' derives t'Form' instances from +-- records. +module MCP.Server.Ask + ( -- * Handlers that ask + Ask + , runAsk + , askContext + -- * Questions + , Answer(..) + , Form(..) + , elicit + , elicitUrl + -- * Journaled IO + , step + -- * Derived handlers + , HandlerMonad(..) + ) where + +import Control.Monad (ap, liftM) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as BSL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import MCP.Server.Internal.Json (jsonDigest) +import MCP.Server.Types + +-- | How the user answered a question. +data Answer a + = Accepted a + -- ^ The user submitted the form (for 'elicitUrl': completed the + -- interaction). + | Declined + -- ^ The user explicitly declined. + | Cancelled + -- ^ The user dismissed the question without choosing. + | Unavailable + -- ^ The client cannot ask: it speaks a protocol revision without + -- multi round-trip requests, or did not declare the elicitation + -- mode. No round trip took place. + deriving (Show, Eq, Functor) + +-- | A form to elicit: an object of strings, numbers, booleans and +-- enumerations, as elicitation allows, and how to read what the user +-- submitted. 'formParse' defaults to the type's 'FromJSON' instance. +-- +-- > data Confirm = Confirm { proceed :: Bool } deriving Generic +-- > instance FromJSON Confirm +-- > instance Form Confirm where +-- > formSchema _ = schema $ SchemaObject [("proceed", schema SchemaBoolean)] ["proceed"] +class Form a where + -- | The requested schema. + formSchema :: Proxy a -> Schema + -- | Read the submitted content, or say why it does not fit the form. + formParse :: Map Text Value -> Either Text a + default formParse :: FromJSON a => Map Text Value -> Either Text a + formParse content = either (Left . T.pack) Right (parseEither parseJSON (toJSON content)) + +-- | A handler that can ask the client for input. Run it with 'runAsk'. +newtype Ask a = Ask (ClientContext -> Run -> IO (Round a)) + +-- Where a run is in the journal. +data Run = Run + { runReplay :: [Entry] -- entries from earlier rounds not yet reached + , runPending :: Maybe Text -- fingerprint of the question the last round asked + , runPosition :: Int + , runWritten :: [Entry] -- the journal so far, newest first + } + +data Round a + = Done a Run + | Suspended Int Text InputRequest [Entry] -- position, fingerprint, request, journal + | Failed Error + +instance Functor Ask where + fmap = liftM + +instance Applicative Ask where + pure a = Ask $ \_ run -> pure (Done a run) + (<*>) = ap + +instance Monad Ask where + Ask m >>= k = Ask $ \ctx run -> do + result <- m ctx run + case result of + Done a run' -> let Ask m' = k a in m' ctx run' + Suspended pos fp req entries -> pure (Suspended pos fp req entries) + Failed err -> pure (Failed err) + +-- | Runs on every round; not journaled. +instance MonadIO Ask where + liftIO io = Ask $ \_ run -> (\a -> Done a run) <$> io + +-- | The context of the current round's request. +askContext :: Ask ClientContext +askContext = Ask $ \ctx run -> pure (Done ctx run) + +-- | Run a handler for one round: 'Complete' when it finishes, or +-- 'InputRequired' with its next question and its journal as the state. +-- Use it in a low-level call handler; derived handlers are run with it +-- for you (see t'HandlerMonad'). +runAsk :: Ask a -> ClientContext -> IO (Either Error (Outcome a)) +runAsk (Ask m) ctx = case readJournal (clientRequestState ctx) of + Left err -> pure (Left (InternalError err)) + Right (Journal entries pending) -> do + result <- m ctx Run + { runReplay = entries + , runPending = pending + , runPosition = 0 + , runWritten = [] + } + pure $ case result of + Done a run + | null (runReplay run), Nothing <- runPending run -> Right (Complete a) + | otherwise -> Left $ mismatch (runPosition run) + "the handler finished before reaching it" + Suspended pos fp request written -> Right $ InputRequired + (Map.singleton (positionKey pos) request) + (Just (writeJournal (Journal written (Just fp)))) + Failed err -> Left err + +-- | The monads a derived handler can run in: 'IO' for handlers that never +-- ask, and t'Ask' for handlers that do. The @derive*Handler@ splices run +-- the handler through this class, so either return type works and a handler +-- switches by changing its type alone. +class Monad m => HandlerMonad m where + -- | Run a handler for one round of a request. + runHandler :: ClientContext -> m a -> IO (Either Error (Outcome a)) + +instance HandlerMonad IO where + runHandler _ action = Right . Complete <$> action + +instance HandlerMonad Ask where + runHandler ctx handler = runAsk handler ctx + +-- | Ask the user to fill in the form for @a@, with a message. +elicit :: Form a => Text -> Ask (Answer a) +elicit message = result + where + result = question (ElicitForm message (formSchema (proxyOf result))) parse + parse (Just content) = formParse content + parse Nothing = Left "accepted without content" + proxyOf :: Ask (Answer a) -> Proxy a + proxyOf _ = Proxy + +-- | Send the user to a URL to complete an interaction out of band, with a +-- message. 'Accepted' means the user agreed to go; the interaction's +-- result reaches the server by other means. +elicitUrl :: Text -> URI -> Ask (Answer ()) +elicitUrl message url = question (ElicitUrl message url) (const (Right ())) + +-- | Run an action once, and replay its result on later rounds. The result +-- is stored in the request state, so it must survive a JSON round trip; it +-- is returned decoded on every round, the first included. +step :: (ToJSON a, FromJSON a) => IO a -> Ask a +step action = Ask $ \_ run -> case (runReplay run, runPending run) of + (Stepped v : rest, _) -> pure $ case fromJSON v of + Success a -> Done a (advance (Stepped v) run { runReplay = rest }) + Error err -> Failed $ InternalError $ + "the step result at position " <> showT (runPosition run) + <> " no longer decodes: " <> T.pack err + (_ : _, _) -> pure $ Failed $ mismatch (runPosition run) "the handler ran a step instead" + ([], Just _) -> pure $ Failed $ mismatch (runPosition run) "the handler ran a step instead" + ([], Nothing) -> do + v <- toJSON <$> action + pure $ case fromJSON v of + Success a -> Done a (advance (Stepped v) run) + Error err -> Failed $ InternalError $ + "the step result at position " <> showT (runPosition run) + <> " does not decode from its own JSON: " <> T.pack err + +-- A question at the next position: the request, and how to read an +-- accepted answer's content. +question :: InputRequest -> (Maybe (Map Text Value) -> Either Text a) -> Ask (Answer a) +question request parse = Ask $ \ctx run -> + let pos = runPosition run + key = positionKey pos + fp = jsonDigest (toJSON request) + record recorded = advance (Asked fp recorded) run + suspend = Suspended pos fp request (reverse (runWritten run)) + supported = clientSupportsInput ctx request + in pure $ case (runReplay run, runPending run) of + (Asked fp' recorded : rest, _) + | fp' == fp -> case answerOf parse recorded of + Right a -> Done a (record recorded) { runReplay = rest } + Left err -> Failed $ InternalError $ + "the answer at position " <> key <> " no longer parses: " <> err + (_ : _, _) -> Failed $ mismatch pos "the handler asked a different question" + ([], Just fp') + | fp' /= fp -> Failed $ mismatch pos "the handler asked a different question" + | otherwise -> case Map.lookup key (clientInputResponses ctx) of + Nothing + | supported -> suspend + | otherwise -> Done Unavailable (record Unavailable') { runPending = Nothing } + Just response -> case recordResponse response >>= \r -> (,) r <$> answerOf parse r of + Right (recorded, a) -> Done a (record recorded) { runPending = Nothing } + Left err -> Failed $ InvalidParams $ "inputResponses: " <> key <> ": " <> err + ([], Nothing) + | supported -> suspend + | otherwise -> Done Unavailable (record Unavailable') + +advance :: Entry -> Run -> Run +advance entry run = run + { runPosition = runPosition run + 1 + , runWritten = entry : runWritten run + } + +mismatch :: Int -> Text -> Error +mismatch pos what = InternalError $ + "the handler does not match its journal at position " <> showT pos <> ": " + <> what <> ". Ask handlers must ask the same questions and run the same steps" + <> " in the same order on every round" + +positionKey :: Int -> Text +positionKey = showT + +showT :: Show a => a -> Text +showT = T.pack . show + +-- The journal ------------------------------------------------------------ + +data Journal = Journal [Entry] (Maybe Text) + +data Entry + = Asked Text Recorded -- the question's fingerprint, and its answer + | Stepped Value + +data Recorded + = Accepted' (Maybe (Map Text Value)) + | Declined' + | Cancelled' + | Unavailable' + +recordResponse :: InputResponse -> Either Text Recorded +recordResponse (ElicitResponse action content) = Right $ case action of + ElicitAccept -> Accepted' content + ElicitDecline -> Declined' + ElicitCancel -> Cancelled' +recordResponse (RawInputResponse _) = Left "expected an elicitation result" + +answerOf :: (Maybe (Map Text Value) -> Either Text a) -> Recorded -> Either Text (Answer a) +answerOf parse (Accepted' content) = Accepted <$> parse content +answerOf _ Declined' = Right Declined +answerOf _ Cancelled' = Right Cancelled +answerOf _ Unavailable' = Right Unavailable + +instance ToJSON Entry where + toJSON (Asked fp recorded) = object $ ("q" .= fp) : case recorded of + Accepted' content -> ["a" .= ("accept" :: Text), "c" .= content] + Declined' -> ["a" .= ("decline" :: Text)] + Cancelled' -> ["a" .= ("cancel" :: Text)] + Unavailable' -> ["a" .= ("unavailable" :: Text)] + toJSON (Stepped v) = object ["s" .= v] + +instance FromJSON Entry where + parseJSON = withObject "Entry" $ \o -> do + -- By presence: a step's result may itself be null. + case KM.lookup "s" o of + Just v -> pure (Stepped v) + Nothing -> do + fp <- o .: "q" + action <- o .: "a" + Asked fp <$> case action :: Text of + "accept" -> Accepted' <$> o .:? "c" + "decline" -> pure Declined' + "cancel" -> pure Cancelled' + "unavailable" -> pure Unavailable' + _ -> fail "unknown answer" + +writeJournal :: Journal -> Text +writeJournal (Journal entries pending) = TE.decodeUtf8 $ BSL.toStrict $ encode $ object + [ "v" .= (1 :: Int) + , "j" .= entries + , "p" .= pending + ] + +readJournal :: Maybe Text -> Either Text Journal +readJournal Nothing = Right (Journal [] Nothing) +readJournal (Just state) = + either (\err -> Left ("the request state is not an Ask journal: " <> T.pack err)) Right $ + eitherDecodeStrict (TE.encodeUtf8 state) >>= parseEither parser + where + parser = withObject "Journal" $ \o -> do + version <- o .: "v" + if version /= (1 :: Int) + then fail "unsupported journal version" + else Journal <$> o .: "j" <*> o .:? "p" diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -1,434 +1,980 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Template Haskell utilities for deriving MCP handlers from data types. -module MCP.Server.Derive - ( -- * Template Haskell Derivation - derivePromptHandler - , derivePromptHandlerWithDescription - , deriveResourceHandler - , deriveResourceHandlerWithDescription - , deriveToolHandler - , deriveToolHandlerWithDescription - ) where - -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Language.Haskell.TH -import qualified Data.Char as Char - -import MCP.Server.Derive.Internal -import MCP.Server.Types - -------------------------------------------------------------------------------- --- Small helpers -------------------------------------------------------------------------------- - --- Helper function to convert PascalCase/camelCase to snake_case --- --- >>> toSnakeCase "GetValue" --- "get_value" -toSnakeCase :: String -> String -toSnakeCase [] = [] -toSnakeCase (x:xs) = Char.toLower x : go xs - where - go [] = [] - go (c:cs) - | Char.isUpper c = '_' : Char.toLower c : go cs - | otherwise = c : go cs - --- Snake-cased name from a TH Name -snakeName :: Name -> String -snakeName = toSnakeCase . nameBase - --- Check if a type is Maybe, and unwrap it -unwrapMaybe :: Type -> (Bool, Type) -unwrapMaybe (AppT (ConT n) inner) | nameBase n == "Maybe" = (True, inner) -unwrapMaybe other = (False, other) - --- Look up description with a default -descriptionFor :: [(String, String)] -> String -> String -> String -descriptionFor descriptions key fallback = - fromMaybe fallback (lookup key descriptions) - --- Map a Haskell type to its JSON schema type string -jsonTypeFor :: Type -> String -jsonTypeFor (ConT n) - | nameBase n == "Int" = "integer" - | nameBase n == "Integer" = "integer" - | nameBase n == "Double" = "number" - | nameBase n == "Float" = "number" - | nameBase n == "Bool" = "boolean" -jsonTypeFor _ = "string" - --- Helper function to convert Clause to Match -clauseToMatch :: Clause -> Match -clauseToMatch (Clause ps b ds) = Match (case ps of [p] -> p; _ -> TupP ps) b ds - --- Get fields from a constructor: [] for nullary, record fields for RecC, --- extracted fields for single-param NormalC -getConFields :: Con -> Q [(Name, Bang, Type)] -getConFields (NormalC _ []) = pure [] -getConFields (RecC _ fields) = pure fields -getConFields (NormalC _ [(_bang, paramType)]) = extractFieldsFromParamType paramType -getConFields _ = fail "Unsupported constructor type" - --- Get the constructor name from a Con -conName :: Con -> Name -conName (NormalC n _) = n -conName (RecC n _) = n -conName (InfixC _ n _) = n -conName (ForallC _ _ c) = conName c -conName (GadtC (n:_) _ _) = n -conName (RecGadtC (n:_) _ _) = n -conName _ = error "conName: empty GADT constructor list" - --- Compute required field names (non-Maybe fields) -requiredFieldNames :: [(Name, Bang, Type)] -> [String] -requiredFieldNames fields = - [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ] - -------------------------------------------------------------------------------- --- Prompt derivation -------------------------------------------------------------------------------- - --- | Derive prompt handlers from a data type with custom descriptions. --- Usage: --- --- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) -derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -derivePromptHandlerWithDescription typeName handlerName descriptions = do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ constructors _) -> do - -- Generate prompt definitions - promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors - - -- Generate list handler - listHandlerExp <- [| \_ctx -> pure $(return $ ListE promptDefs) |] - - -- Generate get handler with cases - cases <- traverse (mkDispatchCase handlerName) constructors - defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |] - let defaultMatch = Match WildP (NormalB defaultCase) [] - let getHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $ - CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) - (map clauseToMatch cases ++ [defaultMatch]) - - return $ TupE [Just listHandlerExp, Just getHandlerExp] - _ -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" - --- | Derive prompt handlers from a data type. --- Usage: --- --- > $(derivePromptHandler ''MyPrompt 'handlePrompt) -derivePromptHandler :: Name -> Name -> Q Exp -derivePromptHandler typeName handlerName = - derivePromptHandlerWithDescription typeName handlerName [] - -mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkPromptDefWithDescription descriptions con = do - let name = conName con - let sname = snakeName name - let description = descriptionFor descriptions (nameBase name) ("Handle " ++ nameBase name) - args <- case con of - NormalC _ [] -> pure [] - RecC _ fields -> traverse (mkArgDef descriptions) fields - NormalC _ [(_bang, paramType)] -> extractFieldsFromType descriptions paramType - _ -> fail "Unsupported constructor type" - [| PromptDefinition - { promptDefinitionName = $(litE $ stringL sname) - , promptDefinitionDescription = $(litE $ stringL description) - , promptDefinitionArguments = $(return $ ListE args) - , promptDefinitionTitle = Nothing - } |] - --- Extract field definitions from a parameter type recursively -extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp] -extractFieldsFromType descriptions paramType = do - case paramType of - ConT typeName -> do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ [RecC _ fields] _) -> - -- Parameter type is a record with fields - traverse (mkArgDef descriptions) fields - TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> - -- Parameter type has a single parameter - recurse - extractFieldsFromType descriptions innerType - _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" - _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType - -mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp -mkArgDef descriptions (fieldName, _, fieldType) = do - let isOptional = fst (unwrapMaybe fieldType) - let fieldNameStr = nameBase fieldName - let description = descriptionFor descriptions fieldNameStr fieldNameStr - [| ArgumentDefinition - { argumentDefinitionName = $(litE $ stringL fieldNameStr) - , argumentDefinitionDescription = $(litE $ stringL description) - , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) - } |] - -------------------------------------------------------------------------------- --- Dispatch case generation (shared by prompt and tool) -------------------------------------------------------------------------------- - -mkDispatchCase :: Name -> Con -> Q Clause -mkDispatchCase handlerName con = do - let name = conName con - let sname = snakeName name - body <- case con of - NormalC _ [] -> - [| do - content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE name) - pure $ Right content |] - RecC _ fields -> - mkRecordCase name handlerName fields - NormalC _ [(_bang, paramType)] -> - mkSeparateParamsCase name handlerName paramType - _ -> fail "Unsupported constructor type" - clause [litP $ stringL sname] (normalB (return body)) [] - -------------------------------------------------------------------------------- --- Field validation -------------------------------------------------------------------------------- - -mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp -mkSeparateParamsCase outerConName handlerName paramType = do - fields <- extractFieldsFromParamType paramType - let argMapName = mkName "argMap" - let mkBaseExp fieldVars = do - paramConstructorApp <- buildParameterConstructor paramType fieldVars - let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp - [| do - content <- $(varE handlerName) $(varE (mkName "ctx")) $(return outerConstructorApp) - pure $ Right content |] - inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0 - [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - -mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp -mkRecordCase recConName handlerName fields = do - case fields of - [] -> [| do - content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE recConName) - pure $ Right content |] - _ -> do - let argMapName = mkName "argMap" - let mkBaseExp fieldVars = do - let constructorApp = foldl AppE (ConE recConName) (map VarE fieldVars) - [| do - content <- $(varE handlerName) $(varE (mkName "ctx")) $(return constructorApp) - pure $ Right content |] - inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0 - [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - --- Build nested case expressions for field validation, supporting any number of fields. --- The mkBaseExp callback receives field variable names and builds the final expression. -buildFieldValidation :: Name -> Name -> ([Name] -> Q Exp) -> [(Name, Bang, Type)] -> Int -> Q Exp -buildFieldValidation _argMap _handlerName mkBaseExp [] depth = do - let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]] - mkBaseExp fieldVars - -buildFieldValidation argMap handlerName mkBaseExp ((fieldName, _, fieldType):remainingFields) depth = do - let fieldStr = nameBase fieldName - let (isOptional, innerType) = unwrapMaybe fieldType - let fieldVar = mkName ("field" ++ show depth) - - continuation <- buildFieldValidation argMap handlerName mkBaseExp remainingFields (depth + 1) - - let parseFunc = mkParseFunc innerType - - let fieldPrefix = litE $ stringL $ "field '" <> fieldStr <> "': " - - if isOptional - then do - [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of - Nothing -> do - let $(varP fieldVar) = Nothing - $(return continuation) - Just raw -> case $(parseFunc) raw of - Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err) - Right parsed -> do - let $(varP fieldVar) = Just parsed - $(return continuation) |] - else do - [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of - Just raw -> case $(parseFunc) raw of - Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err) - Right $(varP fieldVar) -> $(return continuation) - Nothing -> pure $ Left $ MissingRequiredParams $(litE $ stringL $ "field '" <> fieldStr <> "' is missing") |] - --- Extract field information from parameter type -extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] -extractFieldsFromParamType paramType = do - case paramType of - ConT typeName -> do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ [RecC _ fields] _) -> - return fields - TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> - extractFieldsFromParamType innerType - _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" - _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType - --- Build the parameter constructor application recursively -buildParameterConstructor :: Type -> [Name] -> Q Exp -buildParameterConstructor paramType fieldVars = do - case paramType of - ConT typeName -> do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ [RecC cn _] _) -> - -- Record constructor - apply all field variables - return $ foldl AppE (ConE cn) (map VarE fieldVars) - TyConI (DataD _ _ _ _ [NormalC cn [(_bang, innerType)]] _) -> do - -- Single parameter constructor - recurse and wrap - innerConstructor <- buildParameterConstructor innerType fieldVars - return $ AppE (ConE cn) innerConstructor - _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" - _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType - --- Select the appropriate parse helper for a given type -mkParseFunc :: Type -> Q Exp -mkParseFunc innerType = case innerType of - ConT n | nameBase n == "Int" -> [| parseInt |] - ConT n | nameBase n == "Integer" -> [| parseInteger |] - ConT n | nameBase n == "Double" -> [| parseDouble |] - ConT n | nameBase n == "Float" -> [| parseFloat |] - ConT n | nameBase n == "Bool" -> [| parseBool |] - _ -> [| parseText |] - -------------------------------------------------------------------------------- --- Resource derivation -------------------------------------------------------------------------------- - --- | Derive resource handlers from a data type with custom descriptions. --- Usage: --- --- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) -deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -deriveResourceHandlerWithDescription typeName handlerName descriptions = do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ constructors _) -> do - -- Generate resource definitions - resourceDefs <- traverse (mkResourceDefWithDescription descriptions) constructors - listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |] - - -- Generate read handler with cases - cases <- traverse (mkResourceCase handlerName) constructors - defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |] - let defaultMatch = Match (VarP (mkName "unknown")) (NormalB defaultCase) [] - - let readHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "uri")] $ - CaseE (AppE (VarE 'show) (VarE (mkName "uri"))) - (map clauseToMatch cases ++ [defaultMatch]) - - return $ TupE [Just listHandlerExp, Just readHandlerExp] - _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" - --- | Derive resource handlers from a data type. --- Usage: --- --- > $(deriveResourceHandler ''MyResource 'handleResource) -deriveResourceHandler :: Name -> Name -> Q Exp -deriveResourceHandler typeName handlerName = - deriveResourceHandlerWithDescription typeName handlerName [] - -mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkResourceDefWithDescription descriptions (NormalC name []) = do - let resourceName = T.pack . snakeName $ name - let resourceURI = "resource://" <> T.unpack resourceName - let constructorName = nameBase name - let description = case lookup constructorName descriptions of - Just desc -> Just desc - Nothing -> Just constructorName - [| ResourceDefinition - { resourceDefinitionURI = $(litE $ stringL resourceURI) - , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName) - , resourceDefinitionDescription = $(case description of - Just desc -> [| Just $(litE $ stringL desc) |] - Nothing -> [| Nothing |]) - , resourceDefinitionMimeType = Just "text/plain" - , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] -mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" - - -mkResourceCase :: Name -> Con -> Q Clause -mkResourceCase handlerName (NormalC name []) = do - let resourceName = T.pack . snakeName $ name - let resourceURI = "resource://" <> T.unpack resourceName - clause [litP $ stringL resourceURI] - (normalB [| Right <$> $(varE handlerName) $(varE (mkName "ctx")) $(varE (mkName "uri")) $(conE name) |]) - [] -mkResourceCase _ _ = fail "Unsupported constructor type for resources" - -------------------------------------------------------------------------------- --- Tool derivation -------------------------------------------------------------------------------- - --- | Derive tool handlers from a data type with custom descriptions. --- Usage: --- --- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) -deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -deriveToolHandlerWithDescription typeName handlerName descriptions = do - info <- reify typeName - case info of - TyConI (DataD _ _ _ _ constructors _) -> do - -- Generate tool definitions - toolDefs <- traverse (mkToolDefWithDescription descriptions) constructors - - listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |] - - -- Generate call handler with cases - cases <- traverse (mkDispatchCase handlerName) constructors - defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |] - let defaultMatch = Match WildP (NormalB defaultCase) [] - let callHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $ - CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) - (map clauseToMatch cases ++ [defaultMatch]) - - return $ TupE [Just listHandlerExp, Just callHandlerExp] - _ -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" - --- | Derive tool handlers from a data type. --- Usage: --- --- > $(deriveToolHandler ''MyTool 'handleTool) -deriveToolHandler :: Name -> Name -> Q Exp -deriveToolHandler typeName handlerName = - deriveToolHandlerWithDescription typeName handlerName [] - -mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkToolDefWithDescription descriptions con = do - let name = conName con - let sname = snakeName name - let description = descriptionFor descriptions (nameBase name) (nameBase name) - fields <- getConFields con - props <- traverse (mkProperty descriptions) fields - let required = requiredFieldNames fields - [| ToolDefinition - { toolDefinitionName = $(litE $ stringL sname) - , toolDefinitionDescription = $(litE $ stringL description) - , toolDefinitionInputSchema = InputSchemaDefinitionObject - { properties = $(return $ ListE props) - , required = $(return $ ListE $ map (LitE . StringL) required) - } - , toolDefinitionTitle = Nothing - } |] - -mkProperty :: [(String, String)] -> (Name, Bang, Type) -> Q Exp -mkProperty descriptions (fieldName, _, fieldType) = do - let fieldStr = nameBase fieldName - let description = descriptionFor descriptions fieldStr fieldStr - let (_, innerType) = unwrapMaybe fieldType - let jsonType = jsonTypeFor innerType - [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty - { propertyType = $(litE $ stringL jsonType) - , propertyDescription = $(litE $ stringL description) - }) |] +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Template Haskell utilities for deriving MCP handlers from data types. +-- +-- Tool arguments are decoded from full JSON values: records may contain +-- primitive fields ('Data.Text.Text', 'Int', 'Integer', 'Double', 'Float', +-- t'Bool'), optional fields ('Maybe'), lists, enumerations (data types whose +-- constructors are all nullary), and nested records — the generated +-- @inputSchema@ mirrors the same structure. Prompt arguments are +-- string-valued per the MCP specification, so prompt records are limited to +-- primitive and enumeration fields. +-- +-- Handlers may return 'IO' or 'MCP.Server.Ask.Ask' (see t'HandlerMonad'): +-- an t'MCP.Server.Ask.Ask' handler can ask the user questions part-way +-- through, with forms derived by 'deriveForm'. +module MCP.Server.Derive + ( -- * Template Haskell Derivation + derivePromptHandler + , derivePromptHandlerWithDescription + , derivePromptHandlerWithOptions + , deriveResourceHandler + , deriveResourceHandlerWithDescription + , deriveResourceHandlerWithOptions + , deriveResourceTemplates + , deriveResourceTemplatesWithDescription + , deriveResourceTemplatesWithOptions + , deriveToolHandler + , deriveToolHandlerWithDescription + , deriveToolHandlerWithOptions + , deriveToolHandlerWithOutput + , deriveToolHandlerWithOutputDescription + , deriveToolHandlerWithOutputOptions + + -- * Forms for elicitation + , deriveForm + , deriveFormWithDescription + , deriveFormWithOptions + , FormFieldOptions(..) + , defaultFormFieldOptions + , Value(..) + + -- * Per-constructor customization + , DefinitionOptions(..) + , defaultDefinitionOptions + ) where + +import Control.Monad (zipWithM) +-- Names used inside quotes must be imported here, or the generated code +-- looks them up in the user's module instead. +import Data.Aeson (Value (..), encode, object, toJSON, (.=)) +import qualified Data.ByteString.Lazy as BSL +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift, lift) +import qualified Data.Char as Char + +import MCP.Server.Ask (Form (..), HandlerMonad (..)) +import MCP.Server.Derive.Internal +import MCP.Server.Types + +-- | Per-constructor customization for the @WithOptions@ derivations: a +-- single mechanism for everything a definition can carry beyond its shape. +-- Entries are looked up by constructor name; for output-typed tool +-- derivations, an entry keyed by the /output type's/ name supplies its +-- field descriptions. +data DefinitionOptions = DefinitionOptions + { optDescription :: Maybe Text + -- ^ The definition's description (falls back to the constructor name) + , optTitle :: Maybe Text + , optIcons :: [Icon] + , optToolAnnotations :: Maybe ToolAnnotations + -- ^ Behavioral hints; meaningful for tools, ignored elsewhere + , optFieldDescriptions :: [(Text, Text)] + -- ^ Field\/argument descriptions, scoped to this constructor — two + -- constructors may describe a same-named field differently + } deriving (Show, Eq, Lift) + +-- | Nothing customized; record-update what you need. +defaultDefinitionOptions :: DefinitionOptions +defaultDefinitionOptions = DefinitionOptions + { optDescription = Nothing + , optTitle = Nothing + , optIcons = [] + , optToolAnnotations = Nothing + , optFieldDescriptions = [] + } + +-- | Look up a constructor's options. +optionsFor :: [(String, DefinitionOptions)] -> String -> DefinitionOptions +optionsFor opts name = fromMaybe defaultDefinitionOptions (lookup name opts) + +-- | Adapt the legacy flat description list to per-constructor options: +-- constructor entries become 'optDescription'; the whole list also serves +-- as the (unscoped) field-description namespace, preserving the old +-- behavior exactly. +optionsFromDescriptions :: [(String, String)] -> String -> DefinitionOptions +optionsFromDescriptions descriptions name = defaultDefinitionOptions + { optDescription = T.pack <$> lookup name descriptions + } + +-- The merged field-description namespace for one constructor: its scoped +-- entries shadow the legacy global list. +fieldDescsFor :: DefinitionOptions -> [(String, String)] -> [(String, String)] +fieldDescsFor opts globalDescs = + [(T.unpack k, T.unpack v) | (k, v) <- optFieldDescriptions opts] ++ globalDescs + +------------------------------------------------------------------------------- +-- Small helpers +------------------------------------------------------------------------------- + +-- Helper function to convert PascalCase/camelCase to snake_case +-- +-- >>> toSnakeCase "GetValue" +-- "get_value" +toSnakeCase :: String -> String +toSnakeCase [] = [] +toSnakeCase (x:xs) = Char.toLower x : go xs + where + go [] = [] + go (c:cs) + | Char.isUpper c = '_' : Char.toLower c : go cs + | otherwise = c : go cs + +-- Snake-cased name from a TH Name +snakeName :: Name -> String +snakeName = toSnakeCase . nameBase + +-- Check if a type is Maybe, and unwrap it +unwrapMaybe :: Type -> (Bool, Type) +unwrapMaybe (AppT (ConT n) inner) | nameBase n == "Maybe" = (True, inner) +unwrapMaybe other = (False, other) + +-- Look up description with a default +descriptionFor :: [(String, String)] -> String -> String -> String +descriptionFor descriptions key fallback = + fromMaybe fallback (lookup key descriptions) + +-- Helper function to convert Clause to Match +clauseToMatch :: Clause -> Match +clauseToMatch (Clause ps b ds) = Match (case ps of [p] -> p; _ -> TupP ps) b ds + +-- The constructors of a named data (or newtype) declaration, if it is one +reifyCons :: Name -> Q (Maybe [Con]) +reifyCons n = do + info <- reify n + pure $ case info of + TyConI (DataD _ _ _ _ cs _) -> Just cs + TyConI (NewtypeD _ _ _ _ c _) -> Just [c] + _ -> Nothing + +isNullary :: Con -> Bool +isNullary (NormalC _ []) = True +isNullary _ = False + +-- Get fields from a constructor: [] for nullary, record fields for RecC, +-- extracted fields for single-param NormalC +getConFields :: Con -> Q [(Name, Bang, Type)] +getConFields (NormalC _ []) = pure [] +getConFields (RecC _ fields) = pure fields +getConFields (NormalC _ [(_bang, paramType)]) = extractFieldsFromParamType paramType +getConFields _ = fail "Unsupported constructor type" + +-- Get the constructor name from a Con +conName :: Con -> Name +conName (NormalC n _) = n +conName (RecC n _) = n +conName (InfixC _ n _) = n +conName (ForallC _ _ c) = conName c +conName (GadtC (n:_) _ _) = n +conName (RecGadtC (n:_) _ _) = n +conName _ = error "conName: empty GADT constructor list" + +-- Compute required field names (non-Maybe fields) +requiredFieldNames :: [(Name, Bang, Type)] -> [String] +requiredFieldNames fields = + [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ] + +-- Extract field information from a (possibly wrapped) parameter record type +extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] +extractFieldsFromParamType paramType = do + case paramType of + ConT typeName -> do + cons <- reifyCons typeName + case cons of + Just [RecC _ fields] -> return fields + Just [NormalC _ [(_bang, innerType)]] -> extractFieldsFromParamType innerType + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType + +-- Names used to communicate between the generated lambda and its cases +ctxName, argNameN, argsName, uriName :: Name +ctxName = mkName "ctx" +argNameN = mkName "name" +argsName = mkName "args" +uriName = mkName "uri" + +------------------------------------------------------------------------------- +-- Value parsers (tool arguments) +------------------------------------------------------------------------------- + +-- Build a parser expression of type @Value -> Either Text a@ for a field type +mkValueParser :: Type -> Q Exp +mkValueParser ty = case ty of + ConT n | nameBase n == "Int" -> [| valueInt |] + | nameBase n == "Integer" -> [| valueInteger |] + | nameBase n == "Double" -> [| valueDouble |] + | nameBase n == "Float" -> [| valueFloat |] + | nameBase n == "Bool" -> [| valueBool |] + | nameBase n == "Text" -> [| valueText |] + AppT ListT inner -> [| valueArray $(mkValueParser inner) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> mkEnumValueParser n cs + Just [RecC icn ifields] -> mkObjectParser n icn ifields + Just [NormalC icn [(_bang, inner)]] -> [| fmap $(conE icn) . $(mkValueParser inner) |] + _ -> fail $ "Unsupported tool argument type: " ++ show n + _ -> fail $ "Unsupported tool argument type: " ++ show ty + +-- Parser for an enumeration: a JSON string matching a snake_cased constructor +mkEnumValueParser :: Name -> [Con] -> Q Exp +mkEnumValueParser tyName cons = do + textParser <- mkEnumTextParser tyName cons + [| \v -> case v of + String s -> $(return textParser) s + _ -> Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) <> " from: " <> renderValue v) |] + +-- Parser of type @Text -> Either Text a@ for an enumeration +mkEnumTextParser :: Name -> [Con] -> Q Exp +mkEnumTextParser tyName cons = do + let expected = intercalate ", " [snakeName (conName c) | c <- cons] + sVar <- newName "s" + matches <- mapM (enumMatch . conName) cons + fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) + <> " from: " <> $(varE sVar) + <> " (expected one of: " <> $(litE $ stringL expected) <> ")") |] + let defaultMatch = Match WildP (NormalB fallback) [] + return $ LamE [VarP sVar] $ + CaseE (AppE (VarE 'T.unpack) (VarE sVar)) (matches ++ [defaultMatch]) + where + enumMatch cn = do + body <- [| Right $(conE cn) |] + return $ Match (LitP $ StringL $ snakeName cn) (NormalB body) [] + +-- Parser for a nested record: a JSON object decoded field by field +mkObjectParser :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp +mkObjectParser tyName icn ifields = do + vVar <- newName "v" + oVar <- newName "o" + chain <- foldl (\acc f -> [| $acc <*> $(fieldExtractor oVar f) |]) + [| pure $(conE icn) |] + ifields + fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) + <> " object from: " <> renderValue $(varE vVar)) |] + objP <- conP 'Object [varP oVar] + return $ LamE [VarP vVar] $ + CaseE (VarE vVar) + [ Match objP (NormalB chain) [] + , Match WildP (NormalB fallback) [] + ] + where + fieldExtractor oVar (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + if isOptional + then [| optionalField $fname $(mkValueParser innerType) $(varE oVar) |] + else [| requiredField $fname $(mkValueParser innerType) $(varE oVar) |] + +------------------------------------------------------------------------------- +-- Text parsers (prompt arguments) +------------------------------------------------------------------------------- + +-- Build a parser expression of type @Text -> Either Text a@ for a prompt field +mkTextParser :: Type -> Q Exp +mkTextParser ty = case ty of + ConT n | nameBase n == "Int" -> [| parseInt |] + | nameBase n == "Integer" -> [| parseInteger |] + | nameBase n == "Double" -> [| parseDouble |] + | nameBase n == "Float" -> [| parseFloat |] + | nameBase n == "Bool" -> [| parseBool |] + | nameBase n == "Text" -> [| parseText |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> mkEnumTextParser n cs + _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show n + _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show ty + +------------------------------------------------------------------------------- +-- Value serializers (structured output) +------------------------------------------------------------------------------- + +-- Build a serializer expression of type @a -> Value@ that mirrors +-- 'mkSchemaShape' exactly: what the schema promises is what the value +-- contains (snake_cased enums, 'Maybe' fields omitted when 'Nothing'). +mkValueBuilder :: Type -> Q Exp +mkValueBuilder ty = case ty of + ConT n | nameBase n `elem` ["Int", "Integer", "Double", "Float", "Bool", "Text"] -> + [| toJSON |] + AppT ListT inner -> + [| \xs -> toJSON (map $(mkValueBuilder inner) xs) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> do + vVar <- newName "v" + matches <- mapM enumMatch cs + return $ LamE [VarP vVar] $ CaseE (VarE vVar) matches + Just [RecC icn ifields] -> mkRecordBuilder icn ifields + Just [NormalC icn [(_bang, inner)]] -> do + xVar <- newName "x" + wrapped <- conP icn [varP xVar] + body <- [| $(mkValueBuilder inner) $(varE xVar) |] + return $ LamE [wrapped] body + _ -> fail $ "Unsupported output field type: " ++ show n + _ -> fail $ "Unsupported output field type: " ++ show ty + where + enumMatch c = do + let cn = conName c + body <- [| String $(litE $ stringL $ snakeName cn) |] + pat <- conP cn [] + return $ Match pat (NormalB body) [] + +-- Serializer for a record: an object with one entry per field, omitting +-- 'Maybe' fields that are 'Nothing'. Fields are bound by pattern-matching +-- the constructor — never by accessor application, which would be ambiguous +-- for users with DuplicateRecordFields enabled. +mkRecordBuilder :: Name -> [(Name, Bang, Type)] -> Q Exp +mkRecordBuilder con fields = do + vars <- mapM (const $ newName "f") fields + pat <- conP con (map varP vars) + fieldExps <- zipWithM fieldPairs vars fields + body <- [| object (concat $(return $ ListE fieldExps)) |] + return $ LamE [pat] body + where + fieldPairs var (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + if isOptional + then [| omitNothing $fname $(mkValueBuilder innerType) $(varE var) |] + else [| [ $fname .= $(mkValueBuilder innerType) $(varE var) ] |] + +-- The output type must (possibly through single-constructor wrappers) +-- resolve to a record: outputSchema is an object schema per the spec. +requireOutputRecord :: Name -> Q () +requireOutputRecord n = do + cons <- reifyCons n + case cons of + Just [RecC _ (_:_)] -> pure () + Just [NormalC _ [(_bang, ConT inner)]] -> requireOutputRecord inner + _ -> fail $ "Output type " ++ show n + ++ " must be a record (outputSchema is an object schema)" + +------------------------------------------------------------------------------- +-- Argument decoding for a constructor +------------------------------------------------------------------------------- + +data ArgStyle = ToolArgs | ToolArgsOutput Exp | PromptArgs + +-- Build a decoder expression of type @Either Error @ reading from +-- the in-scope arguments map bound to 'argsName'. +mkConDecoder :: ArgStyle -> Con -> Q Exp +mkConDecoder _ (NormalC cn []) = [| Right $(conE cn) |] +mkConDecoder style (RecC cn fields) = mkFieldsDecoder style (conE cn) fields +mkConDecoder style (NormalC cn [(_bang, paramType)]) = + wrapParam paramType + where + wrapParam ty = case ty of + ConT typeName -> do + cons <- reifyCons typeName + case cons of + Just [RecC icn ifields] -> do + inner <- mkFieldsDecoder style (conE icn) ifields + [| $(conE cn) <$> $(return inner) |] + Just [NormalC icn [(_b, innerTy)]] -> do + innerCon <- mkConDecoder style (NormalC icn [(_b, innerTy)]) + [| $(conE cn) <$> $(return innerCon) |] + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show ty +mkConDecoder _ con = fail $ "Unsupported constructor type: " ++ show (conName con) + +-- Applicative chain over the constructor's fields, reading from 'argsName' +mkFieldsDecoder :: ArgStyle -> Q Exp -> [(Name, Bang, Type)] -> Q Exp +mkFieldsDecoder style con fields = + foldl (\acc f -> [| $acc <*> $(argExtractor f) |]) [| pure $con |] fields + where + argExtractor (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + case style of + PromptArgs + | isOptional -> [| optionalTextArg $fname $(mkTextParser innerType) $(varE argsName) |] + | otherwise -> [| requiredTextArg $fname $(mkTextParser innerType) $(varE argsName) |] + _ -- tool styles share the Value-based argument decoding + | isOptional -> [| optionalArg $fname $(mkValueParser innerType) $(varE argsName) |] + | otherwise -> [| requiredArg $fname $(mkValueParser innerType) $(varE argsName) |] + +------------------------------------------------------------------------------- +-- Schema generation +------------------------------------------------------------------------------- + +-- Build a 'SchemaType' expression for a field type +mkSchemaShape :: [(String, String)] -> Type -> Q Exp +mkSchemaShape descriptions ty = case ty of + ConT n | nameBase n == "Int" -> [| SchemaInteger |] + | nameBase n == "Integer" -> [| SchemaInteger |] + | nameBase n == "Double" -> [| SchemaNumber |] + | nameBase n == "Float" -> [| SchemaNumber |] + | nameBase n == "Bool" -> [| SchemaBoolean |] + | nameBase n == "Text" -> [| SchemaString Nothing |] + AppT ListT inner -> + [| SchemaArray (Schema Nothing $(mkSchemaShape descriptions inner)) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> do + let vals = listE [litE $ stringL $ snakeName (conName c) | c <- cs] + [| SchemaString (Just $vals) |] + Just [RecC _ ifields] -> mkObjectShape descriptions ifields + Just [NormalC _ [(_bang, inner)]] -> mkSchemaShape descriptions inner + _ -> fail $ "Unsupported tool argument type: " ++ show n + _ -> fail $ "Unsupported tool argument type: " ++ show ty + +-- Build a 'SchemaType' object expression from record fields +mkObjectShape :: [(String, String)] -> [(Name, Bang, Type)] -> Q Exp +mkObjectShape descriptions fields = do + props <- mapM prop fields + let reqd = listE [litE $ stringL fn | fn <- requiredFieldNames fields] + [| SchemaObject $(return $ ListE props) $reqd |] + where + prop (fieldName, _, fieldType) = do + let fieldStr = nameBase fieldName + let description = descriptionFor descriptions fieldStr fieldStr + let (_, innerType) = unwrapMaybe fieldType + [| ( $(litE $ stringL fieldStr) + , Schema (Just $(litE $ stringL description)) $(mkSchemaShape descriptions innerType) + ) |] + +------------------------------------------------------------------------------- +-- Prompt derivation +------------------------------------------------------------------------------- + +-- | Derive prompt handlers from a data type with custom descriptions. +-- Usage: +-- +-- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) +derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp +derivePromptHandlerWithDescription typeName handlerName descriptions = + derivePromptHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions + +-- | Derive prompt handlers with per-constructor t'DefinitionOptions' +-- (title, icons, scoped argument descriptions). Usage: +-- +-- > $(derivePromptHandlerWithOptions ''MyPrompt 'handlePrompt +-- > [("Recipe", defaultDefinitionOptions { optDescription = Just "…" })]) +derivePromptHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +derivePromptHandlerWithOptions typeName handlerName opts = + derivePromptHandlerGeneric typeName handlerName (optionsFor opts) [] + +derivePromptHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> [(String, String)] -> Q Exp +derivePromptHandlerGeneric typeName handlerName conOpts globalDescs = do + cons <- reifyCons typeName + case cons of + Just constructors -> do + -- Generate prompt definitions + promptDefs <- traverse (mkPromptDef conOpts globalDescs) constructors + + -- Generate list handler + listHandlerExp <- [| \_ctx -> pure $(return $ ListE promptDefs) |] + + -- Generate get handler with cases + cases <- traverse (mkDispatchCase PromptArgs handlerName) constructors + defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> $(varE argNameN) |] + let defaultMatch = Match WildP (NormalB defaultCase) [] + let getHandlerExp = LamE [VarP ctxName, VarP argNameN, VarP argsName] $ + CaseE (AppE (VarE 'T.unpack) (VarE argNameN)) + (map clauseToMatch cases ++ [defaultMatch]) + + return $ TupE [Just listHandlerExp, Just getHandlerExp] + Nothing -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" + +-- | Derive prompt handlers from a data type. +-- Usage: +-- +-- > $(derivePromptHandler ''MyPrompt 'handlePrompt) +derivePromptHandler :: Name -> Name -> Q Exp +derivePromptHandler typeName handlerName = + derivePromptHandlerWithDescription typeName handlerName [] + +mkPromptDef :: (String -> DefinitionOptions) -> [(String, String)] -> Con -> Q Exp +mkPromptDef conOpts globalDescs con = do + let name = conName con + let sname = snakeName name + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack ("Handle " ++ nameBase name)) (optDescription opts) + fields <- getConFields con + args <- traverse (mkArgDef (fieldDescsFor opts globalDescs)) fields + [| PromptDefinition + { promptDefinitionName = $(litE $ stringL sname) + , promptDefinitionDescription = $(lift description) + , promptDefinitionArguments = $(return $ ListE args) + , promptDefinitionTitle = $(lift (optTitle opts)) + , promptDefinitionIcons = $(lift (optIcons opts)) + } |] + +mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp +mkArgDef descriptions (fieldName, _, fieldType) = do + let isOptional = fst (unwrapMaybe fieldType) + let fieldNameStr = nameBase fieldName + let description = descriptionFor descriptions fieldNameStr fieldNameStr + [| ArgumentDefinition + { argumentDefinitionName = $(litE $ stringL fieldNameStr) + , argumentDefinitionDescription = $(litE $ stringL description) + , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) + } |] + +------------------------------------------------------------------------------- +-- Dispatch case generation (shared by prompt and tool) +------------------------------------------------------------------------------- + +mkDispatchCase :: ArgStyle -> Name -> Con -> Q Clause +mkDispatchCase style handlerName con = do + let sname = snakeName (conName con) + decoder <- mkConDecoder style con + body <- case style of + ToolArgs -> + [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> fmap (fmap toToolResult) <$> + runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |] + ToolArgsOutput builder -> + [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> fmap (fmap (resolveToolOutput $(return builder))) <$> + runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |] + PromptArgs -> + [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> fmap (fmap toPromptResult) <$> + runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |] + clause [litP $ stringL sname] (normalB (return body)) [] + +------------------------------------------------------------------------------- +-- Resource derivation +------------------------------------------------------------------------------- + +-- | Derive resource handlers from a data type with custom descriptions. +-- +-- Nullary constructors become static resources +-- (@Menu -> resource:\/\/menu@). Record constructors become resource +-- /templates/ (@UserProfile { userId :: Text } -> +-- resource:\/\/user_profile\/{userId}@): they are excluded from +-- @resources\/list@ (advertise them with 'deriveResourceTemplates'), and the +-- read handler matches their URIs by splitting the path into percent-decoded +-- segments, one per field, in declaration order. +-- +-- Usage: +-- +-- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) +deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp +deriveResourceHandlerWithDescription typeName handlerName descriptions = + deriveResourceHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) + +-- | Derive resource handlers with per-constructor t'DefinitionOptions' +-- (description, title, icons). +deriveResourceHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveResourceHandlerWithOptions typeName handlerName opts = + deriveResourceHandlerGeneric typeName handlerName (optionsFor opts) + +deriveResourceHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> Q Exp +deriveResourceHandlerGeneric typeName handlerName conOpts = do + cons <- reifyCons typeName + case cons of + Just constructors -> do + -- Static resource definitions: nullary constructors only + resourceDefs <- traverse (mkResourceDef conOpts) + (filter isNullary constructors) + listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |] + + -- Read handler: a chain of alternatives over every constructor, + -- falling through to ResourceNotFound + let fallbackQ = [| pure $ Left $ ResourceNotFound $ + "Resource not found: " <> T.pack (show $(varE uriName)) |] + readBody <- foldr (mkResourceAlt handlerName) fallbackQ constructors + let readHandlerExp = LamE [VarP ctxName, VarP uriName] readBody + + return $ TupE [Just listHandlerExp, Just readHandlerExp] + Nothing -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type" + +-- | Derive resource handlers from a data type. +-- Usage: +-- +-- > $(deriveResourceHandler ''MyResource 'handleResource) +deriveResourceHandler :: Name -> Name -> Q Exp +deriveResourceHandler typeName handlerName = + deriveResourceHandlerWithDescription typeName handlerName [] + +-- | Derive a 'ResourceTemplateListHandler' advertising the record +-- constructors of a resource type as URI templates, with custom +-- descriptions. Usage: +-- +-- > $(deriveResourceTemplatesWithDescription ''MyResource [("Constructor", "Description")]) +deriveResourceTemplatesWithDescription :: Name -> [(String, String)] -> Q Exp +deriveResourceTemplatesWithDescription typeName descriptions = + deriveResourceTemplatesGeneric typeName (optionsFromDescriptions descriptions) + +-- | Derive a 'ResourceTemplateListHandler' with per-constructor +-- t'DefinitionOptions' (description, title, icons). +deriveResourceTemplatesWithOptions :: Name -> [(String, DefinitionOptions)] -> Q Exp +deriveResourceTemplatesWithOptions typeName opts = + deriveResourceTemplatesGeneric typeName (optionsFor opts) + +deriveResourceTemplatesGeneric :: Name -> (String -> DefinitionOptions) -> Q Exp +deriveResourceTemplatesGeneric typeName conOpts = do + cons <- reifyCons typeName + case cons of + Just constructors -> do + templateDefs <- traverse (mkTemplateDef conOpts) + [c | c@(RecC _ _) <- constructors] + [| \_ctx -> pure $(return $ ListE templateDefs) |] + Nothing -> fail $ "deriveResourceTemplates: " ++ show typeName ++ " is not a data type" + +-- | Derive a 'ResourceTemplateListHandler' from a resource type's record +-- constructors. Usage: +-- +-- > $(deriveResourceTemplates ''MyResource) +deriveResourceTemplates :: Name -> Q Exp +deriveResourceTemplates typeName = + deriveResourceTemplatesWithDescription typeName [] + +-- The URI-template string for a record constructor: +-- resource://user_profile/{userId}/{...} +templateURI :: Name -> [(Name, Bang, Type)] -> String +templateURI name fields = + "resource://" <> snakeName name + <> concat ["/{" <> nameBase fn <> "}" | (fn, _, _) <- fields] + +mkTemplateDef :: (String -> DefinitionOptions) -> Con -> Q Exp +mkTemplateDef _ (RecC name []) = + fail $ "Resource template constructors need at least one field: " ++ nameBase name +mkTemplateDef conOpts (RecC name fields) = do + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) + [| ResourceTemplateDefinition + { resourceTemplateURITemplate = $(litE $ stringL $ templateURI name fields) + , resourceTemplateName = $(litE $ stringL $ snakeName name) + , resourceTemplateDescription = Just $(lift description) + , resourceTemplateMimeType = Just "text/plain" + , resourceTemplateTitle = $(lift (optTitle opts)) + , resourceTemplateIcons = $(lift (optIcons opts)) + } |] +mkTemplateDef _ _ = fail "Resource templates require record constructors" + +mkResourceDef :: (String -> DefinitionOptions) -> Con -> Q Exp +mkResourceDef conOpts (NormalC name []) = do + let resourceName = T.pack . snakeName $ name + let resourceURI = "resource://" <> T.unpack resourceName + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) + [| ResourceDefinition + { resourceDefinitionURI = $(litE $ stringL resourceURI) + , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName) + , resourceDefinitionDescription = Just $(lift description) + , resourceDefinitionMimeType = Just "text/plain" + , resourceDefinitionTitle = $(lift (optTitle opts)) + , resourceDefinitionIcons = $(lift (optIcons opts)) + } |] +mkResourceDef _ _ = fail "Unsupported constructor type for resources" + +-- One alternative of the read handler: try this constructor, else fall +-- through to the rest of the chain. +mkResourceAlt :: Name -> Con -> Q Exp -> Q Exp +mkResourceAlt handlerName con restQ = case con of + NormalC name [] -> do + let resourceURI = "resource://" <> snakeName name + [| if show $(varE uriName) == $(litE $ stringL resourceURI) + then runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) $(varE uriName) $(conE name)) + else $restQ |] + RecC name [] -> + fail $ "Resource template constructors need at least one field: " ++ nameBase name + RecC name fields -> do + let prefix = "resource://" <> snakeName name <> "/" + segsName = mkName "segs" + decoder <- mkSegmentsDecoder segsName name fields + handled <- [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) $(varE uriName) v) |] + rest <- restQ + matchExp <- [| matchTemplateSegments $(litE $ stringL prefix) + $(litE $ integerL $ fromIntegral $ length fields) + (show $(varE uriName)) |] + justP <- conP 'Just [varP segsName] + nothingP <- conP 'Nothing [] + return $ CaseE matchExp + [ Match justP (NormalB handled) [] + , Match nothingP (NormalB rest) [] + ] + _ -> fail "Unsupported constructor type for resources" + +-- Applicative decode of the matched template segments into the constructor +mkSegmentsDecoder :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp +mkSegmentsDecoder segsName con fields = + foldl step [| pure $(conE con) |] (zip [0 :: Integer ..] fields) + where + step acc (i, (fieldName, _, fieldType)) = do + let (isOptional, innerType) = unwrapMaybe fieldType + if isOptional + then fail $ "Maybe fields are not supported in resource templates: " ++ nameBase fieldName + else [| $acc <*> templateField $(litE $ stringL $ nameBase fieldName) + $(mkTextParser innerType) + $(varE segsName) + $(litE $ integerL i) |] + +------------------------------------------------------------------------------- +-- Tool derivation +------------------------------------------------------------------------------- + +-- | Derive tool handlers from a data type with custom descriptions. +-- Usage: +-- +-- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) +deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp +deriveToolHandlerWithDescription typeName handlerName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions Nothing + +-- | Derive tool handlers with per-constructor t'DefinitionOptions' +-- (description, title, icons, behavioral annotations, scoped argument +-- descriptions). Usage: +-- +-- > $(deriveToolHandlerWithOptions ''MyTool 'handleTool +-- > [ ("Search", defaultDefinitionOptions +-- > { optDescription = Just "Search the catalog" +-- > , optToolAnnotations = Just defaultToolAnnotations { toolReadOnlyHint = Just True } +-- > }) +-- > ]) +deriveToolHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveToolHandlerWithOptions typeName handlerName opts = + deriveToolHandlerGeneric typeName handlerName (optionsFor opts) [] Nothing + +-- | Derive tool handlers from a data type. +-- Usage: +-- +-- > $(deriveToolHandler ''MyTool 'handleTool) +deriveToolHandler :: Name -> Name -> Q Exp +deriveToolHandler typeName handlerName = + deriveToolHandlerWithDescription typeName handlerName [] + +-- | Derive tool handlers with typed, structured output: the third name is a +-- record type describing the tools' results. Its shape becomes the derived +-- @outputSchema@ (same field rules as input derivation: primitives, +-- 'Maybe', lists, all-nullary enums, nested records), and the handler +-- returns @t'ToolOutput' \@, whose typed values the derivation +-- serializes into @structuredContent@ — guaranteed to match the schema. +-- +-- > handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport) +-- > $(deriveToolHandlerWithOutput ''MyTool 'handleTool ''WeatherReport) +deriveToolHandlerWithOutput :: Name -> Name -> Name -> Q Exp +deriveToolHandlerWithOutput typeName handlerName outputName = + deriveToolHandlerWithOutputDescription typeName handlerName outputName [] + +-- | 'deriveToolHandlerWithOutput' with custom descriptions. The +-- description list is shared with the output type: entries matching output +-- field names describe the @outputSchema@ properties. +deriveToolHandlerWithOutputDescription :: Name -> Name -> Name -> [(String, String)] -> Q Exp +deriveToolHandlerWithOutputDescription typeName handlerName outputName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions (Just outputName) + +-- | 'deriveToolHandlerWithOutput' with per-constructor +-- t'DefinitionOptions'. An entry keyed by the output type's name supplies +-- the @outputSchema@ field descriptions via 'optFieldDescriptions'. +deriveToolHandlerWithOutputOptions :: Name -> Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveToolHandlerWithOutputOptions typeName handlerName outputName opts = + deriveToolHandlerGeneric typeName handlerName (optionsFor opts) [] (Just outputName) + +deriveToolHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> [(String, String)] -> Maybe Name -> Q Exp +deriveToolHandlerGeneric typeName handlerName conOpts globalDescs outputName = do + cons <- reifyCons typeName + case cons of + Just constructors -> do + -- The output type's schema and its matching serializer, when typed + -- output is requested. Its field descriptions come from an options + -- entry keyed by the output type's own name, merged with the legacy + -- global list. + output <- traverse + (\o -> do + requireOutputRecord o + let outDescs = fieldDescsFor (conOpts (nameBase o)) globalDescs + (,) <$> mkSchemaShape outDescs (ConT o) + <*> mkValueBuilder (ConT o)) + outputName + + -- Generate tool definitions + toolDefs <- traverse (mkToolDef conOpts globalDescs (fst <$> output)) constructors + + listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |] + + -- Generate call handler with cases + let style = maybe ToolArgs (ToolArgsOutput . snd) output + cases <- traverse (mkDispatchCase style handlerName) constructors + defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> $(varE argNameN) |] + let defaultMatch = Match WildP (NormalB defaultCase) [] + let callHandlerExp = LamE [VarP ctxName, VarP argNameN, VarP argsName] $ + CaseE (AppE (VarE 'T.unpack) (VarE argNameN)) + (map clauseToMatch cases ++ [defaultMatch]) + + return $ TupE [Just listHandlerExp, Just callHandlerExp] + Nothing -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type" + +mkToolDef :: (String -> DefinitionOptions) -> [(String, String)] -> Maybe Exp -> Con -> Q Exp +mkToolDef conOpts globalDescs outputShape con = do + let name = conName con + let sname = snakeName name + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) + fields <- getConFields con + shapeExp <- mkObjectShape (fieldDescsFor opts globalDescs) fields + [| ToolDefinition + { toolDefinitionName = $(litE $ stringL sname) + , toolDefinitionDescription = $(lift description) + , toolDefinitionInputSchema = Schema Nothing $(return shapeExp) + , toolDefinitionOutputSchema = $(case outputShape of + Just shape -> [| Just (Schema Nothing $(return shape)) |] + Nothing -> [| Nothing |]) + , toolDefinitionTitle = $(lift (optTitle opts)) + , toolDefinitionAnnotations = $(lift (optToolAnnotations opts)) + , toolDefinitionIcons = $(lift (optIcons opts)) + } |] + +------------------------------------------------------------------------------- +-- Form derivation (elicitation) +------------------------------------------------------------------------------- + +-- | How one field of a derived form is presented. +data FormFieldOptions = FormFieldOptions + { formFieldTitle :: Maybe Text + -- ^ The label clients show (falls back to the field name) + , formFieldDescription :: Maybe Text + -- ^ Help text shown with the field + , formFieldDefault :: Maybe Value + -- ^ The value the field starts with; checked against the field's type + -- at compile time + } deriving (Show, Eq) + +-- | Nothing customized; record-update what you need. +defaultFormFieldOptions :: FormFieldOptions +defaultFormFieldOptions = FormFieldOptions + { formFieldTitle = Nothing + , formFieldDescription = Nothing + , formFieldDefault = Nothing + } + +-- | Derive a t'Form' instance from a record, for 'MCP.Server.Ask.elicit': +-- +-- > data Environment = Staging | Production +-- > data DeployTarget = DeployTarget { environment :: Environment, reason :: Text, notify :: Maybe Bool } +-- > $(deriveForm ''DeployTarget) +-- +-- Elicitation forms are flat, so the fields may be 'Text', 'Int', +-- 'Integer', 'Double', 'Float', t'Bool', enumerations (data types whose +-- constructors are all nullary, offered as snake_cased choices), lists of +-- enumerations (several choices), and 'Maybe' of any of these for optional +-- fields. Anything else, such as a nested record, is a compile-time error +-- naming the field. +deriveForm :: Name -> Q [Dec] +deriveForm typeName = deriveFormWithOptions typeName [] + +-- | 'deriveForm' with field descriptions, keyed by field name. +-- +-- > $(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")]) +deriveFormWithDescription :: Name -> [(String, String)] -> Q [Dec] +deriveFormWithDescription typeName descriptions = deriveFormWithOptions typeName + [ (field, defaultFormFieldOptions { formFieldDescription = Just (T.pack d) }) + | (field, d) <- descriptions ] + +-- | 'deriveForm' with per-field t'FormFieldOptions', keyed by field name. +-- +-- > $(deriveFormWithOptions ''DeployTarget +-- > [ ("environment", defaultFormFieldOptions +-- > { formFieldTitle = Just "Environment", formFieldDefault = Just "staging" }) ]) +deriveFormWithOptions :: Name -> [(String, FormFieldOptions)] -> Q [Dec] +deriveFormWithOptions typeName opts = do + cons <- reifyCons typeName + (con, fields) <- case cons of + Just [RecC con fields@(_ : _)] -> pure (con, fields) + _ -> fail $ "deriveForm: " ++ nameBase typeName + ++ " must be a record with a single constructor and at least one field" + let known = [nameBase fn | (fn, _, _) <- fields] + case [field | (field, _) <- opts, field `notElem` known] of + [] -> pure () + unknown -> fail $ "deriveForm: " ++ nameBase typeName + ++ " has no field named " ++ intercalate ", " unknown + props <- traverse (formProperty typeName opts) fields + let reqd = listE [litE $ stringL fn | fn <- requiredFieldNames fields] + parser <- mkObjectParser typeName con fields + [d| instance Form $(conT typeName) where + formSchema _ = Schema Nothing (SchemaObject $(return (ListE props)) $reqd) + formParse content = $(return parser) (toJSON content) |] + +-- One property of a form's schema, after checking the field can be in one. +formProperty :: Name -> [(String, FormFieldOptions)] -> (Name, Bang, Type) -> Q Exp +formProperty typeName opts (fieldName, _, fieldType) = do + let field = nameBase fieldName + (_, innerType) = unwrapMaybe fieldType + fieldOpts = fromMaybe defaultFormFieldOptions (lookup field opts) + unsupported why = fail $ "deriveForm: field '" ++ field ++ "' of " ++ nameBase typeName + ++ " " ++ why ++ "; form fields are Text, numbers, Bool, enumerations," + ++ " lists of enumerations, or Maybe of these" + kind <- formFieldKind innerType >>= either unsupported pure + traverse_ (checkFormDefault typeName field kind) (formFieldDefault fieldOpts) + shape <- mkSchemaShape [] innerType + let defaultJson = jsonText <$> formFieldDefault fieldOpts + [| ( $(litE (stringL field)) + , formFieldSchema $(lift (formFieldTitle fieldOpts)) + $(lift (formFieldDescription fieldOpts)) + $(lift defaultJson) + $(return shape) + ) |] + where + traverse_ f = maybe (pure ()) f + +-- What a form field holds, for checking defaults. +data FormFieldKind + = FormText + | FormNumber (Value -> Either Text ()) -- the field's own parser, discarding the value + | FormBool + | FormChoice [String] + | FormChoices [String] + +-- Classify a field type, or say why a form cannot hold it. +formFieldKind :: Type -> Q (Either String FormFieldKind) +formFieldKind ty = case ty of + ConT n | nameBase n == "Text" -> ok FormText + | nameBase n == "Int" -> number valueInt + | nameBase n == "Integer" -> number valueInteger + | nameBase n == "Double" -> number valueDouble + | nameBase n == "Float" -> number valueFloat + | nameBase n == "Bool" -> ok FormBool + AppT ListT inner -> do + kind <- formFieldKind inner + pure $ case kind of + Right (FormChoice choices) -> Right (FormChoices choices) + _ -> Left "is a list of something other than an enumeration" + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> ok (FormChoice [snakeName (conName c) | c <- cs]) + Just [RecC _ _] -> pure (Left "is a record (forms cannot nest)") + Just [NormalC _ [(_bang, inner)]] -> formFieldKind inner + _ -> pure (Left ("has type " ++ nameBase n)) + AppT (ConT n) _ | nameBase n == "Maybe" -> pure (Left "is a nested Maybe") + _ -> pure (Left ("has type " ++ pprint ty)) + where + ok = pure . Right + number parser = ok (FormNumber (fmap (const ()) . parser)) + +-- A default must be a value the field can hold. +checkFormDefault :: Name -> String -> FormFieldKind -> Value -> Q () +checkFormDefault typeName field kind value + | fits kind value = pure () + | otherwise = fail $ "deriveForm: the default for field '" ++ field ++ "' of " + ++ nameBase typeName ++ " does not fit its type: " ++ T.unpack (jsonText value) + where + fits FormText (String _) = True + -- Numbers go through the field's parser, so an Int default must be a + -- whole number in range, as the parsed answer would have to be. + fits (FormNumber parse) v@(Number _) = either (const False) (const True) (parse v) + fits FormBool (Bool _) = True + fits (FormChoice cs) (String c) = T.unpack c `elem` cs + fits (FormChoices cs) (Array xs) = all (fits (FormChoice cs)) xs + fits _ _ = False + +-- JSON as text, decoded as UTF-8 (the encoding is always valid UTF-8). +jsonText :: Value -> Text +jsonText = TE.decodeUtf8 . BSL.toStrict . encode diff --git a/src/MCP/Server/Derive/Internal.hs b/src/MCP/Server/Derive/Internal.hs --- a/src/MCP/Server/Derive/Internal.hs +++ b/src/MCP/Server/Derive/Internal.hs @@ -1,18 +1,73 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Runtime support for the code generated by "MCP.Server.Derive". +-- +-- Two families of parsers exist because the MCP specification types the two +-- argument channels differently: prompt arguments are always strings, while +-- tool arguments are full JSON values. The Value-based parsers are lenient: +-- they accept the native JSON type and fall back to parsing the string +-- representation, since many clients send numbers and booleans as strings. module MCP.Server.Derive.Internal - ( parseText + ( -- * Text-based parsers (prompt arguments) + parseText , parseInt , parseInteger , parseDouble , parseFloat , parseBool + -- * Value-based parsers (tool arguments) + , valueText + , valueInt + , valueInteger + , valueDouble + , valueFloat + , valueBool + , valueArray + , renderValue + -- * Argument/field extraction + , requiredArg + , optionalArg + , requiredTextArg + , optionalTextArg + , requiredField + , optionalField + -- * Resource template matching + , matchTemplateSegments + , templateField + -- * Structured output + , resolveToolOutput + , omitNothing + , canonicalJsonText + -- * Forms + , formFieldSchema ) where -import Data.Text (Text) -import qualified Data.Text as T -import Text.Read (readMaybe) +import Data.Aeson (Value (..), decodeStrict, encode, toJSON) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (toList) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Scientific (base10Exponent, floatingOrInteger, + toBoundedInteger, toRealFloat) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.URI (unEscapeString) +import Text.Read (readMaybe) +import MCP.Server.Internal.Json (canonicalJsonText) +import MCP.Server.Types (Content (..), Error (..), Schema (..), + SchemaType (..), + ToolOutput (..), ToolResult (..), + toolError, toolResult) + +-- --------------------------------------------------------------------------- +-- Text-based parsers (prompt arguments are strings per the MCP spec) +-- --------------------------------------------------------------------------- + parseText :: Text -> Either Text Text parseText = Right @@ -41,3 +96,173 @@ "true" -> Right True "false" -> Right False _ -> Left $ "Failed to parse Bool from: " <> t + +-- --------------------------------------------------------------------------- +-- Value-based parsers (tool arguments are full JSON values) +-- --------------------------------------------------------------------------- + +-- | A short rendering of a JSON value for error messages. +renderValue :: Value -> Text +renderValue (String t) = t +renderValue v = TE.decodeUtf8 $ BSL.toStrict $ encode v + +valueText :: Value -> Either Text Text +valueText (String t) = Right t +valueText v = Left $ "Failed to parse Text from: " <> renderValue v + +valueInt :: Value -> Either Text Int +valueInt (Number n) = case toBoundedInteger n of + Just i -> Right i + Nothing -> Left $ "Failed to parse Int from: " <> renderValue (Number n) +valueInt (String t) = parseInt t +valueInt v = Left $ "Failed to parse Int from: " <> renderValue v + +valueInteger :: Value -> Either Text Integer +valueInteger (Number n) + -- Bound the exponent before materializing the Integer: aeson keeps huge + -- exponents compact, so a tiny payload like 1e1000000000 would otherwise + -- allocate a billion-digit Integer (same bound aeson itself uses for its + -- FromJSON Integer instance). + | base10Exponent n > 1024 = + Left "Failed to parse Integer: exponent too large" + | otherwise = case floatingOrInteger n :: Either Double Integer of + Right i -> Right i + Left _ -> Left $ "Failed to parse Integer from: " <> renderValue (Number n) +valueInteger (String t) = parseInteger t +valueInteger v = Left $ "Failed to parse Integer from: " <> renderValue v + +valueDouble :: Value -> Either Text Double +valueDouble (Number n) = Right (toRealFloat n) +valueDouble (String t) = parseDouble t +valueDouble v = Left $ "Failed to parse Double from: " <> renderValue v + +valueFloat :: Value -> Either Text Float +valueFloat (Number n) = Right (toRealFloat n) +valueFloat (String t) = parseFloat t +valueFloat v = Left $ "Failed to parse Float from: " <> renderValue v + +valueBool :: Value -> Either Text Bool +valueBool (Bool b) = Right b +valueBool (String t) = parseBool t +valueBool v = Left $ "Failed to parse Bool from: " <> renderValue v + +valueArray :: (Value -> Either Text a) -> Value -> Either Text [a] +valueArray p (Array xs) = traverse p (toList xs) +valueArray _ v = Left $ "Failed to parse array from: " <> renderValue v + +-- --------------------------------------------------------------------------- +-- Argument extraction from the top-level arguments map +-- --------------------------------------------------------------------------- + +prefixed :: Text -> Either Text a -> Either Error a +prefixed name = either (Left . InvalidParams . (("field '" <> name <> "': ") <>)) Right + +-- | A required tool argument: missing yields 'MissingRequiredParams', a parse +-- failure yields 'InvalidParams' with the field name prefixed. +requiredArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error a +requiredArg name p args = case Map.lookup name args of + Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing" + Just v -> prefixed name (p v) + +-- | An optional tool argument: absent (or JSON null) becomes 'Nothing'. +optionalArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error (Maybe a) +optionalArg name p args = case Map.lookup name args of + Nothing -> Right Nothing + Just Null -> Right Nothing + Just v -> Just <$> prefixed name (p v) + +-- | A required prompt argument (string-valued). +requiredTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error a +requiredTextArg name p args = case Map.lookup name args of + Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing" + Just t -> prefixed name (p t) + +-- | An optional prompt argument (string-valued). +optionalTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error (Maybe a) +optionalTextArg name p args = case Map.lookup name args of + Nothing -> Right Nothing + Just t -> Just <$> prefixed name (p t) + +-- --------------------------------------------------------------------------- +-- Field extraction from nested JSON objects +-- --------------------------------------------------------------------------- + +-- | A required field of a nested object argument. +requiredField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text a +requiredField name p o = case KM.lookup (Key.fromText name) o of + Nothing -> Left $ "field '" <> name <> "' is missing" + Just v -> either (Left . (("field '" <> name <> "': ") <>)) Right (p v) + +-- | An optional field of a nested object argument: absent or null is 'Nothing'. +optionalField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text (Maybe a) +optionalField name p o = case KM.lookup (Key.fromText name) o of + Nothing -> Right Nothing + Just Null -> Right Nothing + Just v -> either (Left . (("field '" <> name <> "': ") <>)) (Right . Just) (p v) + +-- --------------------------------------------------------------------------- +-- Resource template matching +-- --------------------------------------------------------------------------- + +-- | Match a URI against a template of the form @\{a}\/{b}\/…@: the +-- rendered URI must start with the prefix and continue with exactly @n@ +-- non-empty, slash-separated segments, which are returned percent-decoded. +-- Any query or fragment on the URI is ignored — templates declare only path +-- variables (a literal @?@ or @#@ inside a segment value arrives +-- percent-encoded and is unaffected). +matchTemplateSegments :: Text -> Int -> String -> Maybe [Text] +matchTemplateSegments prefix n uriStr = do + let base = T.takeWhile (\c -> c /= '?' && c /= '#') (T.pack uriStr) + rest <- T.stripPrefix prefix base + let segs = T.splitOn "/" rest + if length segs == n && all (not . T.null) segs + then Just (map (T.pack . unEscapeString . T.unpack) segs) + else Nothing + +-- | Decode one matched template segment into a field value. +templateField :: Text -> (Text -> Either Text a) -> [Text] -> Int -> Either Error a +templateField name p segs i = case drop i segs of + (s:_) -> either (Left . InvalidParams . (("template field '" <> name <> "': ") <>)) Right (p s) + [] -> Left $ InvalidParams $ "missing segment for template field '" <> name <> "'" + +-- --------------------------------------------------------------------------- +-- Structured output +-- --------------------------------------------------------------------------- + +-- | Turn a t'ToolOutput' into the t'ToolResult' that goes on the wire, given +-- the generated serializer for the output type. A plain v'ToolOutput' also +-- carries the serialized JSON as a text content block, per the spec's +-- recommendation for clients that predate structured output. +resolveToolOutput :: (o -> Value) -> ToolOutput o -> ToolResult +resolveToolOutput serialize out = case out of + ToolOutput o -> + let v = serialize o + in (toolResult [ContentText (canonicalJsonText v)]) { toolResultStructured = Just v } + ToolOutputWith content o -> + (toolResult content) { toolResultStructured = Just (serialize o) } + ToolOutputError msg -> toolError msg + ToolOutputRaw result -> result + +-- | A record field for the generated serializers: absent when 'Nothing', +-- mirroring how the generated schema marks 'Maybe' fields optional. +omitNothing :: Text -> (a -> Value) -> Maybe a -> [Pair] +omitNothing _ _ Nothing = [] +omitNothing name f (Just x) = [(Key.fromText name, f x)] + +-- --------------------------------------------------------------------------- +-- Forms +-- --------------------------------------------------------------------------- + +-- | One property of a derived form: its shape, with a title and a default +-- (JSON, checked when the form was derived) added as raw keywords, since +-- t'Schema' has no place for them. +formFieldSchema :: Maybe Text -> Maybe Text -> Maybe Text -> SchemaType -> Schema +formFieldSchema title description defaultJson shape + | null extras = Schema description shape + | otherwise = Schema description (SchemaRaw (KM.union (KM.fromList extras) base)) + where + base = case toJSON (Schema Nothing shape) of + Object o -> o + _ -> KM.empty + extras = [("title", String t) | Just t <- [title]] + ++ [("default", v) | Just j <- [defaultJson], Just v <- [decodeStrict (TE.encodeUtf8 j)]] 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 @@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Protocol dispatch: routes each JSON-RPC message to the matching +-- user handler and builds the response for the request's protocol era. +-- The transports call 'handleMcpMessage'; the per-method handlers are +-- exported for testing and custom transports. module MCP.Server.Handlers ( -- * Core Message Handling handleMcpMessage @@ -9,31 +13,45 @@ -- * Individual Request Handlers , handleInitialize , handlePing + , handleServerDiscover , handlePromptsList , handlePromptsGet , handleResourcesList , handleResourcesRead + , handleResourcesTemplatesList , handleToolsList , handleToolsCall + , handleCompletionComplete -- * Protocol Support , validateProtocolVersion , getMessageSummary + , metaProtocolVersion + , unsupportedVersionError -- * Error Conversion , errorCodeFromMcpError , errorMessageFromMcpError ) where -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (SomeAsyncException, SomeException, + displayException, fromException, + throwIO, try) +import Control.Monad (when) import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T import System.IO (hPutStrLn, stderr) +import MCP.Server.Internal.InputRound (beginRound, + inputRequiredResult) import MCP.Server.JsonRpc import MCP.Server.Protocol +import MCP.Server.RequestState (StateCodec) import MCP.Server.Types -- | Convert JSON Value to Text representation suitable for handlers @@ -62,51 +80,236 @@ -- Per MCP spec: "If the server supports the requested protocol version, -- it MUST respond with the same version. Otherwise, the server MUST respond -- with another protocol version it supports." +-- +-- Only /legacy/ revisions are eligible here: a client that negotiates via +-- @initialize@ is legacy by definition, so proposing @2026-07-28@ (or +-- anything unknown) negotiates down to the newest legacy revision rather +-- than promising stateless semantics inside a handshake. validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion | clientVersion `elem` supportedVersions = Right clientVersion -- Supported: echo the client's own version | otherwise = Right protocolVersion -- Unknown: negotiate down to the server's default version --- | Handle an MCP message and return a response if needed -handleMcpMessage :: (MonadIO m) - => McpServerInfo - -> McpServerHandlers m +-- | Look up an @io.modelcontextprotocol/\@ entry in a request's +-- params @_meta@ object. +metaLookup :: Text -> Maybe Value -> Maybe Value +metaLookup key params = plainMetaLookup ("io.modelcontextprotocol/" <> key) params + +-- | Look up an unprefixed key in a request's params @_meta@ object +-- (e.g. @progressToken@, which the spec defines without a prefix). +plainMetaLookup :: Text -> Maybe Value -> Maybe Value +plainMetaLookup key params = do + Object o <- params + Object m <- KM.lookup "_meta" o + KM.lookup (Key.fromText key) m + +-- | The protocol revision a request declares in its params @_meta@ +-- (modern, 2026-07-28+ clients). 'Nothing' for legacy requests. +metaProtocolVersion :: Maybe Value -> Maybe Text +metaProtocolVersion params = case metaLookup "protocolVersion" params of + Just (String v) -> Just v + _ -> Nothing + +-- | The @UnsupportedProtocolVersionError@ (-32022) for a declared version +-- this library does not implement, listing what it does. +unsupportedVersionError :: Text -> JsonRpcError +unsupportedVersionError requested = JsonRpcError + { errorCode = -32022 + , errorMessage = "Unsupported protocol version" + , errorData = Just $ object + [ "supported" .= allVersions + , "requested" .= requested + ] + } + +-- | Methods whose modern results carry the required cacheability fields. +cacheableMethods :: [Text] +cacheableMethods = + [ "server/discover" + , "tools/list" + , "prompts/list" + , "resources/list" + , "resources/read" + , "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\"@ (unless the result already carries one, as +-- an @input_required@ result does), the server's identity in result +-- @_meta@, and (for complete results of cacheable methods) @ttlMs@ and +-- @cacheScope@. Error responses and legacy responses pass through +-- untouched. +decorateModern :: McpServerInfo -> CacheHints -> Text -> JsonRpcResponse -> JsonRpcResponse +decorateModern serverInfo hints method resp = case responseResult resp of + Just (Object o) -> resp { responseResult = Just $ Object $ decorate o } + _ -> resp + where + decorate o = case KM.lookup "resultType" o of + Just _ -> insertMeta o + Nothing -> insertCache $ KM.insert "resultType" (String "complete") $ insertMeta o + insertMeta o = KM.insert "_meta" (Object meta) o + where meta = case KM.lookup "_meta" o of + Just (Object m) -> KM.insert serverInfoKey serverInfoVal m + _ -> KM.singleton serverInfoKey serverInfoVal + serverInfoKey = "io.modelcontextprotocol/serverInfo" + serverInfoVal = object + [ "name" .= serverName serverInfo + , "version" .= serverVersion serverInfo + ] + insertCache o + | method `elem` cacheableMethods = + KM.insert "ttlMs" (toJSON (cacheTtlMs hints)) $ + KM.insert "cacheScope" + (String (if cacheScopePublic hints then "public" else "private")) o + | otherwise = o + +-- | Handle an MCP message and return a response if needed. +-- +-- The server is dual-era: a request that declares a protocol revision in +-- its params @_meta@ (2026-07-28+) is served statelessly with the modern +-- result envelope; a request that does not is served exactly as before +-- under the revision negotiated by @initialize@. +-- +-- @codec@ seals and opens the @requestState@ of multi round-trip requests +-- (see "MCP.Server.RequestState"). +-- +-- @emit@ is the transport's request-scoped notification sink: progress and +-- client-log notifications for /this request/ are delivered through it, +-- interleaved before the response (stdio's shared channel, or the +-- request's SSE response stream on HTTP). +handleMcpMessage :: McpServerInfo + -> CacheHints + -> StateCodec + -> NotificationSupport + -> (JsonRpcNotification -> IO ()) + -> McpServerHandlers -> ClientContext -> JsonRpcMessage - -> m (Maybe JsonRpcMessage) -handleMcpMessage serverInfo handlers ctx (JsonRpcMessageRequest req) = do - response <- case requestMethod req of - "initialize" -> handleInitialize serverInfo handlers req - "ping" -> handlePing req - "prompts/list" -> handlePromptsList handlers ctx req - "prompts/get" -> handlePromptsGet handlers ctx req - "resources/list" -> handleResourcesList handlers ctx req - "resources/read" -> handleResourcesRead handlers ctx req - "tools/list" -> handleToolsList handlers ctx req - "tools/call" -> handleToolsCall handlers ctx req - method -> return $ makeErrorResponse (requestId req) $ JsonRpcError - { errorCode = -32601 - , errorMessage = "Method not found: " <> method - , errorData = Nothing - } - return $ Just $ JsonRpcMessageResponse response + -> IO (Maybe JsonRpcMessage) +handleMcpMessage serverInfo hints codec notifSupport emit handlers ctx0 (JsonRpcMessageRequest req) = do + let params = requestParams req + declaredVersion = metaProtocolVersion params + case declaredVersion of + Just v | v `notElem` modernVersions -> + return $ Just $ JsonRpcMessageResponse $ + makeErrorResponse (requestId req) (unsupportedVersionError v) + _ -> do + -- server/discover is itself a modern-revision method (and the + -- backwards-compatibility probe), so it always gets the modern + -- envelope even if a probing client omitted _meta. + let modern = isJust declaredVersion || requestMethod req == "server/discover" + ctx = ctx0 + { clientProtocolVersion = declaredVersion + , clientInfo = metaLookup "clientInfo" params + , clientCapabilities = metaLookup "clientCapabilities" params + , reportProgress = progressReporter emit params + , logToClient = clientLogger emit params + } + 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 + -- these are unknown methods there. + m | isJust declaredVersion, m `elem` ["initialize", "ping"] -> + return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32601 + , errorMessage = "Method not found: " <> m + <> " (not part of protocol revision " <> fromMaybe "" declaredVersion <> ")" + , errorData = Nothing + } + "initialize" -> handleInitialize serverInfo notifSupport handlers req + "ping" -> handlePing req + "server/discover" -> handleServerDiscover serverInfo notifSupport handlers req + "prompts/list" -> handlePromptsList handlers ctx req + "prompts/get" -> handlePromptsGet codec handlers ctx req + "resources/list" -> handleResourcesList handlers ctx req + "resources/read" -> handleResourcesRead codec handlers ctx req + "resources/templates/list" -> handleResourcesTemplatesList handlers ctx req + "tools/list" -> handleToolsList handlers ctx req + "tools/call" -> handleToolsCall codec handlers ctx req + "completion/complete" -> handleCompletionComplete handlers ctx req + method -> return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32601 + , errorMessage = "Method not found: " <> method + , errorData = Nothing + } + let response' = if modern + then decorateModern serverInfo hints (requestMethod req) response + else response + return $ Just $ JsonRpcMessageResponse response' -handleMcpMessage _ _ _ (JsonRpcMessageNotification notif) = do +handleMcpMessage _ _ _ _ _ _ _ (JsonRpcMessageNotification notif) = do case notificationMethod notif of - "notifications/initialized" -> do - liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation" - return () - _ -> do - liftIO $ hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif) - return () + "notifications/initialized" -> + hPutStrLn stderr "Received initialized notification - server is ready for operation" + _ -> + hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif) return Nothing -handleMcpMessage _ _ _ (JsonRpcMessageResponse _) = +handleMcpMessage _ _ _ _ _ _ _ (JsonRpcMessageResponse _) = return Nothing +-- | The 'reportProgress' action for a request: emits +-- @notifications\/progress@ tagged with the request's @progressToken@, or +-- does nothing when no token was provided. +progressReporter :: (JsonRpcNotification -> IO ()) -> Maybe Value -> Double -> Maybe Double -> Maybe Text -> IO () +progressReporter emit params = case plainMetaLookup "progressToken" params of + Nothing -> \_ _ _ -> pure () + Just token -> \progress total message -> + emit $ makeNotification "notifications/progress" $ Just $ object $ + [ "progressToken" .= token + , "progress" .= progress + ] ++ maybe [] (\t -> ["total" .= t]) total + ++ maybe [] (\m -> ["message" .= m]) message + +-- | The 'logToClient' action for a request: emits @notifications\/message@ +-- at or above the request's declared @io.modelcontextprotocol/logLevel@, +-- and nothing at all when the request did not declare one (the spec +-- forbids it). +clientLogger :: (JsonRpcNotification -> IO ()) -> Maybe Value -> LogLevel -> Value -> IO () +clientLogger emit params = case declared of + Nothing -> \_ _ -> pure () + Just threshold -> \level payload -> + when (level >= threshold) $ + emit $ makeNotification "notifications/message" $ Just $ object + [ "level" .= level + , "data" .= payload + ] + where + declared = do + v <- metaLookup "logLevel" params + case fromJSON v of + Success l -> Just l + Error _ -> Nothing + -- | Handle initialize request -handleInitialize :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse -handleInitialize serverInfo handlers req = do +handleInitialize :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse +handleInitialize serverInfo notifSupport handlers req = do case requestParams req of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = -32602 @@ -130,29 +333,66 @@ , errorData = Nothing } Right negotiatedVersion -> do - liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion - -- Only advertise a capability that actually has a handler. - -- Advertising e.g. "prompts" while prompts/list returns an error - -- makes strict clients (e.g. Crush) drop the whole server. - let capabilities = ServerCapabilities - { capabilityPrompts = PromptCapabilities { promptListChanged = Nothing } <$ prompts handlers - , capabilityResources = ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing } <$ resources handlers - , capabilityTools = ToolCapabilities { toolListChanged = Nothing } <$ tools handlers - , capabilityLogging = Nothing -- Not supported yet - } + hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion let response = InitializeResponse { initRespProtocolVersion = negotiatedVersion - , initRespCapabilities = capabilities + -- Legacy clients can only receive pushed notifications + -- where the transport supports it (stdio); the modern + -- subscribe mechanism is not part of their revision. + , initRespCapabilities = + handlerCapabilities (supportsLegacyPush notifSupport) False handlers , initRespServerInfo = serverInfo } return $ makeSuccessResponse (requestId req) (toJSON response) +-- | Only advertise a capability that actually has a handler. +-- Advertising e.g. "prompts" while prompts/list returns an error +-- makes strict clients (e.g. Crush) drop the whole server. +-- +-- The flags say whether change notifications (@listChanged@) and resource +-- update subscriptions (@subscribe@) are deliverable to the requesting +-- client — which depends on transport and era, so callers decide. +handlerCapabilities :: Bool -> Bool -> McpServerHandlers -> ServerCapabilities +handlerCapabilities listChanged subscribe handlers = ServerCapabilities + { capabilityPrompts = PromptCapabilities { promptListChanged = flag listChanged } <$ prompts handlers + , capabilityResources = + if isJust (resources handlers) || isJust (resourceTemplates handlers) + then Just ResourceCapabilities + { resourceSubscribe = flag subscribe + , resourceListChanged = flag listChanged + } + else Nothing + , capabilityTools = ToolCapabilities { toolListChanged = flag listChanged } <$ tools handlers + , capabilityCompletions = CompletionCapabilities <$ completions handlers + , capabilityLogging = Nothing -- Not supported yet + } + where + flag b = if b then Just True else Nothing + -- | Handle ping request -handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse +handlePing :: JsonRpcRequest -> IO JsonRpcResponse handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse) +-- | Handle server/discover (2026-07-28+): the server's supported protocol +-- revisions, capabilities and identity, available before any other request. +-- Also serves as the stdio backwards-compatibility probe. The modern result +-- envelope (resultType, serverInfo _meta, cacheability) is stamped on by +-- 'handleMcpMessage'. +handleServerDiscover :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse +handleServerDiscover serverInfo notifSupport handlers req = do + -- Modern clients receive notifications via subscriptions/listen, so both + -- listChanged and subscribe hinge on that being served. + let listen = supportsListen notifSupport + result = object $ + [ "supportedVersions" .= allVersions + , "capabilities" .= handlerCapabilities listen listen handlers + ] ++ (if T.null (serverInstructions serverInfo) + then [] + else ["instructions" .= serverInstructions serverInfo]) + return $ makeSuccessResponse (requestId req) result + -- | Handle prompts/list request -handlePromptsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handlePromptsList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handlePromptsList handlers ctx req = case prompts handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -168,8 +408,8 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle prompts/get request -handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse -handlePromptsGet handlers ctx req = +handlePromptsGet :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse +handlePromptsGet codec handlers ctx req = case prompts handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = -32601 @@ -191,26 +431,27 @@ , errorData = Nothing } Success getReq -> do - let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq) - result <- getHandler ctx (promptsGetName getReq) args - case result of - Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError - { errorCode = errorCodeFromMcpError err - , errorMessage = errorMessageFromMcpError err - , errorData = Nothing - } - Right content -> do - let response = PromptsGetResponse - { promptsGetDescription = Nothing - , promptsGetMessages = [PromptMessage RoleUser content] - , promptsGetMeta = Nothing -- Can be extended for additional metadata - } - return $ makeSuccessResponse (requestId req) (toJSON response) + -- Prompt arguments are string-valued per the MCP spec; flatten + -- any non-string values a lenient client may have sent. + let args = maybe Map.empty (fmap jsonValueToText) (promptsGetArguments getReq) + runRound codec ctx req + (\c -> getHandler c (promptsGetName getReq) args) + (\promptRes -> toJSON PromptsGetResponse + { promptsGetDescription = promptResultDescription promptRes + , promptsGetMessages = promptResultMessages promptRes + , promptsGetMeta = Nothing + }) -- | Handle resources/list request -handleResourcesList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handleResourcesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleResourcesList handlers ctx req = case resources handlers of + -- A templates-only configuration advertises the resources capability, + -- so resources/list must answer (with an empty list) rather than error: + -- strict clients drop servers whose advertised capabilities error. + Nothing | isJust (resourceTemplates handlers) -> + return $ makeSuccessResponse (requestId req) + (toJSON (ResourcesListResponse { resourcesListResources = [] })) Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = -32601 , errorMessage = "Resources not supported" @@ -224,8 +465,8 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle resources/read request -handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse -handleResourcesRead handlers ctx req = +handleResourcesRead :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse +handleResourcesRead codec handlers ctx req = case resources handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = -32601 @@ -246,22 +487,69 @@ , errorMessage = "Invalid parameters: " <> T.pack err , errorData = Nothing } - Success readReq -> do - result <- readHandler ctx (resourcesReadUri readReq) + Success readReq -> + runRound codec ctx req + (\c -> readHandler c (resourcesReadUri readReq)) + (\resourceContent -> toJSON ResourcesReadResponse + { resourcesReadContents = [resourceContent] + }) + +-- | Handle resources/templates/list request +handleResourcesTemplatesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse +handleResourcesTemplatesList handlers ctx req = + case resourceTemplates handlers of + Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32601 + , errorMessage = "Resource templates not supported" + , errorData = Nothing + } + Just listHandler -> do + templates <- listHandler ctx + let response = ResourcesTemplatesListResponse + { resourcesTemplatesList = templates + } + return $ makeSuccessResponse (requestId req) (toJSON response) + +-- | Handle completion/complete request +handleCompletionComplete :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse +handleCompletionComplete handlers ctx req = + case completions handlers of + Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32601 + , errorMessage = "Completions not supported" + , errorData = Nothing + } + Just completeHandler -> + case requestParams req of + Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32602 + , errorMessage = "Missing parameters" + , errorData = Nothing + } + Just params -> + case fromJSON params of + Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError + { errorCode = -32602 + , errorMessage = "Invalid parameters: " <> T.pack err + , errorData = Nothing + } + Success completeReq -> do + result <- completeHandler ctx + (completeRef completeReq) + (completeArgumentName completeReq) + (completeArgumentValue completeReq) + (completeContextArgs completeReq) case result of Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = errorCodeFromMcpError err , errorMessage = errorMessageFromMcpError err , errorData = Nothing } - Right resourceContent -> do - let response = ResourcesReadResponse - { resourcesReadContents = [resourceContent] - } - return $ makeSuccessResponse (requestId req) (toJSON response) + Right completion -> + return $ makeSuccessResponse (requestId req) (toJSON (CompleteResponse completion)) -- | Handle tools/list request -handleToolsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handleToolsList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleToolsList handlers ctx req = case tools handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -277,8 +565,8 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle tools/call request -handleToolsCall :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse -handleToolsCall handlers ctx req = +handleToolsCall :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse +handleToolsCall codec handlers ctx req = case tools handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError { errorCode = -32601 @@ -300,21 +588,46 @@ , errorData = Nothing } Success callReq -> do - let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq) - result <- callHandler ctx (toolsCallName callReq) args - case result of - Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError - { errorCode = errorCodeFromMcpError err - , errorMessage = errorMessageFromMcpError err - , errorData = Nothing - } - Right content -> do - let response = ToolsCallResponse - { toolsCallContent = [content] - , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- Can be extended for structured output - } - return $ makeSuccessResponse (requestId req) (toJSON response) + -- Tool arguments are passed through as full JSON values. + let args = fromMaybe Map.empty (toolsCallArguments callReq) + runRound codec ctx req + (\c -> callHandler c (toolsCallName callReq) args) + (\toolRes -> toJSON ToolsCallResponse + { toolsCallContent = toolResultContent toolRes + , toolsCallIsError = if toolResultIsError toolRes then Just True else Nothing + , toolsCallStructuredContent = toolResultStructured toolRes + , toolsCallMeta = toolResultMeta toolRes + }) + +-- | Run a handler that may ask the client for input (multi round-trip +-- requests): read a retry's answers and verified state into the context, +-- run the handler, and answer with its result, its error, or an +-- @input_required@ result. +runRound :: StateCodec + -> ClientContext + -> JsonRpcRequest + -> (ClientContext -> IO (Either Error (Outcome a))) + -> (a -> Value) + -> IO JsonRpcResponse +runRound codec ctx0 req run render = do + let rid = requestId req + method = requestMethod req + params = requestParams req + prepared <- beginRound codec method params ctx0 + case prepared of + Left err -> pure (makeErrorResponse rid err) + Right ctx -> do + result <- run ctx + case result of + Left err -> pure $ makeErrorResponse rid JsonRpcError + { errorCode = errorCodeFromMcpError err + , errorMessage = errorMessageFromMcpError err + , errorData = Nothing + } + Right (Complete a) -> pure (makeSuccessResponse rid (render a)) + Right (InputRequired requests state) -> do + answer <- inputRequiredResult codec method params ctx requests state + pure (either (makeErrorResponse rid) (makeSuccessResponse rid) answer) -- | Convert MCP error to JSON-RPC error code errorCodeFromMcpError :: Error -> Int diff --git a/src/MCP/Server/Internal/InputRound.hs b/src/MCP/Server/Internal/InputRound.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Internal/InputRound.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The library's side of multi round-trip requests: reading a retry's +-- @inputResponses@ and @requestState@ into the handler's context, and +-- turning a handler's 'InputRequired' into an @input_required@ result. +-- +-- The sealed state carries, besides the handler's own state, what the spec +-- asks servers to bind it to: the caller (a digest of the principal), the +-- originating request (the method and a digest of its parameters) and an +-- expiry. All four are checked before the handler runs again. +module MCP.Server.Internal.InputRound + ( beginRound + , inputRequiredResult + ) where + +import Control.Monad (unless, when) +import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as BSL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import System.IO (hPutStrLn, stderr) + +import MCP.Server.Internal.Json (jsonDigest) +import MCP.Server.JsonRpc (JsonRpcError (..)) +import MCP.Server.RequestState +import MCP.Server.Types + +-- | What is sealed into a request state. +data Payload = Payload + { payloadMethod :: Text + , payloadParams :: Text -- ^ Digest of the request parameters + , payloadPrincipal :: Text -- ^ Digest of the caller's principal + , payloadExpires :: Integer -- ^ POSIX seconds + , payloadKeys :: [Text] -- ^ The keys of the requests issued + , payloadState :: Maybe Text -- ^ The handler's own state + } + +instance ToJSON Payload where + toJSON p = object + [ "v" .= (1 :: Int) + , "m" .= payloadMethod p + , "d" .= payloadParams p + , "p" .= payloadPrincipal p + , "e" .= payloadExpires p + , "k" .= payloadKeys p + , "s" .= payloadState p + ] + +instance FromJSON Payload where + parseJSON = withObject "Payload" $ \o -> do + version <- o .: "v" + unless (version == (1 :: Int)) $ fail "unsupported state version" + Payload <$> o .: "m" <*> o .: "d" <*> o .: "p" <*> o .: "e" <*> o .: "k" <*> o .:? "s" + +-- | Prepare the context for a call that may be a retry. Legacy requests +-- have no multi round-trip semantics, so their context is left alone. +-- +-- Answers are only taken from a retry that carries the state of the round +-- that asked, and only for the keys that round issued: anything else in +-- @inputResponses@ is ignored, as the spec asks, so a client cannot +-- volunteer answers the handler never requested. A retry's state is +-- verified before anything else; a failure is a @-32602@ the handler never +-- sees. +beginRound :: StateCodec -> Text -> Maybe Value -> ClientContext + -> IO (Either JsonRpcError ClientContext) +beginRound codec method params ctx + | Nothing <- clientProtocolVersion ctx = pure (Right ctx) + | otherwise = case field "requestState" of + Nothing -> pure (Right ctx) + Just (String sealed) -> do + opened <- openPayload codec method params ctx sealed + pure $ do + (keys, state) <- opened + responses <- issuedResponses keys + Right ctx { clientInputResponses = responses, clientRequestState = state } + Just _ -> pure $ Left $ invalidParams "Invalid requestState: expected a string" + where + field key = case params of + Just (Object o) -> KM.lookup key o + _ -> Nothing + issuedResponses keys = case field "inputResponses" of + Nothing -> Right Map.empty + Just (Object rs) -> Map.fromList <$> traverse parseIssued + [ (key, v) | key <- keys, Just v <- [KM.lookup (Key.fromText key) rs] ] + Just _ -> Left $ invalidParams "Invalid inputResponses: expected an object" + parseIssued (key, v) = case parseEither parseJSON v of + Right response -> Right (key, response) + Left err -> Left $ invalidParams $ "Invalid inputResponses: " <> key <> ": " <> T.pack err + +-- | The @input_required@ result for a handler's requests and state, or a +-- @-32603@ when the handler asked for input this client cannot provide +-- (a server bug: handlers should check 'clientSupportsInput'). +inputRequiredResult :: StateCodec -> Text -> Maybe Value -> ClientContext + -> Map Text InputRequest -> Maybe Text + -> IO (Either JsonRpcError Value) +inputRequiredResult codec method params ctx requests state + | Nothing <- clientProtocolVersion ctx = + pure $ Left $ internalError + "the handler requested input, which the client's protocol revision does not support" + | unsupported@(_ : _) <- [key | (key, request) <- Map.toList requests + , not (clientSupportsInput ctx request)] = + pure $ Left $ internalError $ + "the handler requested input the client cannot provide (" + <> T.intercalate ", " unsupported <> ")" + | otherwise = do + now <- getPOSIXTime + let payload = Payload + { payloadMethod = method + , payloadParams = paramsDigest params + , payloadPrincipal = principalDigest ctx + , payloadExpires = floor (now + stateLifetime codec) + , payloadKeys = Map.keys requests + , payloadState = state + } + sealed <- sealState codec (BSL.toStrict (encode payload)) + pure $ Right $ object + [ "resultType" .= ("input_required" :: Text) + , "inputRequests" .= requests + , "requestState" .= sealed + ] + where + internalError message = JsonRpcError + { errorCode = -32603 + , errorMessage = "Internal error: " <> message + , errorData = Nothing + } + +openPayload :: StateCodec -> Text -> Maybe Value -> ClientContext -> Text + -> IO (Either JsonRpcError ([Text], Maybe Text)) +openPayload codec method params ctx sealed = do + opened <- openState codec sealed + now <- getPOSIXTime + let check = do + bytes <- case opened of + Left StateUnknownKey -> Left (unknownKey, "unknown key id") + Left StateInvalid -> Left (invalid, "could not be opened") + Right b -> Right b + payload <- either (\e -> Left (invalid, "bad payload: " <> T.pack e)) Right $ + eitherDecodeStrict bytes + when (payloadMethod payload /= method) $ + Left (invalid, "issued for " <> payloadMethod payload <> ", presented on " <> method) + when (payloadParams payload /= paramsDigest params) $ + Left (invalid, "issued for different request parameters") + when (payloadPrincipal payload /= principalDigest ctx) $ + Left (invalid, "issued to a different principal") + when (fromInteger (payloadExpires payload) < now) $ + Left (expired, "expired") + pure (payloadKeys payload, payloadState payload) + case check of + Right issued -> pure (Right issued) + Left (err, reason) -> do + hPutStrLn stderr $ "Rejected requestState on " <> T.unpack method <> ": " <> T.unpack reason + pure (Left err) + where + invalid = invalidParams "Invalid requestState" + expired = invalidParams "requestState has expired: retry the request without it" + unknownKey = invalidParams + "requestState was issued by another server instance or under a retired key" + +invalidParams :: Text -> JsonRpcError +invalidParams message = JsonRpcError + { errorCode = -32602 + , errorMessage = message + , errorData = Nothing + } + +-- | Digest of the request parameters that define the request: everything +-- but the round's own fields and @_meta@. +paramsDigest :: Maybe Value -> Text +paramsDigest params = jsonDigest $ case params of + Just (Object o) -> Object (foldr KM.delete o ["inputResponses", "requestState", "_meta"]) + Just v -> v + Nothing -> Null + +principalDigest :: ClientContext -> Text +principalDigest = jsonDigest . maybe Null id . clientPrincipal diff --git a/src/MCP/Server/Internal/Json.hs b/src/MCP/Server/Internal/Json.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Internal/Json.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Deterministic JSON encoding, for JSON that ends up inside a string or a +-- digest, where structural comparison cannot see through the bytes. +module MCP.Server.Internal.Json + ( canonicalJson + , canonicalJsonText + , jsonDigest + ) where + +import qualified Crypto.Hash as Hash + +import Data.Aeson (ToJSON (..), Value (..), encode) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteArray as BA +import qualified Data.ByteString.Base64.URL as B64 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +-- | Compact JSON with objects in sorted-key order, independent of the +-- aeson\/hashable pair in the build plan. +canonicalJson :: Value -> BSL.ByteString +canonicalJson = encode . Canonical + +-- | 'canonicalJson' as text. Used wherever JSON ends up /inside a string/ +-- (the structured-output text block): structural comparison cannot see +-- through a string, so those bytes must be deterministic — which also +-- keeps repeated tool results stable for client prompt caching. +canonicalJsonText :: Value -> Text +canonicalJsonText = TE.decodeUtf8 . BSL.toStrict . canonicalJson + +-- | SHA-256 of 'canonicalJson', base64url-encoded: equal for structurally +-- equal values. +jsonDigest :: Value -> Text +jsonDigest v = TE.decodeUtf8 $ B64.encode $ BA.convert + (Hash.hashlazy (canonicalJson v) :: Hash.Digest Hash.SHA256) + +-- Encoding-only wrapper: objects are emitted via a sorted 'Map', arrays +-- and atoms recurse. 'encode' uses 'toEncoding', so no KeyMap is rebuilt. +newtype Canonical = Canonical Value + +instance ToJSON Canonical where + toJSON (Canonical v) = v + toEncoding (Canonical (Object o)) = + toEncoding (Map.fromList [(Key.toText k, Canonical v) | (k, v) <- KM.toList o]) + toEncoding (Canonical (Array xs)) = toEncoding (fmap Canonical xs) + toEncoding (Canonical v) = toEncoding v diff --git a/src/MCP/Server/JsonRpc.hs b/src/MCP/Server/JsonRpc.hs --- a/src/MCP/Server/JsonRpc.hs +++ b/src/MCP/Server/JsonRpc.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | JSON-RPC 2.0 messages: requests, responses, errors and notifications, +-- with parsing and encoding. module MCP.Server.JsonRpc ( -- * JSON-RPC Types JsonRpcRequest(..) @@ -20,9 +22,10 @@ import Data.Text (Text) import Data.Aeson +import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (parseEither) +import Data.Scientific (toBoundedInteger) import GHC.Generics (Generic) -import Control.Applicative ((<|>)) -- | JSON-RPC request ID data RequestId @@ -38,7 +41,9 @@ instance FromJSON RequestId where parseJSON (String t) = return $ RequestIdText t - parseJSON (Number n) = return $ RequestIdNumber (round n) + parseJSON (Number n) = case toBoundedInteger n of + Just i -> return $ RequestIdNumber i + Nothing -> fail "Request id must be an integral number" parseJSON Null = return RequestIdNull parseJSON _ = fail "Invalid request ID" @@ -137,12 +142,16 @@ toJSON (JsonRpcMessageResponse resp) = toJSON resp toJSON (JsonRpcMessageNotification notif) = toJSON notif +-- | Classify by shape instead of parse-fallthrough: a request with a +-- malformed field must fail as a request, not silently succeed as a +-- notification (which has fewer required fields). instance FromJSON JsonRpcMessage where - parseJSON v = parseRequest v <|> parseResponse v <|> parseNotification v - where - parseRequest = fmap JsonRpcMessageRequest . parseJSON - parseResponse = fmap JsonRpcMessageResponse . parseJSON - parseNotification = fmap JsonRpcMessageNotification . parseJSON + parseJSON = withObject "JsonRpcMessage" $ \o -> + case (KM.member "method" o, KM.member "id" o) of + (True, True) -> JsonRpcMessageRequest <$> parseJSON (Object o) + (True, False) -> JsonRpcMessageNotification <$> parseJSON (Object o) + (False, True) -> JsonRpcMessageResponse <$> parseJSON (Object o) + (False, False) -> fail "Not a JSON-RPC message: no method and no id" -- | Create a successful JSON-RPC response makeSuccessResponse :: RequestId -> Value -> JsonRpcResponse diff --git a/src/MCP/Server/Notifications.hs b/src/MCP/Server/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Notifications.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Server-initiated change notifications. +-- +-- Create a notifier with 'newMcpNotifier', hand the t'NotificationSource' to +-- a transport via its configuration ('MCP.Server.Transport.Stdio.StdioConfig' +-- \/ 'MCP.Server.Transport.Http.HttpConfig'), keep the t'McpNotifier', and +-- call its actions whenever your tool\/prompt\/resource lists (or a specific +-- resource) change: +-- +-- > (notifier, source) <- newMcpNotifier +-- > let config = defaultStdioConfig { stdioNotifications = Just source } +-- > _ <- forkIO $ appLogic notifier +-- > runMcpServerStdioWithConfig config serverInfo handlers +-- +-- Delivery is transport- and era-specific: modern (2026-07-28) clients open +-- a @subscriptions\/listen@ stream and receive only the notification types +-- they opted into, tagged with their subscription id; legacy stdio clients +-- receive untagged notifications spontaneously after @initialize@. Legacy +-- HTTP has no delivery channel (this library dropped the deprecated GET SSE +-- stream), so the @listChanged@ capabilities are not advertised there. +module MCP.Server.Notifications + ( -- * Notifier + McpNotifier(..) + , NotificationSource + , newMcpNotifier + , ChangeEvent(..) + , subscribeEvents + + -- * Subscription wire format (used by transports) + , NotificationFilter(..) + , parseNotificationFilter + , filterAccepts + , filterIsEmpty + , acknowledgedNotification + , eventNotification + , legacyEventNotification + , closureResponse + ) where + +import Control.Concurrent.STM (STM, TChan, atomically, + dupTChan, newBroadcastTChanIO, + writeTChan) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI (URI) + +import MCP.Server.JsonRpc +import MCP.Server.Types (McpServerInfo (..)) + +-- | A change an application can announce. +data ChangeEvent + = ToolsListChangedEvent + | PromptsListChangedEvent + | ResourcesListChangedEvent + | ResourceUpdatedEvent Text -- ^ the resource URI, rendered + deriving (Show, Eq) + +-- | The application-facing handle: call these when things change. +data McpNotifier = McpNotifier + { notifyToolsListChanged :: IO () + , notifyPromptsListChanged :: IO () + , notifyResourcesListChanged :: IO () + , notifyResourceUpdated :: URI -> IO () + } + +-- | The transport-facing end of a notifier: subscribe with +-- 'subscribeEvents'. Backed by a broadcast 'TChan', so events published +-- while nobody listens are dropped rather than retained. +newtype NotificationSource = NotificationSource (TChan ChangeEvent) + +-- | Create a notifier and its source. +newMcpNotifier :: IO (McpNotifier, NotificationSource) +newMcpNotifier = do + chan <- newBroadcastTChanIO + let publish = atomically . writeTChan chan + pure + ( McpNotifier + { notifyToolsListChanged = publish ToolsListChangedEvent + , notifyPromptsListChanged = publish PromptsListChangedEvent + , notifyResourcesListChanged = publish ResourcesListChangedEvent + , notifyResourceUpdated = publish . ResourceUpdatedEvent . T.pack . show + } + , NotificationSource chan + ) + +-- | A private read end delivering every event published after the call. +subscribeEvents :: NotificationSource -> STM (TChan ChangeEvent) +subscribeEvents (NotificationSource chan) = dupTChan chan + +-- | Which notification types a @subscriptions\/listen@ request opted into. +data NotificationFilter = NotificationFilter + { filterTools :: Bool + , filterPrompts :: Bool + , filterResources :: Bool + , filterResourceSubs :: [Text] -- ^ URIs watched for updates + } deriving (Show, Eq) + +-- | Parse the @notifications@ filter out of a @subscriptions\/listen@ +-- request's params. Absent fields mean "not subscribed". +parseNotificationFilter :: Maybe Value -> NotificationFilter +parseNotificationFilter params = NotificationFilter + { filterTools = boolField "toolsListChanged" + , filterPrompts = boolField "promptsListChanged" + , filterResources = boolField "resourcesListChanged" + , filterResourceSubs = subsField + } + where + notifications = do + Object o <- params + KM.lookup "notifications" o + boolField key = case notifications of + Just (Object n) | Just (Bool b) <- KM.lookup key n -> b + _ -> False + subsField = case notifications of + Just (Object n) | Just (Array xs) <- KM.lookup "resourceSubscriptions" n -> + [u | String u <- foldr (:) [] xs] + _ -> [] + +-- | Whether a subscription with this filter receives the event. +filterAccepts :: NotificationFilter -> ChangeEvent -> Bool +filterAccepts f ToolsListChangedEvent = filterTools f +filterAccepts f PromptsListChangedEvent = filterPrompts f +filterAccepts f ResourcesListChangedEvent = filterResources f +filterAccepts f (ResourceUpdatedEvent uri) = uri `elem` filterResourceSubs f + +-- | True when the filter subscribes to nothing at all. +filterIsEmpty :: NotificationFilter -> Bool +filterIsEmpty f = + not (filterTools f || filterPrompts f || filterResources f) + && null (filterResourceSubs f) + +-- | The @_meta@ object tagging a message with its subscription id (the +-- JSON-RPC id of the @subscriptions\/listen@ request). +subscriptionMeta :: RequestId -> Pair +subscriptionMeta subId = + "_meta" .= object ["io.modelcontextprotocol/subscriptionId" .= subId] + +-- | The mandatory first message of a subscription stream: the honored +-- filter (this library honors every requested type). +acknowledgedNotification :: RequestId -> NotificationFilter -> JsonRpcNotification +acknowledgedNotification subId f = + makeNotification "notifications/subscriptions/acknowledged" $ Just $ object + [ subscriptionMeta subId + , "notifications" .= object (concat + [ ["toolsListChanged" .= True | filterTools f] + , ["promptsListChanged" .= True | filterPrompts f] + , ["resourcesListChanged" .= True | filterResources f] + , ["resourceSubscriptions" .= filterResourceSubs f | not (null (filterResourceSubs f))] + ]) + ] + +-- | The method and extra params of an event's notification. +eventBody :: ChangeEvent -> (Text, [Pair]) +eventBody ToolsListChangedEvent = ("notifications/tools/list_changed", []) +eventBody PromptsListChangedEvent = ("notifications/prompts/list_changed", []) +eventBody ResourcesListChangedEvent = ("notifications/resources/list_changed", []) +eventBody (ResourceUpdatedEvent uri) = ("notifications/resources/updated", ["uri" .= uri]) + +-- | A change event as a subscription-tagged notification (modern era). +eventNotification :: RequestId -> ChangeEvent -> JsonRpcNotification +eventNotification subId event = + let (method, extra) = eventBody event + in makeNotification method $ Just $ object (subscriptionMeta subId : extra) + +-- | A change event as an untagged notification (legacy stdio delivery). +legacyEventNotification :: ChangeEvent -> JsonRpcNotification +legacyEventNotification event = + let (method, extra) = eventBody event + in makeNotification method $ if null extra then Nothing else Just (object extra) + +-- | The graceful-closure response a server sends when it ends a +-- subscription on its own initiative (e.g. shutdown). Like every modern +-- result it carries the server identity alongside the subscription id. +closureResponse :: McpServerInfo -> RequestId -> JsonRpcResponse +closureResponse serverInfo subId = makeSuccessResponse subId $ object + [ "resultType" .= ("complete" :: Text) + , "_meta" .= object + [ "io.modelcontextprotocol/subscriptionId" .= subId + , "io.modelcontextprotocol/serverInfo" .= object + [ "name" .= serverName serverInfo + , "version" .= serverVersion serverInfo + ] + ] + ] diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | Request and response payloads for each MCP method, and the protocol +-- revisions this library supports. module MCP.Server.Protocol ( -- * MCP Protocol Messages InitializeRequest(..) @@ -22,7 +24,12 @@ , ResourcesListResponse(..) , ResourcesReadRequest(..) , ResourcesReadResponse(..) + , ResourcesTemplatesListResponse(..) + -- * Completion Protocol + , CompleteRequest(..) + , CompleteResponse(..) + -- * Tools Protocol , ToolsListRequest(..) , ToolsListResponse(..) @@ -35,20 +42,27 @@ -- * Protocol Functions , protocolVersion , supportedVersions + , modernVersions + , allVersions ) where import Data.Aeson +import Data.Aeson.Types (Parser) import Data.Map (Map) import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics (Generic) import MCP.Server.Types --- | The protocol revision the server advertises by default. Used as the --- fallback when a client proposes a version this library does not recognise. +-- | The newest /legacy/ (initialize-handshake) revision the server +-- advertises by default. Used as the fallback when an initializing client +-- proposes a version this library does not recognise — deliberately capped +-- at the newest legacy revision: a client that sends @initialize@ is legacy +-- by definition and must not be promised the stateless 2026-07-28 semantics. protocolVersion :: Text protocolVersion = "2025-11-25" --- | Date-versioned MCP revisions whose wire format for the basic +-- | Legacy (initialize-handshake) revisions whose wire format for the basic -- tool/resource/prompt operations this library implements is identical. -- The server echoes back any of these a client proposes (see -- 'MCP.Server.Handlers.validateProtocolVersion'), satisfying the spec @@ -63,7 +77,21 @@ , "2024-11-05" ] +-- | Modern (stateless, per-request @_meta@) revisions this library +-- implements. Requests declaring one of these are served with modern +-- semantics: @resultType@, cacheability fields, and @serverInfo@ in result +-- @_meta@. +modernVersions :: [Text] +modernVersions = + [ "2026-07-28" + ] +-- | Every revision this library implements, newest first — what +-- @server\/discover@ and @UnsupportedProtocolVersionError@ report. +allVersions :: [Text] +allVersions = modernVersions ++ supportedVersions + + -- | Initialize request data InitializeRequest = InitializeRequest { initProtocolVersion :: Text @@ -116,26 +144,6 @@ instance ToJSON PongResponse where toJSON PongResponse = object [] --- | Message role for prompts -data MessageRole = RoleUser | RoleAssistant - deriving (Show, Eq, Generic) - -instance ToJSON MessageRole where - toJSON RoleUser = "user" - toJSON RoleAssistant = "assistant" - --- | Prompt message -data PromptMessage = PromptMessage - { promptMessageRole :: MessageRole - , promptMessageContent :: Content - } deriving (Show, Eq, Generic) - -instance ToJSON PromptMessage where - toJSON msg = object - [ "role" .= promptMessageRole msg - , "content" .= promptMessageContent msg - ] - -- | Prompts list request data PromptsListRequest = PromptsListRequest deriving (Show, Eq, Generic) @@ -216,6 +224,58 @@ [ "contents" .= resourcesReadContents resp ] +-- | Resource templates list response +data ResourcesTemplatesListResponse = ResourcesTemplatesListResponse + { resourcesTemplatesList :: [ResourceTemplateDefinition] + } deriving (Show, Eq, Generic) + +instance ToJSON ResourcesTemplatesListResponse where + toJSON resp = object + [ "resourceTemplates" .= resourcesTemplatesList resp + ] + +-- | Completion request (completion/complete) +data CompleteRequest = CompleteRequest + { completeRef :: CompletionRef + , completeArgumentName :: Text + , completeArgumentValue :: Text + , completeContextArgs :: Map Text Text + } deriving (Show, Eq, Generic) + +instance FromJSON CompleteRequest where + parseJSON = withObject "CompleteRequest" $ \o -> do + refObj <- o .: "ref" + ref <- withObject "CompletionRef" + (\r -> do + refType <- r .: "type" :: Parser Text + case refType of + "ref/prompt" -> CompletionRefPrompt <$> r .: "name" + "ref/resource" -> CompletionRefResource <$> r .: "uri" + _ -> fail $ "Unknown completion ref type: " ++ T.unpack refType) + refObj + argument <- o .: "argument" + (name, value) <- withObject "argument" + (\a -> (,) <$> a .: "name" <*> a .: "value") + argument + ctx <- o .:? "context" + ctxArgs <- case ctx of + Nothing -> pure mempty + Just c -> withObject "context" (\co -> co .:? "arguments" .!= mempty) c + pure $ CompleteRequest ref name value ctxArgs + +-- | Completion response +data CompleteResponse = CompleteResponse + { completeResult :: CompletionResult + } deriving (Show, Eq, Generic) + +instance ToJSON CompleteResponse where + toJSON (CompleteResponse res) = object + [ "completion" .= object + ([ "values" .= take 100 (completionValues res) ] + ++ maybe [] (\t -> ["total" .= t]) (completionTotal res) + ++ maybe [] (\h -> ["hasMore" .= h]) (completionHasMore res)) + ] + -- | Tools list request data ToolsListRequest = ToolsListRequest deriving (Show, Eq, Generic) @@ -246,15 +306,17 @@ -- | Tools call response (2025-06-18 enhanced) data ToolsCallResponse = ToolsCallResponse - { toolsCallContent :: [Content] - , toolsCallIsError :: Maybe Bool - , toolsCallMeta :: Maybe Value -- New _meta field for structured output + { toolsCallContent :: [Content] + , toolsCallIsError :: Maybe Bool + , toolsCallStructuredContent :: Maybe Value -- ^ structuredContent (2025-06-18+) + , toolsCallMeta :: Maybe Value } deriving (Show, Eq, Generic) instance ToJSON ToolsCallResponse where toJSON resp = object $ [ "content" .= toolsCallContent resp ] ++ maybe [] (\e -> ["isError" .= e]) (toolsCallIsError resp) + ++ maybe [] (\s -> ["structuredContent" .= s]) (toolsCallStructuredContent resp) ++ maybe [] (\m -> ["_meta" .= m]) (toolsCallMeta resp) -- | List changed notification diff --git a/src/MCP/Server/RequestState.hs b/src/MCP/Server/RequestState.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/RequestState.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Protection for the @requestState@ of multi round-trip requests. +-- +-- When a handler answers with 'MCP.Server.Types.InputRequired', the +-- client must echo the request state back on its retry. The specification +-- treats that state as attacker-controlled, so the library never hands it +-- to the client in the clear: it binds the state to the caller, the +-- original request and an expiry, then seals it with a t'StateCodec'. +-- +-- The default codec, 'ephemeralStateCodec', encrypts with a random key +-- created when the transport starts. That is right for stdio and for a +-- single HTTP instance. Deployments with several instances behind a load +-- balancer must share a key, with 'aeadStateCodec': +-- +-- > Just key = stateKey "2026-10" keyBytes -- 32 secret bytes +-- > config = defaultHttpConfig { httpStateCodec = Just (aeadStateCodec key []) } +-- +-- To rotate keys, seal with the new key and keep accepting the old one +-- until its states have expired: @aeadStateCodec newKey [oldKey]@. +module MCP.Server.RequestState + ( -- * Codecs + StateCodec(..) + , StateError(..) + , defaultStateLifetime + , aeadStateCodec + , ephemeralStateCodec + -- * Keys + , StateKey + , stateKey + , stateKeyId + ) where + +import Crypto.Cipher.ChaChaPoly1305 (aeadChacha20poly1305Init) +import Crypto.Cipher.Types (AuthTag (..), aeadSimpleDecrypt, + aeadSimpleEncrypt) +import Crypto.Error (maybeCryptoError) +import Crypto.Random (getRandomBytes) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64 +import Data.Char (isAsciiLower, isAsciiUpper, + isDigit) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (NominalDiffTime) +import Numeric (showHex) + +-- | How sealed request state is produced and checked. The library builds +-- the plaintext (the caller, the request, the expiry and the handler's +-- state) and verifies it after 'openState'; a codec only has to keep it +-- confidential and tamper-evident. +-- +-- Replace the codec to manage keys elsewhere, or to keep states on the +-- server and hand the client only a reference. +data StateCodec = StateCodec + { sealState :: ByteString -> IO Text + -- ^ Seal plaintext into the opaque string sent to the client. + , openState :: Text -> IO (Either StateError ByteString) + -- ^ Recover the plaintext from a string the client sent back. + , stateLifetime :: NominalDiffTime + -- ^ How long a state stays valid after it is issued. + } + +-- | Why a state could not be opened. +data StateError + = StateUnknownKey + -- ^ Sealed under a key this codec does not have: issued by another + -- server instance, or under a key that has since been retired. + | StateInvalid + -- ^ Malformed, or altered after it was sealed. + deriving (Show, Eq) + +-- | 60 minutes: long enough for a user to fill in a form. +defaultStateLifetime :: NominalDiffTime +defaultStateLifetime = 3600 + +-- | A 256-bit key for 'aeadStateCodec', with an id that is stored next to +-- each sealed state so the right key is used to open it. +data StateKey = StateKey Text ByteString + +-- | A key from its id and 32 secret bytes. The id is 1–32 characters of +-- ASCII letters, digits, @-@ and @_@; it is visible to clients, so it +-- should not reveal anything. 'Nothing' if either is invalid. +stateKey :: Text -> ByteString -> Maybe StateKey +stateKey kid secret + | validId && BS.length secret == 32 = Just (StateKey kid secret) + | otherwise = Nothing + where + validId = not (T.null kid) && T.length kid <= 32 && T.all idChar kid + idChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '-' || c == '_' + +-- | The id of a key. +stateKeyId :: StateKey -> Text +stateKeyId (StateKey kid _) = kid + +-- | Seal with ChaCha20-Poly1305 under the first key, with a random nonce +-- for every state; open with that key or any of the others. States last +-- 'defaultStateLifetime'; set 'stateLifetime' to change that. +aeadStateCodec :: StateKey -> [StateKey] -> StateCodec +aeadStateCodec current older = StateCodec + { sealState = sealWith current + , openState = pure . openWith (current : older) + , stateLifetime = defaultStateLifetime + } + +-- | 'aeadStateCodec' with a random key, created afresh by each call. States +-- cannot be opened by another process, or after a restart. +ephemeralStateCodec :: IO StateCodec +ephemeralStateCodec = do + secret <- getRandomBytes 32 + idBytes <- getRandomBytes 6 :: IO ByteString + let kid = "ephemeral-" <> T.pack (concatMap hex (BS.unpack idBytes)) + hex b = let s = showHex b "" in if length s < 2 then '0' : s else s + case stateKey kid secret of + Just key -> pure (aeadStateCodec key []) + Nothing -> error "ephemeralStateCodec: generated an invalid key" + +-- Wire format: @.@. The key +-- id and a format version are authenticated as associated data. + +nonceSize, tagSize :: Int +nonceSize = 12 +tagSize = 16 + +associatedData :: Text -> ByteString +associatedData kid = "mcp-server/requestState/v1:" <> TE.encodeUtf8 kid + +sealWith :: StateKey -> ByteString -> IO Text +sealWith (StateKey kid secret) plaintext = do + nonce <- getRandomBytes nonceSize :: IO ByteString + case maybeCryptoError (aeadChacha20poly1305Init secret nonce) of + Nothing -> error "aeadStateCodec: invalid key or nonce" + Just aead -> do + let (AuthTag tag, ciphertext) = + aeadSimpleEncrypt aead (associatedData kid) plaintext tagSize + blob = nonce <> ciphertext <> BA.convert tag + pure (kid <> "." <> TE.decodeUtf8 (B64.encode blob)) + +openWith :: [StateKey] -> Text -> Either StateError ByteString +openWith keys sealed = do + let (kid, rest) = T.breakOn "." sealed + StateKey _ secret <- maybe (Left StateUnknownKey) Right $ + lookup kid [(k, key) | key@(StateKey k _) <- keys] + blob <- either (const (Left StateInvalid)) Right $ + B64.decode (TE.encodeUtf8 (T.drop 1 rest)) + if BS.length blob < nonceSize + tagSize + then Left StateInvalid + else do + let (nonce, body) = BS.splitAt nonceSize blob + (ciphertext, tag) = BS.splitAt (BS.length body - tagSize) body + aead <- maybe (Left StateInvalid) Right $ + maybeCryptoError (aeadChacha20poly1305Init secret nonce) + maybe (Left StateInvalid) Right $ + aeadSimpleDecrypt aead (associatedData kid) ciphertext (AuthTag (BA.convert tag)) diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -1,17 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | The Streamable HTTP transport, as a standalone Warp server +-- ('transportRunHttp') or a WAI application to mount in an existing one +-- ('mcpApplication'). module MCP.Server.Transport.Http ( -- * HTTP Transport HttpConfig(..) , transportRunHttp , defaultHttpConfig + , mcpApplication + + -- * Request validation (exposed for testing) + , BodyPeek(..) + , peekBody + , peekIsModern + , wantsStreamingResponse + , validateRequestHeaders + , decodeSentinel ) where -import Control.Monad (when) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) +import Control.Concurrent.MVar (newMVar, withMVar) +import Control.Concurrent.STM (atomically, check, orElse, + readTChan, readTVar, registerDelay) +import Control.Exception (uninterruptibleMask_) +import Control.Monad (forever, when) import Data.Aeson import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (isJust) import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T @@ -24,12 +46,15 @@ import MCP.Server.Handlers import MCP.Server.JsonRpc -import MCP.Server.Protocol (protocolVersion, supportedVersions) +import MCP.Server.Notifications +import MCP.Server.RequestState (StateCodec, ephemeralStateCodec) +import MCP.Server.Protocol (allVersions, modernVersions, + supportedVersions) import MCP.Server.Types -- | HTTP transport configuration following the MCP Streamable HTTP specification -- --- Note: 'HttpConfig' has no 'Show'/'Eq' instances because 'httpAuthorize' is a +-- Note: t'HttpConfig' has no 'Show'/'Eq' instances because 'httpAuthorize' is a -- function. data HttpConfig = HttpConfig { httpPort :: Int -- ^ Port to listen on @@ -42,9 +67,34 @@ -- 'Nothing' when absent / not a Bearer credential) is passed to -- @check@, which returns the caller's principal: @'Just' principal@ -- authorizes the request — the principal (e.g. a role) is placed in the - -- handler 'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects + -- handler t'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects -- the request with @401@. Validation and principal assignment are left -- entirely to the caller. + , httpAllowedOrigins :: Maybe [Text] + -- ^ Origin-validation policy (DNS-rebinding protection; the MCP + -- Streamable HTTP spec requires servers to validate the @Origin@ + -- header). @'Just' origins@ rejects any request whose @Origin@ header + -- is present but not in the list with @403@, and echoes the allowed + -- origin in CORS headers instead of @*@. Requests without an @Origin@ + -- header (non-browser clients) are always allowed. 'Nothing' disables + -- the check — only appropriate when the server is not reachable from + -- a browser (e.g. bound to localhost for CLI clients). + , httpCacheHints :: CacheHints + -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read + -- results. + , httpStateCodec :: Maybe StateCodec + -- ^ Seals the @requestState@ of multi round-trip requests (see + -- "MCP.Server.RequestState"). 'Nothing' uses a random key created + -- by 'mcpApplication', which only that application can open: a + -- deployment with several instances must configure a shared key + -- with 'MCP.Server.RequestState.aeadStateCodec'. + , httpNotifications :: Maybe NotificationSource + -- ^ When configured, @subscriptions\/listen@ (2026-07-28) is served as + -- a long-lived SSE stream delivering the change notifications the + -- client opted into, and the @listChanged@\/@subscribe@ capabilities + -- are advertised to modern clients. Legacy HTTP clients have no + -- delivery channel (the deprecated GET SSE stream is not offered), + -- so legacy @initialize@ does not advertise them. } -- | Default HTTP configuration (authentication disabled). @@ -55,52 +105,138 @@ , httpEndpoint = "/mcp" , httpVerbose = False , httpAuthorize = Nothing + , httpAllowedOrigins = Nothing + , httpCacheHints = defaultCacheHints + , httpStateCodec = Nothing + , httpNotifications = Nothing } -- | Helper for conditional logging logVerbose :: HttpConfig -> String -> IO () logVerbose config msg = when (httpVerbose config) $ hPutStrLn stderr msg +-- | Whether a notification source is configured. +httpHasNotifications :: HttpConfig -> Bool +httpHasNotifications = isJust . httpNotifications +-- | What notification delivery this HTTP server offers. +httpNotifSupport :: HttpConfig -> NotificationSupport +httpNotifSupport config = NotificationSupport + { supportsLegacyPush = False -- no legacy HTTP delivery channel + , supportsListen = httpHasNotifications config + } + +-- | Response headers for an SSE stream: no caching, and no proxy +-- buffering, so events reach the client immediately. +sseHeaders :: ResponseHeaders +sseHeaders = + [ ("Content-Type", "text/event-stream") + , ("Cache-Control", "no-cache") + , ("X-Accel-Buffering", "no") + ] + + -- | Transport-specific implementation for HTTP -transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO () +-- +-- A client closing the connection is its cancellation signal: for SSE +-- responses the handler task is cancelled once the disconnect surfaces (at +-- most one keep-alive interval later — the periodic keep-alive write is +-- what detects it). For single-JSON responses nothing is written until the +-- handler finishes, so a disconnect is only detected — and the request +-- thread only torn down — at the final write: mid-handler cancellation +-- applies to streaming requests, and clients wanting cancellable calls +-- should opt into streaming via a @progressToken@. Cancellation reaches +-- handler code as an asynchronous exception: handlers that acquire +-- resources should release them with 'Control.Exception.bracket'. +transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunHttp config serverInfo handlers = do let settings = Warp.setHost (fromString $ httpHost config) $ Warp.setPort (httpPort config) $ Warp.defaultSettings putStrLn $ "Starting MCP HTTP server on " ++ httpHost config ++ ":" ++ show (httpPort config) ++ httpEndpoint config - Warp.runSettings settings (mcpApplication config serverInfo handlers) + app <- mcpApplication config serverInfo handlers + Warp.runSettings settings app --- | WAI Application for MCP over HTTP -mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Application -mcpApplication config serverInfo handlers req respond = do +-- | The MCP endpoint as a plain WAI 'Wai.Application', for embedding into +-- an existing WAI stack (your own Warp settings, TLS, middleware, or a +-- larger router) instead of letting 'transportRunHttp' run its own server. +-- +-- When embedding, 'httpPort' and 'httpHost' are ignored — they only +-- configure the server 'transportRunHttp' starts. Everything else applies +-- as usual: requests are served only on the 'httpEndpoint' path (any other +-- path gets 404, so mount accordingly or match the path in your router), +-- Origin validation and bearer authentication run per 'httpAllowedOrigins' +-- and 'httpAuthorize', and @subscriptions\/listen@ streams work as long as +-- the surrounding stack does not buffer streaming responses. +-- +-- Building the application creates the 'httpStateCodec' default (a random +-- key) when none is configured, so build it once and serve every request +-- with the same application. +mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO Wai.Application +mcpApplication config serverInfo handlers = do + codec <- maybe ephemeralStateCodec pure (httpStateCodec config) + pure (mcpApplicationWith codec config serverInfo handlers) + +mcpApplicationWith :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> Wai.Application +mcpApplicationWith codec config serverInfo handlers req respond0 = do -- Log the request logVerbose config $ "HTTP " ++ show (Wai.requestMethod req) ++ " " ++ T.unpack (TE.decodeUtf8 $ Wai.rawPathInfo req) - -- Authenticate and obtain the caller's principal (if any) before anything - -- else. CORS preflight requests are exempt: browsers never attach - -- credentials to an OPTIONS preflight, and the preflight response is what - -- tells the browser it may send the Authorization header at all. - decision <- case httpAuthorize config of - _ | Wai.requestMethod req == "OPTIONS" - -> pure (Just Nothing) -- CORS preflight: no credentials - Nothing -> pure (Just Nothing) -- auth disabled: allowed, no principal - Just check -> fmap (fmap Just) (check (bearerToken req)) - case decision of - Nothing -> do - logVerbose config "Request rejected by authorization callback" - respond $ Wai.responseLBS - status401 - [("Content-Type", "application/json"), ("WWW-Authenticate", "Bearer")] - (encode $ object ["error" .= ("Unauthorized" :: Text)]) - Just principal -> do - let ctx = ClientContext { clientToken = bearerToken req, clientPrincipal = principal } - -- Check if this is our MCP endpoint - if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config) - then handleMcpRequest config serverInfo handlers ctx req respond - else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found" + let origin = lookup hOrigin (Wai.requestHeaders req) + -- Every response carries exactly one Access-Control-Allow-Origin header: + -- the validated request origin when a policy is configured, "*" + -- otherwise. When the value depends on the request origin, Vary: Origin + -- keeps shared caches from serving one origin's response to another. + corsHeaders = case (httpAllowedOrigins config, origin) of + (Just _, Just o) -> [("Access-Control-Allow-Origin", o), ("Vary", "Origin")] + _ -> [("Access-Control-Allow-Origin", "*")] + addCors hs = corsHeaders + ++ filter ((/= "Access-Control-Allow-Origin") . fst) hs + respond = respond0 . Wai.mapResponseHeaders addCors + -- Origin validation first (DNS-rebinding protection, a MUST in the spec). + if not (originAllowed config req) + then do + logVerbose config $ "Request rejected: disallowed Origin " ++ show origin + respond0 $ Wai.responseLBS + status403 + [("Content-Type", "application/json")] + (encode $ object ["error" .= ("Origin not allowed" :: Text)]) + else do + -- Authenticate and obtain the caller's principal (if any) before anything + -- else. CORS preflight requests are exempt: browsers never attach + -- credentials to an OPTIONS preflight, and the preflight response is what + -- tells the browser it may send the Authorization header at all. + decision <- case httpAuthorize config of + _ | Wai.requestMethod req == "OPTIONS" + -> pure (Just Nothing) -- CORS preflight: no credentials + Nothing -> pure (Just Nothing) -- auth disabled: allowed, no principal + Just authorize -> fmap (fmap Just) (authorize (bearerToken req)) + case decision of + Nothing -> do + logVerbose config "Request rejected by authorization callback" + respond $ Wai.responseLBS + status401 + [("Content-Type", "application/json"), ("WWW-Authenticate", "Bearer")] + (encode $ object ["error" .= ("Unauthorized" :: Text)]) + Just principal -> do + let ctx = anonymousContext { clientToken = bearerToken req, clientPrincipal = principal } + -- Check if this is our MCP endpoint + if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config) + then handleMcpRequest codec config serverInfo handlers ctx req respond + else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found" + +-- | Whether the request passes the configured Origin policy: with no policy +-- everything passes; with a policy, a present Origin header must be in the +-- allow-list (absent Origin means a non-browser client and always passes). +originAllowed :: HttpConfig -> Wai.Request -> Bool +originAllowed config req = case httpAllowedOrigins config of + Nothing -> True + Just allowed -> case lookup hOrigin (Wai.requestHeaders req) of + Nothing -> True + Just o -> TE.decodeUtf8With lenientDecode o `elem` allowed + -- | The bearer token presented by a request, if any: the value following -- @Authorization: Bearer @. The scheme is matched case-insensitively per -- RFC 7235, and invalid UTF-8 in the header is replaced rather than thrown. @@ -113,121 +249,344 @@ else Nothing -- | Handle MCP requests according to Streamable HTTP specification -handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -handleMcpRequest config serverInfo handlers ctx req respond = do - -- Read the POST body up front so we can identify the `initialize` request: - -- it negotiates the protocol version in its *body*, so (per the Streamable - -- HTTP spec, which scopes the MCP-Protocol-Version header to "subsequent - -- requests") it is exempt from the header check. For any other request a - -- *missing* header is accepted, while a *present but unsupported* one is - -- rejected with 400. +handleMcpRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleMcpRequest codec config serverInfo handlers ctx req respond = do + -- Read the POST body up front: the request era and header validation both + -- depend on it. A body declaring a modern protocol revision in _meta gets + -- the 2026-07-28 header validation (header/body match, Mcp-Method, + -- Mcp-Name); a legacy body keeps the relaxed pre-2026 rules, where + -- `initialize` is exempt (it negotiates in the body), a missing + -- MCP-Protocol-Version header is accepted, and a present-but-unsupported + -- one is rejected with 400. body <- if Wai.requestMethod req == "POST" then Wai.strictRequestBody req else pure "" - if extractMethod body /= Just "initialize" && not (versionHeaderSupported req) - then do - logVerbose config "Request rejected: unsupported MCP-Protocol-Version header" - respond $ Wai.responseLBS - status400 - [("Content-Type", "application/json")] - (encode $ object ["error" .= ("Unsupported protocol version. Supported versions: " <> T.intercalate ", " supportedVersions)]) - else - case Wai.requestMethod req of - -- GET requests for endpoint discovery - "GET" -> do - let discoveryResponse = object - [ "name" .= serverName serverInfo - , "version" .= serverVersion serverInfo - , "description" .= serverInstructions serverInfo - , "protocolVersion" .= protocolVersion - , "capabilities" .= object - [ "tools" .= object [] - , "prompts" .= object [] - , "resources" .= object [] - ] - ] - logVerbose config $ "Sending server discovery response: " ++ show discoveryResponse - respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] - (encode discoveryResponse) + let peek = peekBody body + modern = peekIsModern peek + case Wai.requestMethod req of + -- POST requests for JSON-RPC messages + "POST" -> + case validateRequestHeaders req peek of + Just err -> do + logVerbose config $ "Request rejected: " ++ T.unpack (errorMessage err) + respond $ Wai.responseLBS + status400 + [("Content-Type", "application/json")] + (encode $ makeErrorResponse (peekId peek) err) + Nothing + -- subscriptions/listen is transport-level: the response is a + -- long-lived SSE stream, not a single JSON object + | peekMethod peek == Just "subscriptions/listen" + , Just src <- httpNotifications config + -> handleSubscriptionsListen config src body respond + -- Requests that opted into request-scoped notifications get an + -- SSE response stream carrying them before the final response — + -- but only for dispatchable request methods, so unknown methods + -- keep their 404 and notification bodies keep their 202 + | wantsStreamingResponse peek + -> handleStreamingRequest codec config serverInfo handlers ctx body respond + | otherwise -> do + logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body) + handleJsonRpcRequest codec config serverInfo handlers ctx modern body respond - -- POST requests for JSON-RPC messages - "POST" -> do - logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body) - handleJsonRpcRequest config serverInfo handlers ctx body respond + -- OPTIONS for CORS preflight + "OPTIONS" -> respond $ Wai.responseLBS + status200 + [ ("Access-Control-Allow-Methods", "POST, OPTIONS") + , ("Access-Control-Allow-Headers", "Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name") + ] + "" - -- OPTIONS for CORS preflight - "OPTIONS" -> respond $ Wai.responseLBS - status200 - [ ("Access-Control-Allow-Origin", "*") - , ("Access-Control-Allow-Methods", "GET, POST, OPTIONS") - , ("Access-Control-Allow-Headers", "Content-Type, Authorization, MCP-Protocol-Version") - ] - "" + -- Everything else, including GET: the MCP endpoint only speaks + -- JSON-RPC over POST (this library does not offer server-initiated + -- SSE streams, and revision 2026-07-28 requires 405 for GET). + _ -> respond $ Wai.responseLBS + status405 + [("Content-Type", "text/plain"), ("Allow", "POST, OPTIONS")] + "Method Not Allowed" - -- Unsupported methods - _ -> respond $ Wai.responseLBS - status405 - [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")] - "Method Not Allowed" +-- | The parts of a JSON-RPC body that header validation and response-mode +-- selection need. +data BodyPeek = BodyPeek + { peekMethod :: Maybe Text + , peekMetaVersion :: Maybe Text + , peekName :: Maybe Text -- ^ params.name or params.uri + , peekId :: RequestId + , peekHasId :: Bool + -- ^ Whether an @id@ member is present at all ('peekId' alone + -- conflates an absent id — a notification — with an explicit null) + , peekWantsStream :: Bool + -- ^ The request opted into request-scoped notifications + -- (@_meta.progressToken@ or @_meta.\"io.modelcontextprotocol/logLevel\"@), + -- so the response must be an SSE stream that can carry them + } --- | True unless the request carries a *present but unsupported* --- MCP-Protocol-Version header. A missing header is treated as acceptable, since --- the spec allows the server to assume a default protocol version in that case. -versionHeaderSupported :: Wai.Request -> Bool -versionHeaderSupported req = - case lookup "MCP-Protocol-Version" (Wai.requestHeaders req) of - Nothing -> True - Just hv -> TE.decodeUtf8 hv `elem` supportedVersions +-- | Methods that run user handlers and may therefore emit request-scoped +-- notifications. Only these upgrade to an SSE response stream: everything +-- else keeps the JSON path so pre-dispatch outcomes retain their +-- spec-mandated HTTP statuses (404 for unknown methods, 202 for +-- notifications) — 'Wai.responseStream' would commit @200@ before dispatch +-- could veto it. +streamableMethods :: [Text] +streamableMethods = + [ "tools/call", "tools/list" + , "prompts/get", "prompts/list" + , "resources/read", "resources/list", "resources/templates/list" + , "completion/complete" + ] --- | Peek at a JSON-RPC message body to read its @method@ (if present). -extractMethod :: BSL.ByteString -> Maybe Text -extractMethod body = case decode body of - Just (Object o) -> case KM.lookup "method" o of - Just (String m) -> Just m - _ -> Nothing - _ -> Nothing +-- | Whether this request is answered with an SSE response stream. +wantsStreamingResponse :: BodyPeek -> Bool +wantsStreamingResponse peek = + peekWantsStream peek + && peekHasId peek + && maybe False (`elem` streamableMethods) (peekMethod peek) +-- | Whether the body declares a modern (2026-07-28+) request. +peekIsModern :: BodyPeek -> Bool +peekIsModern peek = + peekMetaVersion peek /= Nothing || peekMethod peek == Just "server/discover" + +-- | Extract the t'BodyPeek' fields from a raw request body. A body that is +-- not a JSON object yields a peek with every field empty. +peekBody :: BSL.ByteString -> BodyPeek +peekBody body = case decode body of + Just (Object o) -> BodyPeek + { peekMethod = case KM.lookup "method" o of + Just (String m) -> Just m + _ -> Nothing + , peekMetaVersion = metaProtocolVersion (KM.lookup "params" o) + , peekName = case KM.lookup "params" o of + Just (Object p) -> case (KM.lookup "name" p, KM.lookup "uri" p) of + (Just (String n), _) -> Just n + (_, Just (String u)) -> Just u + _ -> Nothing + _ -> Nothing + , peekId = case KM.lookup "id" o of + Just v -> either (const RequestIdNull) id (parseEither parseJSON v) + Nothing -> RequestIdNull + , peekHasId = KM.member "id" o + , peekWantsStream = case KM.lookup "params" o of + Just (Object p) -> case KM.lookup "_meta" p of + Just (Object m) -> + KM.member "progressToken" m + || KM.member "io.modelcontextprotocol/logLevel" m + _ -> False + _ -> False + } + _ -> BodyPeek Nothing Nothing Nothing RequestIdNull False False + +-- | Validate the request-metadata headers against the body. 'Nothing' means +-- the request may proceed; @'Just' err@ is answered with 400 and the given +-- JSON-RPC error. +-- +-- Modern requests (body declares a protocol revision in @_meta@) follow the +-- 2026-07-28 rules: the MCP-Protocol-Version header must match the body's +-- declared revision, Mcp-Method must match the body method, and Mcp-Name +-- must match @params.name@/@params.uri@ for the three named methods +-- (@HeaderMismatch@, -32020); an undeclared revision yields +-- @UnsupportedProtocolVersionError@ (-32022). +-- +-- Legacy requests keep the relaxed pre-2026 rules: only a +-- present-but-unsupported MCP-Protocol-Version header is rejected, and +-- @initialize@ is exempt entirely. +validateRequestHeaders :: Wai.Request -> BodyPeek -> Maybe JsonRpcError +validateRequestHeaders req peek = case peekMetaVersion peek of + Just v + | v `notElem` modernVersions -> Just (unsupportedVersionError v) + | headerText "MCP-Protocol-Version" /= Just v -> + Just $ headerMismatch $ "MCP-Protocol-Version header " + <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "MCP-Protocol-Version") + <> " and does not match body value '" <> v <> "'" + | headerText "Mcp-Method" /= peekMethod peek -> + Just $ headerMismatch $ "Mcp-Method header " + <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "Mcp-Method") + <> " and does not match body method" + | needsName + , (decodeSentinel <$> headerText "Mcp-Name") /= peekName peek -> + Just $ headerMismatch $ "Mcp-Name header " + <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "Mcp-Name") + <> " and does not match the body name/uri" + | otherwise -> Nothing + Nothing + | peekMethod peek /= Just "initialize" + , Just hv <- headerText "MCP-Protocol-Version" + , hv `notElem` supportedVersions ++ modernVersions -> + Just $ JsonRpcError + { errorCode = -32600 + , errorMessage = "Unsupported protocol version. Supported versions: " + <> T.intercalate ", " allVersions + , errorData = Nothing + } + | otherwise -> Nothing + where + headerText name = + TE.decodeUtf8With lenientDecode <$> lookup name (Wai.requestHeaders req) + needsName = peekMethod peek `elem` map Just ["tools/call", "resources/read", "prompts/get"] + headerMismatch msg = JsonRpcError + { errorCode = -32020 + , errorMessage = "Header mismatch: " <> msg + , errorData = Nothing + } + +-- | Decode the @=?base64?...?=@ sentinel encoding the 2026-07-28 transport +-- uses for header values that cannot be represented in plain ASCII. Values +-- not wrapped in the sentinel (or with invalid base64) pass through as-is. +decodeSentinel :: Text -> Text +decodeSentinel t + | Just inner <- T.stripPrefix "=?base64?" t >>= T.stripSuffix "?=" = + case B64.decode (TE.encodeUtf8 inner) of + Right bs -> TE.decodeUtf8With lenientDecode bs + Left _ -> t + | otherwise = t + +-- | Serve a subscriptions/listen request (2026-07-28): a long-lived SSE +-- stream that first acknowledges the subscription and then delivers exactly +-- the notification types the client opted into, tagged with the +-- subscription id. Closing the stream is the client's cancellation signal; +-- periodic SSE comments keep intermediaries from timing the stream out. +handleSubscriptionsListen :: HttpConfig -> NotificationSource -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleSubscriptionsListen config src body respond = + case eitherDecode body :: Either String JsonRpcRequest of + Left err -> do + hPutStrLn stderr $ "subscriptions/listen parse error: " ++ err + respond $ Wai.responseLBS + status400 + [("Content-Type", "application/json")] + (encode $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32600 + , errorMessage = "Invalid Request" + , errorData = Nothing + }) + Right req -> do + let subId = requestId req + notifFilter = parseNotificationFilter (requestParams req) + logVerbose config $ "Opening subscription stream " ++ show subId + respond $ Wai.responseStream status200 sseHeaders $ \write flush -> do + chan <- atomically $ subscribeEvents src + let sendJson v = do + write $ B.lazyByteString $ "data: " <> encode v <> "\n\n" + flush + sendJson $ toJSON $ acknowledgedNotification subId notifFilter + forever $ do + keepAlive <- registerDelay 25000000 -- 25s + next <- atomically $ + (Just <$> readTChan chan) + `orElse` (readTVar keepAlive >>= check >> pure Nothing) + case next of + Just event + | filterAccepts notifFilter event -> + sendJson $ toJSON $ eventNotification subId event + | otherwise -> pure () + Nothing -> do + write $ B.byteString ": keep-alive\n\n" + flush + +-- | Serve a request that opted into request-scoped notifications: the +-- response is an SSE stream on which progress and client-log notifications +-- flow, followed by the final JSON-RPC response. +-- +-- The handler runs in its own task, raced against a keep-alive writer that +-- doubles as the disconnect detector: when the client closes the stream the +-- next keep-alive write throws, the race cancels the handler task, and +-- nothing further is produced for the request. +handleStreamingRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleStreamingRequest codec config serverInfo handlers ctx body respond = + respond $ Wai.responseStream status200 sseHeaders $ \write flush -> do + -- One writer at a time, and a cancellation arriving mid-write cannot + -- split an event in half + streamLock <- newMVar () + let sendChunk b = withMVar streamLock $ \_ -> uninterruptibleMask_ $ do + write b + flush + sendEvent v = sendChunk $ B.lazyByteString $ "data: " <> encode v <> "\n\n" + emit n = sendEvent (toJSON (n :: JsonRpcNotification)) + case eitherDecode body of + Left err -> do + hPutStrLn stderr $ "JSON parse error: " ++ err + sendEvent $ toJSON $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32700, errorMessage = "Parse error", errorData = Nothing } + Right jsonValue -> case parseJsonRpcMessage jsonValue of + Left err -> do + hPutStrLn stderr $ "JSON-RPC parse error: " ++ err + sendEvent $ toJSON $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32600, errorMessage = "Invalid Request", errorData = Nothing } + Right message -> do + logVerbose config $ "Processing streaming HTTP message: " ++ show (getMessageSummary message) + -- 5s: short enough that an abandoned handler is cancelled + -- promptly (a write to a closed connection is what surfaces the + -- disconnect), long enough to stay negligible on the wire + let keepAlive :: IO () + keepAlive = forever $ do + threadDelay 5000000 + sendChunk $ B.byteString ": keep-alive\n\n" + outcome <- race + (handleMcpMessage serverInfo (httpCacheHints config) codec + (httpNotifSupport config) emit handlers ctx message) + keepAlive + case outcome of + Left (Just responseMsg) -> sendEvent (encodeJsonRpcMessage responseMsg) + Left Nothing -> pure () + Right () -> pure () + -- | Handle JSON-RPC request from HTTP body -handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -handleJsonRpcRequest config serverInfo handlers ctx body respond = do +handleJsonRpcRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleJsonRpcRequest codec config serverInfo handlers ctx modern body respond = do case eitherDecode body of Left err -> do hPutStrLn stderr $ "JSON parse error: " ++ err respond $ Wai.responseLBS status400 [("Content-Type", "application/json")] - (encode $ object ["error" .= ("Invalid JSON" :: Text)]) + (encode $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32700 + , errorMessage = "Parse error" + , errorData = Nothing + }) - Right jsonValue -> handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond + Right jsonValue -> handleSingleJsonRpc codec config serverInfo handlers ctx modern jsonValue respond -- | Handle a single JSON-RPC message -handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond = do +handleSingleJsonRpc :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleSingleJsonRpc codec config serverInfo handlers ctx modern jsonValue respond = do case parseJsonRpcMessage jsonValue of Left err -> do hPutStrLn stderr $ "JSON-RPC parse error: " ++ err respond $ Wai.responseLBS status400 [("Content-Type", "application/json")] - (encode $ object ["error" .= ("Invalid JSON-RPC" :: Text)]) + (encode $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32600 + , errorMessage = "Invalid Request" + , errorData = Nothing + }) Right message -> do logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message) - maybeResponse <- handleMcpMessage serverInfo handlers ctx message + -- Single-JSON responses have no channel for request-scoped + -- notifications; requests that want them take the streaming path. + maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config) codec + (httpNotifSupport config) (\_ -> pure ()) handlers ctx message case maybeResponse of Just responseMsg -> do let responseJson = encode $ encodeJsonRpcMessage responseMsg logVerbose config $ "Sending HTTP response for: " ++ show (getMessageSummary message) respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] + (statusForResponse modern responseMsg) + [("Content-Type", "application/json")] responseJson Nothing -> do logVerbose config $ "No response needed for: " ++ show (getMessageSummary message) - -- For notifications, return 200 with empty JSON object (per MCP spec) - respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] - "{}" + -- Accepted notification: 202 with no body, per the Streamable HTTP spec + respond $ Wai.responseLBS status202 [] "" + +-- | The HTTP status for a JSON-RPC response. Modern (2026-07-28) requests +-- map protocol-level failures onto HTTP statuses — 404 for an unknown RPC +-- method, 400 for an unsupported protocol version — so era-probing clients +-- can distinguish them; legacy requests always get 200 as before. +statusForResponse :: Bool -> JsonRpcMessage -> Status +statusForResponse True (JsonRpcMessageResponse r) = case responseError r of + Just e | errorCode e == -32601 -> status404 + | errorCode e == -32022 -> status400 + _ -> status200 +statusForResponse _ _ = status200 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 @@ -1,54 +1,288 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | The stdio transport: newline-delimited JSON-RPC on stdin and stdout, +-- with logging on stderr. module MCP.Server.Transport.Stdio ( -- * STDIO Transport transportRunStdio + , transportRunStdioWithConfig + , StdioConfig(..) + , defaultStdioConfig ) where -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.Async (Async, async, cancel, waitCatch) +import Control.Concurrent.MVar (modifyMVar_, newEmptyMVar, newMVar, + putMVar, readMVar, takeMVar, + withMVar) +import Control.Concurrent.STM (atomically, readTChan) +import Control.Exception (finally, uninterruptibleMask_) +import Control.Monad (forever, unless, when) import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy as BSL +import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO -import System.IO (hFlush, stderr, stdout) +import System.IO (hFlush, hIsEOF, hSetEncoding, stderr, + stdin, stdout, utf8) import MCP.Server.Handlers import MCP.Server.JsonRpc +import MCP.Server.Notifications +import MCP.Server.Protocol (modernVersions) +import MCP.Server.RequestState (StateCodec, ephemeralStateCodec) import MCP.Server.Types +-- | STDIO transport configuration +data StdioConfig = StdioConfig + { stdioVerbose :: Bool + -- ^ When 'True', raw request bodies are logged to stderr. The default + -- ('False') logs only message summaries (method and id): tool arguments + -- may carry sensitive data that does not belong in logs. + , stdioCacheHints :: CacheHints + -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read + -- results. + , stdioStateCodec :: Maybe StateCodec + -- ^ Seals the @requestState@ of multi round-trip requests (see + -- "MCP.Server.RequestState"). 'Nothing' uses a random key created when + -- the transport starts, which is all a single stdio process needs. + , stdioNotifications :: Maybe NotificationSource + -- ^ When configured, change notifications are delivered: modern clients + -- via @subscriptions\/listen@, legacy clients as spontaneous + -- notifications after @initialize@ — and the corresponding + -- @listChanged@\/@subscribe@ capabilities are advertised. + } --- | Transport-specific implementation for STDIO -import System.IO (hSetEncoding, utf8) +-- | Default STDIO configuration: summaries only, no raw bodies, no caching, +-- no notifications. +defaultStdioConfig :: StdioConfig +defaultStdioConfig = StdioConfig + { stdioVerbose = False + , stdioCacheHints = defaultCacheHints + , stdioStateCodec = Nothing + , stdioNotifications = Nothing + } -transportRunStdio :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> m () -transportRunStdio serverInfo handlers = do +-- | Run the STDIO transport with the default configuration. +transportRunStdio :: McpServerInfo -> McpServerHandlers -> IO () +transportRunStdio = transportRunStdioWithConfig defaultStdioConfig + +-- | Run the STDIO transport with the given configuration. +-- +-- Each request is served in its own task, so a @notifications/cancelled@ +-- naming its id can interrupt it mid-flight (after which nothing further is +-- written for that id). Cancellation reaches handler code as an +-- asynchronous exception: handlers that acquire resources should release +-- them with 'Control.Exception.bracket'. +-- +-- This also means requests run /concurrently/ (before 0.2.0.1 the stdio +-- transport processed them strictly sequentially): handlers touching +-- shared mutable state must synchronize, as was already required of +-- handlers used with the HTTP transport. +transportRunStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO () +transportRunStdioWithConfig config serverInfo handlers = do -- Ensure UTF-8 encoding for all handles - liftIO $ do - hSetEncoding stderr utf8 - hSetEncoding stdout utf8 - loop - where + hSetEncoding stderr utf8 + hSetEncoding stdout utf8 + + codec <- maybe ephemeralStateCodec pure (stdioStateCodec config) + + -- Subscription threads, request tasks and the main loop share stdout: + -- one line at a time. + writeLock <- newMVar () + -- Active subscriptions_listen streams, by their request id + subsVar <- newMVar ([] :: [(RequestId, ThreadId)]) + -- In-flight request tasks, by request id (cancellable) + inflightVar <- newMVar ([] :: [(RequestId, Async ())]) + -- Whether a legacy client has completed initialize (gates legacy pushes) + legacyReady <- newIORef False + + let logLine = TIO.hPutStrLn stderr + logVerbose msg = when (stdioVerbose config) $ logLine msg + + -- Writes are uninterruptible so a cancellation arriving mid-write + -- cannot corrupt the message channel with a half line + sendRaw bytes = withMVar writeLock $ \_ -> uninterruptibleMask_ $ do + TIO.putStrLn $ TE.decodeUtf8 $ BSL.toStrict bytes + hFlush stdout + sendMessage msg = sendRaw $ encode $ encodeJsonRpcMessage msg + sendResponse resp = sendRaw $ encode $ toJSON (resp :: JsonRpcResponse) + sendNotification notif = sendRaw $ encode $ toJSON (notif :: JsonRpcNotification) + + notifSupport = case stdioNotifications config of + Nothing -> noNotificationSupport + Just _ -> NotificationSupport { supportsLegacyPush = True, supportsListen = True } + + -- Legacy delivery: push untagged notifications to a client that completed + -- the initialize handshake (which is when the capability was advertised). + case stdioNotifications config of + Nothing -> pure () + Just src -> do + chan <- atomically $ subscribeEvents src + _ <- forkIO $ forever $ do + event <- atomically $ readTChan chan + ready <- readIORef legacyReady + when ready $ sendNotification $ legacyEventNotification event + pure () + + let + -- Open a subscriptions/listen stream: acknowledge, then deliver + -- matching events tagged with the subscription id until cancelled. + -- A listen reusing an already-open subscription id replaces the old + -- stream (otherwise the shadowed writer would leak until EOF). + openSubscription src req = do + let subId = requestId req + notifFilter = parseNotificationFilter (requestParams req) + _ <- cancelSubscription subId + chan <- atomically $ subscribeEvents src + sendNotification $ acknowledgedNotification subId notifFilter + tid <- forkIO $ forever $ do + event <- atomically $ readTChan chan + when (filterAccepts notifFilter event) $ + sendNotification $ eventNotification subId event + modifyMVar_ subsVar (pure . ((subId, tid) :)) + logLine $ "Opened subscription " <> T.pack (show subId) + + cancelSubscription cancelledId = do + subs <- readMVar subsVar + case lookup cancelledId subs of + Nothing -> pure False + Just tid -> do + killThread tid + modifyMVar_ subsVar (pure . filter ((/= cancelledId) . fst)) + logLine $ "Cancelled subscription " <> T.pack (show cancelledId) + pure True + + -- Server-side teardown at EOF: graceful closure for every open stream + closeAllSubscriptions = do + subs <- readMVar subsVar + mapM_ (\(subId, tid) -> do + killThread tid + sendResponse $ closureResponse serverInfo subId) + subs + + -- Cancel an in-flight request task. 'cancel' waits for the task to + -- finish, so once this returns nothing further is written for that id. + cancelInflight cancelledId = do + inflight <- readMVar inflightVar + case lookup cancelledId inflight of + Nothing -> pure False + Just task -> do + cancel task + logLine $ "Cancelled request " <> T.pack (show cancelledId) + pure True + + dispatchMessage message = do + -- Request-scoped notifications (progress, client logs) share the + -- locked stdout channel, interleaved before the response + response <- handleMcpMessage serverInfo (stdioCacheHints config) codec notifSupport sendNotification handlers anonymousContext message + case response of + Just responseMsg -> do + logLine $ "Sending response for: " <> T.pack (show (getMessageSummary message)) + sendMessage responseMsg + Nothing -> + logLine $ "No response needed for: " <> T.pack (show (getMessageSummary message)) + + handleParsed message = case message of + -- subscriptions/listen is transport-level: the stream outlives the + -- request. Only intercept when a source is configured and the + -- declared revision (if any) is one we implement — otherwise fall + -- through for the ordinary -32601 / -32022 answer. + JsonRpcMessageRequest req + | requestMethod req == "subscriptions/listen" + , Just src <- stdioNotifications config + , maybe True (`elem` modernVersions) (metaProtocolVersion (requestParams req)) + -> openSubscription src req + + -- Every other request runs in its own task so a later + -- notifications/cancelled can interrupt it while the read loop keeps + -- serving. The task is registered before its body starts (the gate) + -- so cancellation can never race registration; it deregisters itself + -- on any exit, including cancellation. + | otherwise -> do + let rid = requestId req + gate <- newEmptyMVar + task <- async $ do + takeMVar gate + dispatchMessage message + `finally` modifyMVar_ inflightVar (pure . filter ((/= rid) . fst)) + modifyMVar_ inflightVar (pure . ((rid, task) :)) + putMVar gate () + + -- notifications/cancelled tears down the referenced subscription or + -- in-flight request (no response either way, per the cancellation + -- rules; unknown ids are ignored as the spec requires) + JsonRpcMessageNotification notif + | notificationMethod notif == "notifications/cancelled" + , Just cancelledId <- cancelledRequestId (notificationParams notif) + -> do + wasSub <- cancelSubscription cancelledId + unless wasSub $ do + wasInflight <- cancelInflight cancelledId + unless wasInflight $ + logLine $ "Ignoring cancellation for unknown request " <> T.pack (show cancelledId) + + _ -> do + -- The client's initialized notification is the legacy ready signal: + -- the lifecycle forbids server notifications before it arrives, and + -- it only arrives after the client accepted a successful handshake + -- response (so failed initializes never enable pushes). + case message of + JsonRpcMessageNotification n + | notificationMethod n == "notifications/initialized" -> + writeIORef legacyReady True + _ -> pure () + dispatchMessage message + loop = do - input <- liftIO TIO.getLine - when (not $ T.null $ T.strip input) $ do - -- Use TIO.hPutStrLn for UTF-8 output - liftIO $ TIO.hPutStrLn stderr $ "Received request: " <> input - case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of - Left err -> liftIO $ TIO.hPutStrLn stderr $ "Parse error: " <> T.pack err - Right jsonValue -> do - case parseJsonRpcMessage jsonValue of - Left err -> liftIO $ TIO.hPutStrLn stderr $ "JSON-RPC parse error: " <> T.pack err - Right message -> do - liftIO $ TIO.hPutStrLn stderr $ "Processing message: " <> T.pack (show (getMessageSummary message)) - response <- handleMcpMessage serverInfo handlers (ClientContext Nothing Nothing) message - case response of - Just responseMsg -> do - liftIO $ TIO.hPutStrLn stderr $ "Sending response for: " <> T.pack (show (getMessageSummary message)) - let responseText = TE.decodeUtf8 $ BSL.toStrict $ encode $ encodeJsonRpcMessage responseMsg - liftIO $ TIO.putStrLn responseText - liftIO $ hFlush stdout - Nothing -> liftIO $ TIO.hPutStrLn stderr $ "No response needed for: " <> T.pack (show (getMessageSummary message)) - loop + 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_ (waitCatch . snd) inflight + closeAllSubscriptions + logLine "stdin closed - shutting down" + else do + input <- TIO.getLine + unless (T.null $ T.strip input) $ do + logVerbose $ "Received request: " <> input + case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of + Left err -> do + logLine $ "Parse error: " <> T.pack err + sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32700 + , errorMessage = "Parse error" + , errorData = Nothing + } + Right jsonValue -> + case parseJsonRpcMessage jsonValue of + Left err -> do + logLine $ "JSON-RPC parse error: " <> T.pack err + sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32600 + , errorMessage = "Invalid Request" + , errorData = Nothing + } + Right message -> do + logLine $ "Processing message: " <> T.pack (show (getMessageSummary message)) + handleParsed message + loop + + loop + +-- | The request id referenced by a notifications/cancelled notification. +cancelledRequestId :: Maybe Value -> Maybe RequestId +cancelledRequestId params = do + Object o <- params + v <- KM.lookup "requestId" o + either (const Nothing) Just (parseEither parseJSON v) diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -1,45 +1,100 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} +-- | The library's core types: the content, results, definitions and JSON +-- Schemas that handlers produce, the handler signatures themselves, and the +-- server information and capabilities advertised to clients. module MCP.Server.Types ( -- * Content Types Content(..) , ContentImageData(..) - , ContentResourceData(..) + , ContentAudioData(..) , ResourceContent(..) - -- * URI Utilities + -- * Metadata Types + , Annotations(..) + , defaultAnnotations + , ToolAnnotations(..) + , defaultToolAnnotations + , Icon(..) + , icon + , LogLevel(..) + + -- * Handler Result Types + , ToolResult(..) + , toolResult + , toolError + , ToToolResult(..) + , ToolOutput(..) + , PromptResult(..) + , ToPromptResult(..) + , PromptMessage(..) + , MessageRole(..) + + -- * URI Utilities , parseURI , URI -- * Error Types , Error(..) + -- * Schema Types + , Schema(..) + , SchemaType(..) + , schema + , describedSchema + -- * Definition Types , PromptDefinition(..) + , mkPromptDefinition , ResourceDefinition(..) + , mkResourceDefinition + , ResourceTemplateDefinition(..) + , mkResourceTemplateDefinition , ToolDefinition(..) + , mkToolDefinition , ArgumentDefinition(..) - , InputSchemaDefinition(..) - , InputSchemaDefinitionProperty(..) + -- * Completion Types + , CompletionRef(..) + , CompletionResult(..) + , completionResult + -- * Server Types , McpServerInfo(..) , McpServerHandlers(..) + , noHandlers , ClientContext(..) + , anonymousContext + , CacheHints(..) + , defaultCacheHints + , NotificationSupport(..) + , noNotificationSupport , ServerCapabilities(..) , PromptCapabilities(..) , ResourceCapabilities(..) , ToolCapabilities(..) + , CompletionCapabilities(..) , LoggingCapabilities(..) - -- * Request/Response Types + -- * Asking the client for input + , Outcome(..) + , InputRequest(..) + , InputResponse(..) + , ElicitAction(..) + , clientSupportsInput + + -- * Handler Types , PromptListHandler , PromptGetHandler , ResourceListHandler , ResourceReadHandler + , ResourceTemplateListHandler , ToolListHandler , ToolCallHandler + , CompletionHandler -- * Basic Types , PromptName @@ -50,23 +105,37 @@ import Data.Aeson import Data.Aeson.Key (fromText) -import Data.Aeson.Types (Parser) -import Data.Maybe (catMaybes) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair, Parser) +import Data.Map (Map) +import Data.Maybe (catMaybes, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift) import Network.URI (URI, parseURI) +-- | The name of a prompt, as in @prompts\/get@. type PromptName = Text +-- | The name of a tool, as in @tools\/call@. type ToolName = Text +-- | The name of a prompt or tool argument. type ArgumentName = Text +-- | A prompt argument's value; prompt arguments are always strings. type ArgumentValue = Text -- | Content that can be returned by prompts, resources, and tools data Content = ContentText Text | ContentImage ContentImageData - | ContentResource ContentResourceData + | ContentAudio ContentAudioData + | ContentEmbeddedResource ResourceContent + -- ^ A resource embedded into the result, carrying its full contents + | ContentResourceLink ResourceDefinition + -- ^ A reference to a resource the client can read separately + | ContentAnnotated Annotations Content + -- ^ A content block carrying t'Annotations'; the annotations are merged + -- into the inner block's JSON object. Do not nest. deriving (Show, Eq, Generic) instance ToJSON Content where @@ -79,38 +148,85 @@ , "data" .= contentImageData img , "mimeType" .= contentImageMimeType img ] - toJSON (ContentResource res) = object + toJSON (ContentAudio audio) = object + [ "type" .= ("audio" :: Text) + , "data" .= contentAudioData audio + , "mimeType" .= contentAudioMimeType audio + ] + toJSON (ContentEmbeddedResource res) = object [ "type" .= ("resource" :: Text) - , "resource" .= object - [ "uri" .= contentResourceUri res - , "mimeType" .= contentResourceMimeType res - ] + , "resource" .= res ] + toJSON (ContentResourceLink def) = + case toJSON def of + Object o -> Object (KM.insert "type" (String "resource_link") o) + other -> other + toJSON (ContentAnnotated anns inner) = + case toJSON inner of + Object o -> Object (KM.insert "annotations" (toJSON anns) o) + other -> other instance FromJSON Content where parseJSON = withObject "Content" $ \o -> do - contentType <- o .: "type" :: Parser Text - case contentType of - "text" -> ContentText <$> o .: "text" - "image" -> do - imgData <- o .: "data" - mimeType <- o .: "mimeType" - return $ ContentImage $ ContentImageData imgData mimeType - "resource" -> do - res <- o .: "resource" - uri <- res .: "uri" - mimeType <- res .:? "mimeType" - return $ ContentResource $ ContentResourceData uri mimeType - _ -> fail $ "Unknown content type: " ++ T.unpack contentType + inner <- parseInner o + case KM.lookup "annotations" o of + Just anns -> ContentAnnotated <$> parseJSON anns <*> pure inner + Nothing -> pure inner + where + parseInner o = do + contentType <- o .: "type" :: Parser Text + case contentType of + "text" -> ContentText <$> o .: "text" + "image" -> do + imgData <- o .: "data" + mimeType <- o .: "mimeType" + return $ ContentImage $ ContentImageData imgData mimeType + "audio" -> do + audioData <- o .: "data" + mimeType <- o .: "mimeType" + return $ ContentAudio $ ContentAudioData audioData mimeType + "resource" -> ContentEmbeddedResource <$> o .: "resource" + "resource_link" -> ContentResourceLink <$> parseJSON (Object o) + _ -> fail $ "Unknown content type: " ++ T.unpack contentType +-- | Optional hints on content blocks: who the content is for, how important +-- it is, and when it last changed (2025-03-26+). +data Annotations = Annotations + { annotationsAudience :: [MessageRole] -- ^ Intended audience(s); omitted when empty + , annotationsPriority :: Maybe Double -- ^ 0.0 (optional) … 1.0 (most important) + , annotationsLastModified :: Maybe Text -- ^ ISO 8601 timestamp + } deriving (Show, Eq, Generic) + +-- | No annotations set; record-update the ones you need. +defaultAnnotations :: Annotations +defaultAnnotations = Annotations + { annotationsAudience = [] + , annotationsPriority = Nothing + , annotationsLastModified = Nothing + } + +instance ToJSON Annotations where + toJSON anns = object $ + (if null (annotationsAudience anns) then [] else ["audience" .= annotationsAudience anns]) + ++ maybe [] (\p -> ["priority" .= p]) (annotationsPriority anns) + ++ maybe [] (\lm -> ["lastModified" .= lm]) (annotationsLastModified anns) + +instance FromJSON Annotations where + parseJSON = withObject "Annotations" $ \o -> Annotations + <$> o .:? "audience" .!= [] + <*> o .:? "priority" + <*> o .:? "lastModified" + +-- | The payload of an image content block. data ContentImageData = ContentImageData - { contentImageData :: Text + { contentImageData :: Text -- ^ base64-encoded image data , contentImageMimeType :: Text } deriving (Show, Eq, Generic) -data ContentResourceData = ContentResourceData - { contentResourceUri :: URI - , contentResourceMimeType :: Maybe Text +-- | The payload of an audio content block. +data ContentAudioData = ContentAudioData + { contentAudioData :: Text -- ^ base64-encoded audio data + , contentAudioMimeType :: Text } deriving (Show, Eq, Generic) -- | Resource content compliant with MCP specification @@ -154,6 +270,227 @@ (Nothing, Just blob) -> return $ ResourceBlob uri mimeType blob _ -> fail "ResourceContent must have either 'text' or 'blob' field" +-- | Message role for prompts +data MessageRole = RoleUser | RoleAssistant + deriving (Show, Eq, Generic) + +instance ToJSON MessageRole where + toJSON RoleUser = "user" + toJSON RoleAssistant = "assistant" + +instance FromJSON MessageRole where + parseJSON = withText "MessageRole" $ \t -> case t of + "user" -> pure RoleUser + "assistant" -> pure RoleAssistant + _ -> fail $ "Unknown role: " ++ T.unpack t + +-- | Behavioral hints on a tool (2025-03-26+): clients use these for +-- permission UX (e.g. auto-approving read-only tools). All hints are +-- advisory and default to unset. +data ToolAnnotations = ToolAnnotations + { toolAnnotationsTitle :: Maybe Text + , toolReadOnlyHint :: Maybe Bool -- ^ The tool does not modify its environment + , toolDestructiveHint :: Maybe Bool -- ^ The tool may perform destructive updates + , toolIdempotentHint :: Maybe Bool -- ^ Repeated calls with the same arguments have no additional effect + , toolOpenWorldHint :: Maybe Bool -- ^ The tool interacts with an open world of external entities + } deriving (Show, Eq, Generic, Lift) + +-- | No hints set; record-update the ones you need. +defaultToolAnnotations :: ToolAnnotations +defaultToolAnnotations = ToolAnnotations + { toolAnnotationsTitle = Nothing + , toolReadOnlyHint = Nothing + , toolDestructiveHint = Nothing + , toolIdempotentHint = Nothing + , toolOpenWorldHint = Nothing + } + +instance ToJSON ToolAnnotations where + toJSON anns = object $ concat + [ maybe [] (\t -> ["title" .= t]) (toolAnnotationsTitle anns) + , maybe [] (\b -> ["readOnlyHint" .= b]) (toolReadOnlyHint anns) + , maybe [] (\b -> ["destructiveHint" .= b]) (toolDestructiveHint anns) + , maybe [] (\b -> ["idempotentHint" .= b]) (toolIdempotentHint anns) + , maybe [] (\b -> ["openWorldHint" .= b]) (toolOpenWorldHint anns) + ] + +-- | An icon a client may display for a tool, prompt or resource +-- (2025-11-25+). +data Icon = Icon + { iconSrc :: Text -- ^ URI of the icon + , iconMimeType :: Maybe Text + , iconSizes :: [Text] -- ^ e.g. @[\"48x48\"]@; omitted when empty + } deriving (Show, Eq, Generic, Lift) + +-- | An icon with just a source URI. +icon :: Text -> Icon +icon src = Icon { iconSrc = src, iconMimeType = Nothing, iconSizes = [] } + +-- | RFC 5424 log severities, least to most severe; the 'Ord' instance +-- follows severity, so @level >= threshold@ is the filtering test. +data LogLevel + = LogDebug + | LogInfo + | LogNotice + | LogWarning + | LogError + | LogCritical + | LogAlert + | LogEmergency + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +logLevelText :: LogLevel -> Text +logLevelText l = case l of + LogDebug -> "debug" + LogInfo -> "info" + LogNotice -> "notice" + LogWarning -> "warning" + LogError -> "error" + LogCritical -> "critical" + LogAlert -> "alert" + LogEmergency -> "emergency" + +instance ToJSON LogLevel where + toJSON = String . logLevelText + +instance FromJSON LogLevel where + parseJSON = withText "LogLevel" $ \t -> + case lookup t [(logLevelText l, l) | l <- [minBound .. maxBound]] of + Just l -> pure l + Nothing -> fail $ "Unknown log level: " ++ T.unpack t + +instance ToJSON Icon where + toJSON i = object $ + [ "src" .= iconSrc i ] + ++ maybe [] (\m -> ["mimeType" .= m]) (iconMimeType i) + ++ (if null (iconSizes i) then [] else ["sizes" .= iconSizes i]) + +instance FromJSON Icon where + parseJSON = withObject "Icon" $ \o -> Icon + <$> o .: "src" + <*> o .:? "mimeType" + <*> o .:? "sizes" .!= [] + +-- | Prompt message +data PromptMessage = PromptMessage + { promptMessageRole :: MessageRole + , promptMessageContent :: Content + } deriving (Show, Eq, Generic) + +instance ToJSON PromptMessage where + toJSON msg = object + [ "role" .= promptMessageRole msg + , "content" .= promptMessageContent msg + ] + +-- | The full result of a tool call. +-- +-- Tool /execution/ failures belong in the result with 'toolResultIsError' +-- set (so the model can see what went wrong and react); JSON-RPC errors are +-- reserved for protocol-level failures such as unknown tools or malformed +-- arguments. +data ToolResult = ToolResult + { toolResultContent :: [Content] + , toolResultStructured :: Maybe Value -- ^ structuredContent (2025-06-18+) + , toolResultIsError :: Bool + , toolResultMeta :: Maybe Value + } deriving (Show, Eq, Generic) + +-- | A successful tool result with the given content blocks. +toolResult :: [Content] -> ToolResult +toolResult content = ToolResult + { toolResultContent = content + , toolResultStructured = Nothing + , toolResultIsError = False + , toolResultMeta = Nothing + } + +-- | A failed tool execution: the message is reported to the model with +-- @isError: true@ rather than as a JSON-RPC error. +toolError :: Text -> ToolResult +toolError msg = (toolResult [ContentText msg]) { toolResultIsError = True } + +-- | Types a tool handler may return. Returning plain 'Content' (or 'Text') +-- keeps simple handlers simple; return a full t'ToolResult' for multiple +-- content blocks, structured content, or execution errors. +class ToToolResult a where + toToolResult :: a -> ToolResult + +instance ToToolResult ToolResult where + toToolResult = id + +instance ToToolResult Content where + toToolResult c = toolResult [c] + +-- | Concatenates content; a merged result is an error if any element is +-- ('toolResultIsError' is OR-ed), and the first present @structuredContent@ +-- and @_meta@ are kept. +instance ToToolResult a => ToToolResult [a] where + toToolResult xs = ToolResult + { toolResultContent = concatMap toolResultContent rs + , toolResultStructured = firstJust (map toolResultStructured rs) + , toolResultIsError = any toolResultIsError rs + , toolResultMeta = firstJust (map toolResultMeta rs) + } + where rs = map toToolResult xs + +instance ToToolResult Text where + toToolResult = toToolResult . ContentText + +firstJust :: [Maybe a] -> Maybe a +firstJust = listToMaybe . catMaybes + +-- | What a tool handler derived with +-- 'MCP.Server.Derive.deriveToolHandlerWithOutput' returns: a typed value +-- that the derivation serializes into @structuredContent@ (matching the +-- derived @outputSchema@), or one of the escape hatches. +data ToolOutput o + = ToolOutput o + -- ^ A structured value. Per the spec's recommendation, the serialized + -- JSON is also returned as a text content block for clients that + -- predate structured output. + | ToolOutputWith [Content] o + -- ^ A structured value with caller-supplied content blocks (no + -- automatic text block). + | ToolOutputError Text + -- ^ An execution failure, reported with @isError@ (see 'toolError'). + | ToolOutputRaw ToolResult + -- ^ Full control: return this t'ToolResult' as-is, with no structured + -- content implied. + deriving (Show, Eq) + +-- | The full result of a prompts/get request: an optional description and +-- a conversation of one or more messages. +data PromptResult = PromptResult + { promptResultDescription :: Maybe Text + , promptResultMessages :: [PromptMessage] + } deriving (Show, Eq, Generic) + +-- | Types a prompt handler may return. Plain 'Content' (or 'Text') becomes a +-- single user message; return t'PromptResult' or @[t'PromptMessage']@ for +-- multi-message conversations or assistant roles. +class ToPromptResult a where + toPromptResult :: a -> PromptResult + +instance ToPromptResult PromptResult where + toPromptResult = id + +instance ToPromptResult PromptMessage where + toPromptResult m = PromptResult Nothing [m] + +-- | Concatenates messages and keeps the first present description. +instance ToPromptResult a => ToPromptResult [a] where + toPromptResult xs = PromptResult + (firstJust (map promptResultDescription rs)) + (concatMap promptResultMessages rs) + where rs = map toPromptResult xs + +instance ToPromptResult Content where + toPromptResult c = toPromptResult (PromptMessage RoleUser c) + +instance ToPromptResult Text where + toPromptResult = toPromptResult . ContentText + -- | MCP protocol errors data Error = InvalidPromptName Text @@ -192,20 +529,89 @@ errorMessage (MethodNotFound msg) = "Method not found: " <> msg errorMessage (InvalidParams msg) = "Invalid parameters: " <> msg +-- | A JSON Schema fragment: a shape plus an optional description. +data Schema = Schema + { schemaDescription :: Maybe Text + , schemaShape :: SchemaType + } deriving (Show, Eq, Generic) + +-- | The shape of a JSON Schema fragment. +data SchemaType + = SchemaString (Maybe [Text]) + -- ^ A string, optionally restricted to an enum of allowed values + | SchemaInteger + | SchemaNumber + | SchemaBoolean + | SchemaArray Schema + | SchemaObject [(Text, Schema)] [Text] + -- ^ Properties and the names of the required ones + | SchemaRaw Object + -- ^ JSON Schema keywords, serialized as given. An escape hatch for + -- schemas the other shapes cannot express, such as @null@, @anyOf@, + -- @$defs@ and @$ref@, or numeric bounds. The library does not check + -- them; a tool's input schema must still describe an object. + deriving (Show, Eq, Generic) + +-- | A schema with no description. +schema :: SchemaType -> Schema +schema = Schema Nothing + +-- | A schema with a description. +describedSchema :: Text -> SchemaType -> Schema +describedSchema desc = Schema (Just desc) + +instance ToJSON Schema where + -- The description comes last, so for raw keywords it replaces any + -- description they contain. + toJSON (Schema desc shape) = object $ + typeFields shape ++ maybe [] (\d -> ["description" .= d]) desc + where + typeFields :: SchemaType -> [Pair] + typeFields (SchemaString enumVals) = + [ "type" .= ("string" :: Text) ] + ++ maybe [] (\vs -> ["enum" .= vs]) enumVals + typeFields SchemaInteger = [ "type" .= ("integer" :: Text) ] + typeFields SchemaNumber = [ "type" .= ("number" :: Text) ] + typeFields SchemaBoolean = [ "type" .= ("boolean" :: Text) ] + typeFields (SchemaArray items) = + [ "type" .= ("array" :: Text) + , "items" .= items + ] + typeFields (SchemaObject props req) = + [ "type" .= ("object" :: Text) + , "properties" .= object (map (\(k, v) -> fromText k .= v) props) + , "required" .= req + ] + typeFields (SchemaRaw keywords) = KM.toList keywords + -- | Prompt definition (2025-06-18 enhanced) data PromptDefinition = PromptDefinition { promptDefinitionName :: Text , promptDefinitionDescription :: Text , promptDefinitionArguments :: [ArgumentDefinition] , promptDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , promptDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A prompt definition with only the required fields set; record-update +-- the optional ones (constructing t'PromptDefinition' directly breaks when +-- fields are added). +mkPromptDefinition :: Text -> Text -> [ArgumentDefinition] -> PromptDefinition +mkPromptDefinition name description args = PromptDefinition + { promptDefinitionName = name + , promptDefinitionDescription = description + , promptDefinitionArguments = args + , promptDefinitionTitle = Nothing + , promptDefinitionIcons = [] + } + instance ToJSON PromptDefinition where toJSON def = object $ [ "name" .= promptDefinitionName def , "description" .= promptDefinitionDescription def , "arguments" .= promptDefinitionArguments def ] ++ maybe [] (\t -> ["title" .= t]) (promptDefinitionTitle def) + ++ (if null (promptDefinitionIcons def) then [] else ["icons" .= promptDefinitionIcons def]) -- | Resource definition (2025-06-18 enhanced) data ResourceDefinition = ResourceDefinition @@ -214,8 +620,21 @@ , resourceDefinitionDescription :: Maybe Text , resourceDefinitionMimeType :: Maybe Text , resourceDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , resourceDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A resource definition with only the required fields set; record-update +-- the optional ones. +mkResourceDefinition :: Text -> Text -> ResourceDefinition +mkResourceDefinition uri name = ResourceDefinition + { resourceDefinitionURI = uri + , resourceDefinitionName = name + , resourceDefinitionDescription = Nothing + , resourceDefinitionMimeType = Nothing + , resourceDefinitionTitle = Nothing + , resourceDefinitionIcons = [] + } + instance ToJSON ResourceDefinition where toJSON def = object $ [ "uri" .= resourceDefinitionURI def @@ -223,22 +642,105 @@ ] ++ maybe [] (\d -> ["description" .= d]) (resourceDefinitionDescription def) ++ maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def) ++ - maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) + maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) ++ + (if null (resourceDefinitionIcons def) then [] else ["icons" .= resourceDefinitionIcons def]) +instance FromJSON ResourceDefinition where + parseJSON = withObject "ResourceDefinition" $ \o -> ResourceDefinition + <$> o .: "uri" + <*> o .: "name" + <*> o .:? "description" + <*> o .:? "mimeType" + <*> o .:? "title" + <*> o .:? "icons" .!= [] + +-- | Resource template definition: a parameterized resource identified by an +-- RFC 6570 URI template. +data ResourceTemplateDefinition = ResourceTemplateDefinition + { resourceTemplateURITemplate :: Text + , resourceTemplateName :: Text + , resourceTemplateDescription :: Maybe Text + , resourceTemplateMimeType :: Maybe Text + , resourceTemplateTitle :: Maybe Text + , resourceTemplateIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) + } deriving (Show, Eq, Generic) + +-- | A template definition with only the required fields set; record-update +-- the optional ones. +mkResourceTemplateDefinition :: Text -> Text -> ResourceTemplateDefinition +mkResourceTemplateDefinition uriTemplate name = ResourceTemplateDefinition + { resourceTemplateURITemplate = uriTemplate + , resourceTemplateName = name + , resourceTemplateDescription = Nothing + , resourceTemplateMimeType = Nothing + , resourceTemplateTitle = Nothing + , resourceTemplateIcons = [] + } + +instance ToJSON ResourceTemplateDefinition where + toJSON def = object $ + [ "uriTemplate" .= resourceTemplateURITemplate def + , "name" .= resourceTemplateName def + ] ++ + maybe [] (\d -> ["description" .= d]) (resourceTemplateDescription def) ++ + maybe [] (\m -> ["mimeType" .= m]) (resourceTemplateMimeType def) ++ + maybe [] (\t -> ["title" .= t]) (resourceTemplateTitle def) ++ + (if null (resourceTemplateIcons def) then [] else ["icons" .= resourceTemplateIcons def]) + +-- | What a completion request is completing an argument for. +data CompletionRef + = CompletionRefPrompt Text -- ^ @ref/prompt@: a prompt, by name + | CompletionRefResource Text -- ^ @ref/resource@: a resource URI or URI template + deriving (Show, Eq, Generic) + +-- | Completion suggestions for an argument value. +data CompletionResult = CompletionResult + { completionValues :: [Text] -- ^ Suggestions ranked by relevance (max 100 are sent) + , completionTotal :: Maybe Int -- ^ Optional total number of matches + , completionHasMore :: Maybe Bool -- ^ Whether more results exist beyond 'completionValues' + } deriving (Show, Eq, Generic) + +-- | A completion result with just the given suggestions. +completionResult :: [Text] -> CompletionResult +completionResult vals = CompletionResult + { completionValues = vals + , completionTotal = Nothing + , completionHasMore = Nothing + } + -- | Tool definition (2025-06-18 enhanced) data ToolDefinition = ToolDefinition - { toolDefinitionName :: Text - , toolDefinitionDescription :: Text - , toolDefinitionInputSchema :: InputSchemaDefinition - , toolDefinitionTitle :: Maybe Text -- New title field for human-friendly display + { toolDefinitionName :: Text + , toolDefinitionDescription :: Text + , toolDefinitionInputSchema :: Schema + , toolDefinitionOutputSchema :: Maybe Schema + , toolDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , toolDefinitionAnnotations :: Maybe ToolAnnotations -- ^ behavioral hints (2025-03-26+) + , toolDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A tool definition with only the required fields set; record-update the +-- optional ones. +mkToolDefinition :: Text -> Text -> Schema -> ToolDefinition +mkToolDefinition name description inputSchema = ToolDefinition + { toolDefinitionName = name + , toolDefinitionDescription = description + , toolDefinitionInputSchema = inputSchema + , toolDefinitionOutputSchema = Nothing + , toolDefinitionTitle = Nothing + , toolDefinitionAnnotations = Nothing + , toolDefinitionIcons = [] + } + instance ToJSON ToolDefinition where toJSON def = object $ [ "name" .= toolDefinitionName def , "description" .= toolDefinitionDescription def , "inputSchema" .= toolDefinitionInputSchema def - ] ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def) + ] ++ maybe [] (\s -> ["outputSchema" .= s]) (toolDefinitionOutputSchema def) + ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def) + ++ maybe [] (\a -> ["annotations" .= a]) (toolDefinitionAnnotations def) + ++ (if null (toolDefinitionIcons def) then [] else ["icons" .= toolDefinitionIcons def]) -- | Argument definition for prompts data ArgumentDefinition = ArgumentDefinition @@ -254,30 +756,6 @@ , "required" .= argumentDefinitionRequired def ] --- | Input schema definition for tools -data InputSchemaDefinition = InputSchemaDefinitionObject - { properties :: [(Text, InputSchemaDefinitionProperty)] - , required :: [Text] - } deriving (Show, Eq, Generic) - -instance ToJSON InputSchemaDefinition where - toJSON (InputSchemaDefinitionObject props req) = object - [ "type" .= ("object" :: Text) - , "properties" .= object (map (\(k, v) -> fromText k .= v) props) - , "required" .= req - ] - -data InputSchemaDefinitionProperty = InputSchemaDefinitionProperty - { propertyType :: Text - , propertyDescription :: Text - } deriving (Show, Eq, Generic) - -instance ToJSON InputSchemaDefinitionProperty where - toJSON prop = object - [ "type" .= propertyType prop - , "description" .= propertyDescription prop - ] - -- | Server information data McpServerInfo = McpServerInfo { serverName :: Text @@ -295,6 +773,8 @@ [ fmap ("listChanged" .=) (promptListChanged caps) ] +-- | The @resources@ capability: whether the server supports subscriptions +-- and list-change notifications. data ResourceCapabilities = ResourceCapabilities { resourceSubscribe :: Maybe Bool , resourceListChanged :: Maybe Bool @@ -306,6 +786,8 @@ , fmap ("listChanged" .=) (resourceListChanged caps) ] +-- | The @tools@ capability: whether the server sends list-change +-- notifications. data ToolCapabilities = ToolCapabilities { toolListChanged :: Maybe Bool } deriving (Show, Eq, Generic) @@ -315,6 +797,15 @@ [ fmap ("listChanged" .=) (toolListChanged caps) ] +-- | The @completions@ capability, which has no options. +data CompletionCapabilities = CompletionCapabilities + { -- No sub-capabilities defined + } deriving (Show, Eq, Generic) + +instance ToJSON CompletionCapabilities where + toJSON _ = object [] + +-- | The @logging@ capability, which has no options. data LoggingCapabilities = LoggingCapabilities { -- No specific sub-capabilities for logging yet } deriving (Show, Eq, Generic) @@ -324,10 +815,11 @@ -- | Server capabilities data ServerCapabilities = ServerCapabilities - { capabilityPrompts :: Maybe PromptCapabilities - , capabilityResources :: Maybe ResourceCapabilities - , capabilityTools :: Maybe ToolCapabilities - , capabilityLogging :: Maybe LoggingCapabilities + { capabilityPrompts :: Maybe PromptCapabilities + , capabilityResources :: Maybe ResourceCapabilities + , capabilityTools :: Maybe ToolCapabilities + , capabilityCompletions :: Maybe CompletionCapabilities + , capabilityLogging :: Maybe LoggingCapabilities } deriving (Show, Eq, Generic) instance ToJSON ServerCapabilities where @@ -335,6 +827,7 @@ [ fmap ("prompts" .=) (capabilityPrompts caps) , fmap ("resources" .=) (capabilityResources caps) , fmap ("tools" .=) (capabilityTools caps) + , fmap ("completions" .=) (capabilityCompletions caps) , fmap ("logging" .=) (capabilityLogging caps) ] @@ -347,22 +840,255 @@ -- the transport's authorization callback -- (e.g. a role). 'Nothing' when -- authentication is disabled. + , clientProtocolVersion :: Maybe Text + -- ^ The protocol revision the request declared in its @_meta@ + -- (modern, 2026-07-28+ clients). 'Nothing' for legacy clients that + -- negotiated via @initialize@. + , clientInfo :: Maybe Value + -- ^ The client's self-reported identity from request @_meta@ + -- (modern clients), for display/logging only. + , clientCapabilities :: Maybe Value + -- ^ The client's declared capabilities from request @_meta@ + -- (modern clients). + , reportProgress :: Double -> Maybe Double -> Maybe Text -> IO () + -- ^ Report progress for this request: current progress (which must + -- increase with each call), an optional total, and an optional + -- human-readable message. A no-op when the request carried no + -- @progressToken@, so handlers can call it unconditionally. Stop + -- reporting once the handler returns; avoid flooding. + , logToClient :: LogLevel -> Value -> IO () + -- ^ Send a log message to this request's client + -- (@notifications\/message@). A no-op unless the request declared + -- @io.modelcontextprotocol\/logLevel@ (the spec forbids emitting + -- otherwise); messages below the declared level are dropped. + , clientInputResponses :: Map Text InputResponse + -- ^ On a retry after 'InputRequired': the client's answers, keyed as + -- the handler keyed its requests. Only answers to the requests that + -- round issued are passed on; anything else the client sends is + -- ignored. Empty otherwise. Only the latest round's answers arrive; + -- carry earlier ones in the state. + , clientRequestState :: Maybe Text + -- ^ On a retry after 'InputRequired': the state the handler returned, + -- verified and decrypted by the library. 'Nothing' otherwise. + } + +-- | A context carrying no transport- or request-level information: what +-- handlers see for legacy stdio requests. +anonymousContext :: ClientContext +anonymousContext = ClientContext + { clientToken = Nothing + , clientPrincipal = Nothing + , clientProtocolVersion = Nothing + , clientInfo = Nothing + , clientCapabilities = Nothing + , reportProgress = \_ _ _ -> pure () + , logToClient = \_ _ -> pure () + , clientInputResponses = mempty + , clientRequestState = Nothing + } + +-- | Cacheability hints stamped onto modern (2026-07-28+) list/read results, +-- which require @ttlMs@ and @cacheScope@ fields. +data CacheHints = CacheHints + { cacheTtlMs :: Int -- ^ Freshness hint in milliseconds. + , cacheScopePublic :: Bool -- ^ 'True' allows shared intermediaries to + -- cache the response (@\"public\"@); + -- 'False' is @\"private\"@. } deriving (Show, Eq) --- | Handler type definitions. Every handler receives the request's --- 'ClientContext' as its first argument. -type PromptListHandler m = ClientContext -> m [PromptDefinition] -type PromptGetHandler m = ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) +-- | Conservative defaults: no caching (@ttlMs = 0@), private scope. +defaultCacheHints :: CacheHints +defaultCacheHints = CacheHints + { cacheTtlMs = 0 + , cacheScopePublic = False + } -type ResourceListHandler m = ClientContext -> m [ResourceDefinition] -type ResourceReadHandler m = ClientContext -> URI -> m (Either Error ResourceContent) +-- | What change-notification delivery the serving transport offers, which +-- decides the @listChanged@\/@subscribe@ capabilities each era advertises. +data NotificationSupport = NotificationSupport + { supportsLegacyPush :: Bool + -- ^ The transport can push unsolicited notifications to legacy + -- (initialize-handshake) clients — true for stdio with a configured + -- notification source; never for HTTP (this library dropped the + -- deprecated GET SSE stream legacy delivery relied on). + , supportsListen :: Bool + -- ^ @subscriptions\/listen@ (2026-07-28) is served. + } deriving (Show, Eq) -type ToolListHandler m = ClientContext -> m [ToolDefinition] -type ToolCallHandler m = ClientContext -> ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) +-- | No notification delivery at all: nothing extra is advertised. +noNotificationSupport :: NotificationSupport +noNotificationSupport = NotificationSupport + { supportsLegacyPush = False + , supportsListen = False + } +-- | What a handler that may ask the client for input produces +-- (@tools\/call@, @prompts\/get@ and @resources\/read@, the requests the +-- specification allows to do so). +-- +-- 'InputRequired' answers the request with an @input_required@ result: +-- the client gathers the requested input and retries the request, and the +-- handler then sees the answers in 'clientInputResponses' and its state in +-- 'clientRequestState'. The library protects the state (see +-- "MCP.Server.RequestState"), so a handler can put anything in it. +data Outcome a + = Complete a + -- ^ The request is done. + | InputRequired (Map Text InputRequest) (Maybe Text) + -- ^ Requests for the client, keyed by ids the handler chooses (the + -- same keys come back in 'clientInputResponses'), and state to + -- receive back in 'clientRequestState' on the retry. + deriving (Show, Eq, Functor) + +-- | A request for the client to fulfil before retrying. +data InputRequest + = ElicitForm Text Schema + -- ^ Ask the user to fill in a form (@elicitation\/create@ in @form@ + -- mode): the message, and the schema of an object whose properties + -- are strings, numbers, booleans or enumerations. + | ElicitUrl Text URI + -- ^ Send the user to a URL to complete an interaction out of band + -- (@elicitation\/create@ in @url@ mode): the message and the URL. + | RawInputRequest Text Value + -- ^ Any other request, by method and params, such as + -- @sampling\/createMessage@ or @roots\/list@ (both deprecated in + -- 2026-07-28). + deriving (Show, Eq) + +instance ToJSON InputRequest where + toJSON (ElicitForm message requested) = object + [ "method" .= ("elicitation/create" :: Text) + , "params" .= object + [ "mode" .= ("form" :: Text) + , "message" .= message + , "requestedSchema" .= requested + ] + ] + toJSON (ElicitUrl message url) = object + [ "method" .= ("elicitation/create" :: Text) + , "params" .= object + [ "mode" .= ("url" :: Text) + , "message" .= message + , "url" .= show url + ] + ] + toJSON (RawInputRequest method params) = object + [ "method" .= method + , "params" .= params + ] + +-- | The client's answer to an 'InputRequest'. +data InputResponse + = ElicitResponse ElicitAction (Maybe (Map Text Value)) + -- ^ The user's action, and the submitted form content when they + -- accepted a form. + | RawInputResponse Value + -- ^ Any other result, such as a sampling or roots result. + deriving (Show, Eq) + +-- | How the user responded to an elicitation. +data ElicitAction + = ElicitAccept -- ^ Submitted the form, or confirmed the action + | ElicitDecline -- ^ Explicitly declined + | ElicitCancel -- ^ Dismissed without choosing + deriving (Show, Eq, Ord, Enum, Bounded) + +instance FromJSON InputResponse where + parseJSON = withObject "InputResponse" $ \o -> + case KM.lookup "action" o of + Just (String a) | Just action <- lookup a actions -> + ElicitResponse action <$> o .:? "content" + _ -> pure (RawInputResponse (Object o)) + where + actions = + [ ("accept", ElicitAccept) + , ("decline", ElicitDecline) + , ("cancel", ElicitCancel) + ] + +-- | Whether the client making this request can fulfil an input request: +-- it must speak a revision with multi round-trip requests (2026-07-28+) +-- and have declared the matching capability. Elicitation is declared per +-- mode; an empty @elicitation@ capability means @form@ only. +clientSupportsInput :: ClientContext -> InputRequest -> Bool +clientSupportsInput ctx request = case clientProtocolVersion ctx of + Nothing -> False + Just _ -> case request of + ElicitForm _ _ -> elicitForm + ElicitUrl _ _ -> elicitUrl + RawInputRequest "elicitation/create" params + | modeOf params == Just "url" -> elicitUrl + | otherwise -> elicitForm + RawInputRequest "sampling/createMessage" _ -> declared "sampling" + RawInputRequest "roots/list" _ -> declared "roots" + RawInputRequest _ _ -> False + where + caps = case clientCapabilities ctx of + Just (Object o) -> o + _ -> KM.empty + declared key = KM.member key caps + elicitation = case KM.lookup "elicitation" caps of + Just (Object e) -> Just e + _ -> Nothing + elicitForm = case elicitation of + Just e -> KM.member "form" e || not (KM.member "url" e) + Nothing -> False + elicitUrl = maybe False (KM.member "url") elicitation + modeOf (Object p) = case KM.lookup "mode" p of + Just (String m) -> Just m + _ -> Nothing + modeOf _ = Nothing + +-- | List the available prompts (@prompts\/list@). Every handler receives +-- the request's t'ClientContext' as its first argument. +-- +-- Prompt arguments are string-valued per the MCP specification; tool +-- arguments are full JSON values. +type PromptListHandler = ClientContext -> IO [PromptDefinition] +-- | Render a prompt from its name and arguments (@prompts\/get@). +type PromptGetHandler = ClientContext -> PromptName -> Map Text Text -> IO (Either Error (Outcome PromptResult)) + +-- | List the available resources (@resources\/list@). +type ResourceListHandler = ClientContext -> IO [ResourceDefinition] +-- | Read a resource by URI (@resources\/read@). +type ResourceReadHandler = ClientContext -> URI -> IO (Either Error (Outcome ResourceContent)) +-- | List the resource templates (@resources\/templates\/list@). +type ResourceTemplateListHandler = ClientContext -> IO [ResourceTemplateDefinition] + +-- | List the available tools (@tools\/list@). +type ToolListHandler = ClientContext -> IO [ToolDefinition] +-- | Call a tool by name with its JSON arguments (@tools\/call@). +type ToolCallHandler = ClientContext -> ToolName -> Map Text Value -> IO (Either Error (Outcome ToolResult)) + +-- | Completion handler: given what is being completed ('CompletionRef'), the +-- argument name, the partial value typed so far, and any already-resolved +-- sibling arguments, produce ranked suggestions. +type CompletionHandler = ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult) + -- | Server handlers -data McpServerHandlers m = McpServerHandlers - { prompts :: Maybe (PromptListHandler m, PromptGetHandler m) - , resources :: Maybe (ResourceListHandler m, ResourceReadHandler m) - , tools :: Maybe (ToolListHandler m, ToolCallHandler m) +data McpServerHandlers = McpServerHandlers + { prompts :: Maybe (PromptListHandler, PromptGetHandler) + , resources :: Maybe (ResourceListHandler, ResourceReadHandler) + , resourceTemplates :: Maybe ResourceTemplateListHandler + -- ^ Parameterized resources (@resources\/templates\/list@). Template + -- URIs are read through the 'ResourceReadHandler' in 'resources' — + -- configure both, or template reads have nothing to serve them + -- (a templates-only configuration still answers @resources\/list@ + -- with an empty list so the advertised capability stays honest). + , tools :: Maybe (ToolListHandler, ToolCallHandler) + , completions :: Maybe CompletionHandler + -- ^ Argument autocompletion (@completion\/complete@) for prompts and + -- resource templates. + } + +-- | Handlers for a server that supports nothing — record-update the features +-- you provide, so adding new handler slots to the library does not break +-- your construction. +noHandlers :: McpServerHandlers +noHandlers = McpServerHandlers + { prompts = Nothing + , resources = Nothing + , resourceTemplates = Nothing + , tools = Nothing + , completions = Nothing } diff --git a/test/AskTypes.hs b/test/AskTypes.hs new file mode 100644 --- /dev/null +++ b/test/AskTypes.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Forms and handlers for the derived-interface tests of 'Ask' (ADR 0009, +-- phase 3). Splices that derive handlers live in "Spec.DerivedAsk". +module AskTypes where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH (recover) +import MCP.Server +import MCP.Server.Derive + +data Environment = Staging | Production + deriving (Show, Eq) + +data Tag = Urgent | Routine + deriving (Show, Eq) + +newtype Ticket = Ticket Text + deriving (Show, Eq) + +data DeployTarget = DeployTarget + { environment :: Environment + , reason :: Text + , notify :: Maybe Bool + , replicas :: Int + , tags :: [Tag] + , ticket :: Maybe Ticket + } deriving (Show, Eq) + +newtype Confirm = Confirm { proceed :: Bool } + deriving (Show, Eq) + +data Styled = Styled { size :: Double, label :: Text, mode :: Environment } + deriving (Show, Eq) + +data Counted = Counted { count :: Int, greeting :: Text } + deriving (Show, Eq) + +$(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")]) +$(deriveForm ''Confirm) +$(deriveFormWithOptions ''Styled + [ ("size", defaultFormFieldOptions { formFieldTitle = Just "Size", formFieldDefault = Just (Number 1.5) }) + , ("mode", defaultFormFieldOptions { formFieldDefault = Just "production", formFieldDescription = Just "Where" }) + ]) + +$(deriveFormWithOptions ''Counted + [ ("count", defaultFormFieldOptions { formFieldDefault = Just (Number 3) }) + , ("greeting", defaultFormFieldOptions { formFieldDefault = Just "café 東京" }) + ]) + +-- Types a form cannot hold, for the compile-time rejection tests. +data Inner = Inner { innerName :: Text } deriving (Show, Eq) +data Nested = Nested { inner :: Inner } deriving (Show, Eq) +data TextList = TextList { names :: [Text] } deriving (Show, Eq) +data Unit = Unit deriving (Show, Eq) + +-- | Which derivations were rejected at compile time. +rejectedNested, rejectedTextList, rejectedUnit, rejectedUnknownField, rejectedBadDefault, rejectedBadChoice, + rejectedFractionalInt, rejectedOutOfRangeInt :: Bool +rejectedNested = $(recover [| True |] (deriveForm ''Nested >> [| False |])) +rejectedTextList = $(recover [| True |] (deriveForm ''TextList >> [| False |])) +rejectedUnit = $(recover [| True |] (deriveForm ''Unit >> [| False |])) +rejectedUnknownField = $(recover [| True |] + (deriveFormWithDescription ''Confirm [("procede", "typo")] >> [| False |])) +rejectedBadDefault = $(recover [| True |] + (deriveFormWithOptions ''Confirm [("proceed", defaultFormFieldOptions { formFieldDefault = Just "yes" })] >> [| False |])) +rejectedFractionalInt = $(recover [| True |] + (deriveFormWithOptions ''Counted [("count", defaultFormFieldOptions { formFieldDefault = Just (Number 1.5) })] >> [| False |])) +rejectedOutOfRangeInt = $(recover [| True |] + (deriveFormWithOptions ''Counted [("count", defaultFormFieldOptions { formFieldDefault = Just (Number 1e30) })] >> [| False |])) +rejectedBadChoice = $(recover [| True |] + (deriveFormWithOptions ''Styled [("mode", defaultFormFieldOptions { formFieldDefault = Just "prod" })] >> [| False |])) + +-- Tools: one asks, one never does. +data OpsTool + = Deploy { service :: Text } + | Status { service :: Text } + deriving (Show, Eq) + +handleOps :: ClientContext -> OpsTool -> Ask Content +handleOps _ (Deploy svc) = do + target <- elicit ("Where should " <> svc <> " deploy to?") + case target of + Accepted t -> do + plan <- step (pure (T.pack (show (environment t)) <> " x" <> T.pack (show (replicas t)))) + ok <- elicit ("Apply " <> plan <> "?") + pure $ ContentText $ case ok of + Accepted (Confirm True) -> "deployed " <> svc <> ": " <> plan + _ -> "cancelled" + other -> pure (ContentText ("no target: " <> T.pack (show (() <$ other)))) +handleOps _ (Status svc) = ContentText <$> liftIO (pure (svc <> " is up")) + +-- An IO handler still derives unchanged. +handleOpsIO :: ClientContext -> OpsTool -> IO Content +handleOpsIO _ (Deploy svc) = pure (ContentText ("deployed " <> svc)) +handleOpsIO _ (Status svc) = pure (ContentText (svc <> " is up")) + +-- Structured output from an asking handler. +newtype DeployReport = DeployReport { deployed :: Bool } + +handleOpsOutput :: ClientContext -> OpsTool -> Ask (ToolOutput DeployReport) +handleOpsOutput _ _ = do + ok <- elicit "Go?" + pure $ ToolOutput $ DeployReport $ case ok of + Accepted (Confirm b) -> b + _ -> False + +-- Derived here, where only 'Value' is imported from aeson: the generated +-- serializer must not rely on names from the user's imports. +$(pure []) + +outputTools :: (ToolListHandler, ToolCallHandler) +outputTools = $(deriveToolHandlerWithOutput ''OpsTool 'handleOpsOutput ''DeployReport) + +-- Prompts and resources can ask too. +newtype OpsPrompt = Briefing { team :: Text } + +handlePrompt :: ClientContext -> OpsPrompt -> Ask Content +handlePrompt _ (Briefing t) = do + ok <- elicit ("Include incidents for " <> t <> "?") + pure $ ContentText $ case ok of + Accepted (Confirm True) -> "briefing with incidents" + _ -> "briefing" + +data OpsResource = Secrets + +handleResource :: ClientContext -> URI -> OpsResource -> Ask ResourceContent +handleResource _ uri Secrets = do + ok <- elicit "Reveal secrets?" + pure $ ResourceText uri "text/plain" $ case ok of + Accepted (Confirm True) -> "s3cret" + _ -> "hidden" diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -7,9 +7,24 @@ import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation +import qualified Spec.AskMonad +import qualified Spec.Cancellation import qualified Spec.UnicodeHandling +import qualified Spec.DefinitionMetadata +import qualified Spec.DerivedAsk +import qualified Spec.DerivedOutput +import qualified Spec.GoldenWire +import qualified Spec.HandlerExceptions +import qualified Spec.HttpTransport +import qualified Spec.InputRequired +import qualified Spec.ModernEra +import qualified Spec.Progress import qualified Spec.ProtocolVersionNegotiation +import qualified Spec.RawSchema +import qualified Spec.Subscriptions +import qualified Spec.TemplatesCompletions import qualified Spec.ToolCallParsing +import qualified Spec.TypedArgs main :: IO () main = hspec $ do @@ -18,6 +33,21 @@ Spec.BasicDerivation.spec Spec.SchemaValidation.spec Spec.AdvancedDerivation.spec + Spec.AskMonad.spec + Spec.Cancellation.spec Spec.UnicodeHandling.spec + Spec.DefinitionMetadata.spec + Spec.DerivedAsk.spec + Spec.DerivedOutput.spec + Spec.GoldenWire.spec + Spec.HandlerExceptions.spec + Spec.HttpTransport.spec + Spec.InputRequired.spec + Spec.ModernEra.spec + Spec.Progress.spec Spec.ProtocolVersionNegotiation.spec + Spec.RawSchema.spec + Spec.Subscriptions.spec + Spec.TemplatesCompletions.spec Spec.ToolCallParsing.spec + Spec.TypedArgs.spec diff --git a/test/Spec/AdvancedDerivation.hs b/test/Spec/AdvancedDerivation.hs --- a/test/Spec/AdvancedDerivation.hs +++ b/test/Spec/AdvancedDerivation.hs @@ -9,20 +9,21 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes import TestData -- Generate advanced handlers for separate parameter types -testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlers :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) -testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlers :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) -testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) -testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions) -- Helper functions for advanced testing @@ -35,17 +36,13 @@ assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO () assertSchemaHasProperties expectedProps toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - let propNames = map fst props - in all (`elem` propNames) expectedProps `shouldBe` True + let propNames = map fst (schemaProps (toolDefinitionInputSchema toolDef)) + all (`elem` propNames) expectedProps `shouldBe` True -assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO () +assertToolCallResult :: ToolCallHandler -> Text -> [(Text, Text)] -> Text -> IO () assertToolCallResult handler toolName args expectedContent = do - result <- handler anonCtx toolName args - case result of - Right (ContentText content) -> content `shouldBe` expectedContent - other -> expectationFailure $ "Expected ContentText but got: " ++ show other + result <- handler anonCtx toolName (stringArgs args) + result `shouldBeTextResult` expectedContent assertToolHasDescription :: Text -> Text -> ToolDefinition -> IO () assertToolHasDescription toolName expectedDesc toolDef = do @@ -54,11 +51,9 @@ assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO () assertPropertyHasDescription propName expectedDesc toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - case lookup propName props of - Just prop -> propertyDescription prop `shouldBe` expectedDesc - Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName + case lookupProp propName toolDef of + Just prop -> schemaDescription prop `shouldBe` Just expectedDesc + Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName spec :: Spec spec = describe "Advanced Template Haskell Derivation" $ do diff --git a/test/Spec/AskMonad.hs b/test/Spec/AskMonad.hs new file mode 100644 --- /dev/null +++ b/test/Spec/AskMonad.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for the 'Ask' monad (ADR 0009, phase 2): handlers replayed +-- against a journal across rounds, through the real dispatcher and state +-- codec. +module Spec.AskMonad (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) + +newtype Target = Target { environment :: Text } deriving (Show, Eq, Generic) +instance FromJSON Target +instance Form Target where + formSchema _ = schema $ SchemaObject + [("environment", schema (SchemaString (Just ["staging", "production"])))] + ["environment"] + +newtype Confirm = Confirm { ok :: Bool } deriving (Show, Eq, Generic) +instance FromJSON Confirm +instance Form Confirm where + formSchema _ = schema $ SchemaObject [("ok", schema SchemaBoolean)] ["ok"] + +-- | Counters for what ran: the journaled planning step, and every round. +data Counters = Counters { planRuns :: IORef Int, rounds :: IORef Int } + +-- | Ask for a target, plan once, ask for confirmation. +deploy :: Counters -> Ask Text +deploy counters = do + liftIO (modifyIORef (rounds counters) (+ 1)) + target <- elicit "Where to?" + case target of + Accepted (Target env) -> do + plan <- step $ do + modifyIORef (planRuns counters) (+ 1) + pure ("plan-" <> env) + confirmed <- elicit ("Apply " <> plan <> "?") + pure $ case confirmed of + Accepted (Confirm True) -> "applied " <> plan + other -> "not applied: " <> T.pack (show other) + other -> pure ("no target: " <> T.pack (show other)) + +-- | Asks a question that changes every round, which replay must refuse. +fickle :: IORef Int -> Ask Text +fickle counter = do + n <- liftIO (atomicModifyIORef counter (\c -> (c + 1, c))) + reply <- elicit ("Question " <> T.pack (show n)) + pure (T.pack (show (reply :: Answer Confirm))) + +-- | A step whose result is JSON null, a question, and a step after it. +nullStep :: Ask Text +nullStep = do + nothing <- step (pure (Nothing :: Maybe Text)) + reply <- elicit "Still there?" + later <- step (pure (2 :: Int)) + pure (T.pack (show (nothing, reply :: Answer Confirm, later))) + +handlersFor :: Counters -> IORef Int -> McpServerHandlers +handlersFor counters fickleCounter = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx name _ -> fmap (fmap (\t -> toolResult [ContentText t])) <$> + runAsk (case name of + "fickle" -> fickle fickleCounter + "null" -> nullStep + _ -> deploy counters) ctx + ) + } + +newCounters :: IO (Counters, IORef Int) +newCounters = (,) <$> (Counters <$> newIORef 0 <*> newIORef 0) <*> newIORef 0 + +call :: (Counters, IORef Int) -> Text -> Value -> [Pair] -> IO Value +call (counters, fickleCounter) name caps extra = do + response <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec + noNotificationSupport (\_ -> pure ()) (handlersFor counters fickleCounter) anonymousContext $ + JsonRpcMessageRequest JsonRpcRequest + { requestJsonrpc = "2.0" + , requestId = RequestIdNumber 1 + , requestMethod = "tools/call" + , requestParams = Just $ object $ extra ++ + [ "name" .= name + , "arguments" .= object [] + , "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientCapabilities" .= caps + ] + ] + } + case response of + Just (JsonRpcMessageResponse r) -> pure (toJSON r) + other -> fail ("expected a response, got " ++ show other) + +formCaps, noCaps :: Value +formCaps = object ["elicitation" .= object ["form" .= object []]] +noCaps = object [] + +at :: [Key] -> Value -> Maybe Value +at [] v = Just v +at (k : ks) (Object o) = KM.lookup k o >>= at ks +at _ _ = Nothing + +stateOf :: Value -> Text +stateOf v = case at ["result", "requestState"] v of + Just (String s) -> s + _ -> error ("no requestState in " ++ show v) + +-- | The keys of an @input_required@ result's requests, and their messages. +questionsOf :: Value -> [(Key, Value)] +questionsOf v = case at ["result", "inputRequests"] v of + Just (Object rs) -> [(k, m) | (k, r) <- KM.toList rs, Just m <- [at ["params", "message"] r]] + _ -> [] + +textOf :: Value -> Maybe Value +textOf v = case at ["result", "content"] v of + Just (Array xs) | [c] <- foldr (:) [] xs -> at ["text"] c + _ -> Nothing + +errorOf :: Value -> Maybe (Int, Text) +errorOf v = do + Number code <- at ["error", "code"] v + String msg <- at ["error", "message"] v + pure (round code, msg) + +answer :: Key -> Value -> Pair +answer key response = "inputResponses" .= object [key .= response] + +accepted :: [Pair] -> Value +accepted content = object ["action" .= ("accept" :: Text), "content" .= object content] + +retrying :: Value -> [Pair] +retrying previous = ["requestState" .= stateOf previous] + +spec :: Spec +spec = describe "The Ask monad" $ do + it "asks, replays answers and steps, and completes" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + questionsOf r1 `shouldBe` [("0", String "Where to?")] + r2 <- call env "deploy" formCaps $ + answer "0" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1 + questionsOf r2 `shouldBe` [("2", String "Apply plan-staging?")] + r3 <- call env "deploy" formCaps $ + answer "2" (accepted ["ok" .= True]) : retrying r2 + textOf r3 `shouldBe` Just (String "applied plan-staging") + readIORef (planRuns (fst env)) `shouldReturn` 1 + readIORef (rounds (fst env)) `shouldReturn` 3 + + it "keeps earlier answers in the journal, not in the retry" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + r2 <- call env "deploy" formCaps $ + answer "0" (accepted ["environment" .= ("production" :: Text)]) : retrying r1 + -- The last round's answers only: the first answer comes from the state. + r3 <- call env "deploy" formCaps $ answer "2" (accepted ["ok" .= False]) : retrying r2 + textOf r3 `shouldBe` Just (String "not applied: Accepted (Confirm {ok = False})") + + it "asks again when the retry carries no answer" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + r2 <- call env "deploy" formCaps (retrying r1) + questionsOf r2 `shouldBe` [("0", String "Where to?")] + + it "returns a declined or cancelled answer to the handler" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + declined <- call env "deploy" formCaps $ + answer "0" (object ["action" .= ("decline" :: Text)]) : retrying r1 + textOf declined `shouldBe` Just (String "no target: Declined") + cancelled <- call env "deploy" formCaps $ + answer "0" (object ["action" .= ("cancel" :: Text)]) : retrying r1 + textOf cancelled `shouldBe` Just (String "no target: Cancelled") + + it "answers Unavailable without a round trip when the client cannot ask" $ do + env <- newCounters + r <- call env "deploy" noCaps [] + textOf r `shouldBe` Just (String "no target: Unavailable") + legacy <- runAsk (deploy (fst env)) anonymousContext + legacy `shouldBe` Right (Complete "no target: Unavailable") + + it "runs a step again when a round is retried from an earlier state" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + let staging = answer "0" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1 + _ <- call env "deploy" formCaps staging + _ <- call env "deploy" formCaps staging + readIORef (planRuns (fst env)) `shouldReturn` 2 + + it "refuses a handler whose questions change between rounds" $ do + env <- newCounters + r1 <- call env "fickle" formCaps [] + questionsOf r1 `shouldBe` [("0", String "Question 0")] + r2 <- call env "fickle" formCaps $ answer "0" (accepted ["ok" .= True]) : retrying r1 + fmap fst (errorOf r2) `shouldBe` Just (-32603) + fmap (T.isInfixOf "position 0" . snd) (errorOf r2) `shouldBe` Just True + + it "rejects content that does not fit the form" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + r2 <- call env "deploy" formCaps $ + answer "0" (accepted ["environment" .= (3 :: Int)]) : retrying r1 + fmap fst (errorOf r2) `shouldBe` Just (-32602) + + it "rejects an answer that is not an elicitation result" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + r2 <- call env "deploy" formCaps $ + answer "0" (object ["roots" .= ([] :: [Value])]) : retrying r1 + fmap fst (errorOf r2) `shouldBe` Just (-32602) + + it "completes without state when nothing is asked" $ do + result <- runAsk (step (pure (42 :: Int))) anonymousContext + result `shouldBe` Right (Complete 42) + + it "fails a run whose journal belongs to a different handler" $ do + env <- newCounters + Right (InputRequired _ journal) <- runAsk (deploy (fst env)) anonymousContext + { clientProtocolVersion = Just "2026-07-28" + , clientCapabilities = Just formCaps + } + result <- runAsk (step (pure (1 :: Int))) anonymousContext { clientRequestState = journal } + case result of + Left (InternalError msg) -> msg `shouldSatisfy` T.isInfixOf "position 0" + other -> expectationFailure ("expected a mismatch, got " ++ show other) + + it "keeps the pending question's key stable across unrelated rounds" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + let unrelated = answer "1" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1 + r2 <- call env "deploy" formCaps unrelated + questionsOf r2 `shouldBe` [("0", String "Where to?")] + + it "replays a step whose result is null" $ do + env <- newCounters + r1 <- call env "null" formCaps [] + questionsOf r1 `shouldBe` [("1", String "Still there?")] + r2 <- call env "null" formCaps $ answer "1" (accepted ["ok" .= True]) : retrying r1 + textOf r2 `shouldBe` Just (String "(Nothing,Accepted (Confirm {ok = True}),2)") + + it "settles a pending question as Unavailable when the client can no longer ask" $ do + env <- newCounters + r1 <- call env "deploy" formCaps [] + r2 <- call env "deploy" noCaps (retrying r1) + textOf r2 `shouldBe` Just (String "no target: Unavailable") + r3 <- call env "null" formCaps [] + r4 <- call env "null" noCaps (retrying r3) + textOf r4 `shouldBe` Just (String "(Nothing,Unavailable,2)") diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -9,53 +9,40 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes import TestData -- Generate handlers using Template Haskell -testPromptHandlers :: (PromptListHandler IO, PromptGetHandler IO) +testPromptHandlers :: (PromptListHandler, PromptGetHandler) testPromptHandlers = $(derivePromptHandler ''TestPrompt 'handleTestPrompt) -testResourceHandlers :: (ResourceListHandler IO, ResourceReadHandler IO) +testResourceHandlers :: (ResourceListHandler, ResourceReadHandler) testResourceHandlers = $(deriveResourceHandler ''TestResource 'handleTestResource) -testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlers :: (ToolListHandler, ToolCallHandler) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) --- Helper functions for common test patterns -shouldReturnContentText :: IO (Either Error Content) -> Text -> IO () -shouldReturnContentText action expected = do - result <- action - case result of - Right (ContentText content) -> content `shouldBe` expected - other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other - -shouldContainText :: IO (Either Error Content) -> Text -> IO () -shouldContainText action expectedSubstring = do - result <- action - case result of - Right (ContentText content) -> - T.isInfixOf expectedSubstring content `shouldBe` True - other -> expectationFailure $ "Expected ContentText containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other - -testPromptCall :: PromptGetHandler IO -> Text -> [(Text, Text)] -> Text -> IO () -testPromptCall handler name args expected = - shouldReturnContentText (handler anonCtx name args) expected +testPromptCall :: PromptGetHandler -> Text -> [(Text, Text)] -> Text -> IO () +testPromptCall handler name args expected = do + result <- handler anonCtx name (promptArgsMap args) + result `shouldBePromptText` expected -testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO () +testResourceCall :: ResourceReadHandler -> String -> Text -> IO () testResourceCall handler uriString expected = do case parseURI uriString of Just uri -> do result <- handler anonCtx uri - case result of + case completed result of Right (ResourceText _ _ content) -> content `shouldBe` expected Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob" Left err -> expectationFailure $ "Expected success but got error: " ++ show err Nothing -> expectationFailure $ "Failed to parse URI: " ++ uriString -testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO () -testToolCall handler name args expected = - shouldReturnContentText (handler anonCtx name args) expected +testToolCall :: ToolCallHandler -> Text -> [(Text, Text)] -> Text -> IO () +testToolCall handler name args expected = do + result <- handler anonCtx name (stringArgs args) + result `shouldBeTextResult` expected spec :: Spec spec = describe "Basic Template Haskell Derivation" $ do @@ -77,7 +64,7 @@ if useSubstringMatch testCase then do result <- readHandler anonCtx uri - case result of + case completed result of Right (ResourceText _ _ content) -> T.isInfixOf (resourceExpectedContent testCase) content `shouldBe` True Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob" diff --git a/test/Spec/Cancellation.hs b/test/Spec/Cancellation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Cancellation.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for the cancellation contract (ADR 0008): a request task +-- cancelled mid-handler stops emitting, never produces a response, and +-- releases bracket-acquired resources. The transports build on exactly +-- this shape (an 'async' around 'handleMcpMessage' that 'cancel' +-- interrupts), so the properties verified here are the ones the wire +-- behavior depends on. +module Spec.Cancellation (spec) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, cancel, waitCatch) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (bracket_) +import Data.Aeson +import Data.IORef +import Data.Text (Text) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) + +-- A slow tools/call carrying a progressToken (so emissions are live), +-- driven from an async that the test cancels once the handler body signals +-- it is ready: the body gets the signal as an action, and calls it once it +-- has reached the point the test is about (inside a bracket, say), so +-- cancellation cannot arrive earlier. +runCancelled :: (IO () -> ClientContext -> IO ()) -> IO [JsonRpcNotification] +runCancelled handlerBody = do + sink <- newIORef [] + started <- newEmptyMVar + responded <- newIORef False + let handlers = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx _ _ -> do + reportProgress ctx 0 (Just 1) Nothing + handlerBody (putMVar started ()) ctx + pure $ Right $ Complete $ toToolResult ("done" :: Text) + ) + } + params = object + [ "name" .= ("slow" :: Text) + , "arguments" .= object [] + , "_meta" .= object ["progressToken" .= ("t" :: Text)] + ] + task <- async $ do + resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec + noNotificationSupport (\n -> modifyIORef' sink (++ [n])) + handlers anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params))) + case resp of + Just _ -> writeIORef responded True + Nothing -> pure () + takeMVar started + cancel task -- waits for the task to finish + _ <- waitCatch task + readIORef responded `shouldReturn` False + readIORef sink + +spec :: Spec +spec = describe "Cancellation contract" $ do + + it "a cancelled handler stops emitting and never yields a response" $ do + lateEmit <- newIORef False + ns <- runCancelled $ \ready ctx -> do + ready + threadDelay 5000000 + writeIORef lateEmit True + reportProgress ctx 1 (Just 1) Nothing + -- only the pre-cancellation progress made it out + map notificationMethod ns `shouldBe` ["notifications/progress"] + readIORef lateEmit `shouldReturn` False + + it "bracket releases handler resources on cancellation" $ do + acquired <- newIORef False + released <- newIORef False + _ <- runCancelled $ \ready _ -> + bracket_ (writeIORef acquired True) (writeIORef released True) $ do + ready + threadDelay 5000000 + readIORef acquired `shouldReturn` True + readIORef released `shouldReturn` True diff --git a/test/Spec/DefinitionMetadata.hs b/test/Spec/DefinitionMetadata.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DefinitionMetadata.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for definition metadata (ADR 0006): tool annotations, icons, +-- content annotations, and the options-based derive customization. +module Spec.DefinitionMetadata (spec) where + +import Data.Aeson +import Data.Text (Text) +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes + +annotatedToolHandlers :: (ToolListHandler, ToolCallHandler) +annotatedToolHandlers = $(deriveToolHandlerWithOptions ''TestTool 'handleTestTool + [ ("Echo", defaultDefinitionOptions + { optDescription = Just "Echoes the input" + , optTitle = Just "Echo" + , optIcons = [icon "https://example.com/echo.png"] + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + , optFieldDescriptions = [("text", "What to echo")] + }) + , ("Calculate", defaultDefinitionOptions + { optFieldDescriptions = [("x", "Calculate's first operand")] + }) + ]) + +toolNamed :: Text -> [ToolDefinition] -> ToolDefinition +toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of + (d:_) -> d + [] -> error $ "tool not found: " ++ show n + +propDescription :: Text -> ToolDefinition -> Maybe Text +propDescription name def = case schemaShape (toolDefinitionInputSchema def) of + SchemaObject props _ -> lookup name props >>= schemaDescription + _ -> Nothing + +spec :: Spec +spec = describe "Definition metadata" $ do + + describe "JSON shapes" $ do + it "serializes tool annotations with only the set hints" $ do + toJSON defaultToolAnnotations { toolReadOnlyHint = Just True } `shouldBe` + object ["readOnlyHint" .= True] + + it "serializes icons, omitting empty optional fields" $ do + toJSON (icon "https://example.com/i.png") `shouldBe` + object ["src" .= ("https://example.com/i.png" :: Text)] + toJSON (Icon "u" (Just "image/png") ["48x48"]) `shouldBe` + object ["src" .= ("u" :: Text), "mimeType" .= ("image/png" :: Text), "sizes" .= (["48x48"] :: [Text])] + + it "merges content annotations into the inner block" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.8 } + toJSON (ContentAnnotated anns (ContentText "hi")) `shouldBe` + object [ "type" .= ("text" :: Text), "text" .= ("hi" :: Text) + , "annotations" .= object ["audience" .= (["user"] :: [Text]), "priority" .= (0.8 :: Double)] + ] + + it "round-trips annotated content through FromJSON" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleAssistant] } + c = ContentAnnotated anns (ContentText "hello") + decode (encode c) `shouldBe` Just c + + it "round-trips resource links carrying icons" $ do + let def = (mkResourceDefinition "resource://x" "x") + { resourceDefinitionIcons = [Icon "https://example.com/x.png" (Just "image/png") ["48x48"]] } + c = ContentResourceLink def + decode (encode c) `shouldBe` Just c + + describe "Options-based derivation" $ do + it "carries description, title, icons and annotations on the definition" $ do + defs <- fst annotatedToolHandlers anonCtx + let echoDef = toolNamed "echo" defs + toolDefinitionDescription echoDef `shouldBe` "Echoes the input" + toolDefinitionTitle echoDef `shouldBe` Just "Echo" + toolDefinitionIcons echoDef `shouldBe` [icon "https://example.com/echo.png"] + toolDefinitionAnnotations echoDef `shouldBe` Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + + it "leaves uncustomized constructors bare (constructor-name description)" $ do + defs <- fst annotatedToolHandlers anonCtx + let toggleDef = toolNamed "toggle" defs + toolDefinitionDescription toggleDef `shouldBe` "Toggle" + toolDefinitionAnnotations toggleDef `shouldBe` Nothing + toolDefinitionIcons toggleDef `shouldBe` [] + + it "scopes field descriptions to their constructor" $ do + defs <- fst annotatedToolHandlers anonCtx + -- 'text' described only on Echo; 'x' described only on Calculate + propDescription "text" (toolNamed "echo" defs) `shouldBe` Just "What to echo" + propDescription "x" (toolNamed "calculate" defs) `shouldBe` Just "Calculate's first operand" + -- Echo's options must not leak onto Calculate's same-named args + propDescription "operation" (toolNamed "calculate" defs) `shouldBe` Just "operation" + + it "still dispatches calls unchanged" $ do + result <- snd annotatedToolHandlers anonCtx "echo" mempty + case result of + Left (MissingRequiredParams msg) -> show msg `shouldContain` "text" + other -> expectationFailure $ "expected missing-params error, got: " ++ show other diff --git a/test/Spec/DerivedAsk.hs b/test/Spec/DerivedAsk.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DerivedAsk.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for the derived interface of multi round-trip requests (ADR +-- 0009, phase 3): derived forms, and derived handlers that return 'Ask'. +module Spec.DerivedAsk (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import MCP.Server +import MCP.Server.Derive +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) + +import AskTypes + +handlers :: McpServerHandlers +handlers = noHandlers + { tools = Just $(deriveToolHandler ''OpsTool 'handleOps) + , prompts = Just $(derivePromptHandler ''OpsPrompt 'handlePrompt) + , resources = Just $(deriveResourceHandler ''OpsResource 'handleResource) + } + +ioTools :: (ToolListHandler, ToolCallHandler) +ioTools = $(deriveToolHandler ''OpsTool 'handleOpsIO) + +request :: McpServerHandlers -> Text -> Value -> [Pair] -> IO Value +request hs method caps params = do + response <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec + noNotificationSupport (\_ -> pure ()) hs anonymousContext $ + JsonRpcMessageRequest JsonRpcRequest + { requestJsonrpc = "2.0" + , requestId = RequestIdNumber 1 + , requestMethod = method + , requestParams = Just $ object $ params ++ + [ "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientCapabilities" .= caps + ] + ] + } + case response of + Just (JsonRpcMessageResponse r) -> pure (toJSON r) + other -> fail ("expected a response, got " ++ show other) + +formCaps, noCaps :: Value +formCaps = object ["elicitation" .= object ["form" .= object []]] +noCaps = object [] + +at :: [Key] -> Value -> Maybe Value +at [] v = Just v +at (k : ks) (Object o) = KM.lookup k o >>= at ks +at _ _ = Nothing + +-- | The single request of an @input_required@ result: its key and params. +questionOf :: Value -> Maybe (Key, Value) +questionOf v = case at ["result", "inputRequests"] v of + Just (Object rs) | [(k, r)] <- KM.toList rs -> (,) k <$> at ["params"] r + _ -> Nothing + +-- | The params of a retry answering the given result's question. +answering :: Value -> [Pair] -> [Pair] +answering previous content = case (questionOf previous, at ["result", "requestState"] previous) of + (Just (key, _), Just st) -> + [ "inputResponses" .= object [key .= object ["action" .= ("accept" :: Text), "content" .= object content]] + , "requestState" .= st + ] + _ -> error ("not an input_required result: " ++ show previous) + +firstText :: Value -> Maybe Value +firstText v = case at ["result", "content"] v of + Just (Array xs) | (c : _) <- foldr (:) [] xs -> at ["text"] c + _ -> case at ["result", "messages"] v of + Just (Array xs) | (m : _) <- foldr (:) [] xs -> at ["content", "text"] m + _ -> case at ["result", "contents"] v of + Just (Array xs) | (c : _) <- foldr (:) [] xs -> at ["text"] c + _ -> Nothing + +callDeploy :: [Pair] -> [Pair] +callDeploy extra = ["name" .= ("deploy" :: Text), "arguments" .= object ["service" .= ("billing" :: Text)]] ++ extra + +spec :: Spec +spec = describe "Derived handlers that ask" $ do + describe "deriveForm" $ do + it "derives a flat schema from a record" $ + toJSON (formSchema (Proxy :: Proxy DeployTarget)) `shouldBe` object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "environment" .= object ["type" .= ("string" :: Text), "enum" .= (["staging", "production"] :: [Text])] + , "reason" .= object ["type" .= ("string" :: Text), "description" .= ("Why deploy now?" :: Text)] + , "notify" .= object ["type" .= ("boolean" :: Text)] + , "replicas" .= object ["type" .= ("integer" :: Text)] + , "tags" .= object + [ "type" .= ("array" :: Text) + , "items" .= object ["type" .= ("string" :: Text), "enum" .= (["urgent", "routine"] :: [Text])] + ] + , "ticket" .= object ["type" .= ("string" :: Text)] + ] + , "required" .= (["environment", "reason", "replicas", "tags"] :: [Text]) + ] + + it "adds titles and defaults from the options" $ + toJSON (formSchema (Proxy :: Proxy Styled)) `shouldBe` object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "size" .= object ["type" .= ("number" :: Text), "title" .= ("Size" :: Text), "default" .= (1.5 :: Double)] + , "label" .= object ["type" .= ("string" :: Text)] + , "mode" .= object + [ "type" .= ("string" :: Text), "enum" .= (["staging", "production"] :: [Text]) + , "default" .= ("production" :: Text), "description" .= ("Where" :: Text) + ] + ] + , "required" .= (["size", "label", "mode"] :: [Text]) + ] + + it "parses submitted content" $ + formParse (Map.fromList + [ ("environment", "production"), ("reason", "hotfix"), ("replicas", Number 3) + , ("tags", toJSON ["urgent" :: Text]), ("ticket", "OPS-1") ]) + `shouldBe` Right (DeployTarget Production "hotfix" Nothing 3 [Urgent] (Just (Ticket "OPS-1"))) + + it "names the field when content does not fit" $ + (formParse (Map.fromList [("proceed", "maybe")]) :: Either Text Confirm) + `shouldBe` Left "field 'proceed': Failed to parse Bool from: maybe" + + it "rejects types a form cannot hold at compile time" $ do + rejectedNested `shouldBe` True + rejectedTextList `shouldBe` True + rejectedUnit `shouldBe` True + rejectedUnknownField `shouldBe` True + rejectedBadDefault `shouldBe` True + rejectedBadChoice `shouldBe` True + rejectedFractionalInt `shouldBe` True + rejectedOutOfRangeInt `shouldBe` True + + it "keeps whole-number and non-ASCII defaults intact" $ + toJSON (formSchema (Proxy :: Proxy Counted)) `shouldBe` object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "count" .= object ["type" .= ("integer" :: Text), "default" .= (3 :: Int)] + , "greeting" .= object ["type" .= ("string" :: Text), "default" .= ("café 東京" :: Text)] + ] + , "required" .= (["count", "greeting"] :: [Text]) + ] + + describe "derive*Handler with Ask" $ do + it "runs a derived tool across rounds" $ do + r1 <- request handlers "tools/call" formCaps (callDeploy []) + fmap fst (questionOf r1) `shouldBe` Just "0" + fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Where should billing deploy to?") + fmap (at ["requestedSchema", "required"] . snd) (questionOf r1) + `shouldBe` Just (Just (toJSON (["environment", "reason", "replicas", "tags"] :: [Text]))) + r2 <- request handlers "tools/call" formCaps $ callDeploy $ answering r1 + [ "environment" .= ("staging" :: Text), "reason" .= ("fix" :: Text) + , "replicas" .= (2 :: Int), "tags" .= ([] :: [Text]) ] + fmap (at ["message"] . snd) (questionOf r2) `shouldBe` Just (Just "Apply Staging x2?") + r3 <- request handlers "tools/call" formCaps $ callDeploy $ answering r2 ["proceed" .= True] + firstText r3 `shouldBe` Just "deployed billing: Staging x2" + + it "answers a tool that never asks in one round" $ do + r <- request handlers "tools/call" formCaps + ["name" .= ("status" :: Text), "arguments" .= object ["service" .= ("billing" :: Text)]] + firstText r `shouldBe` Just "billing is up" + + it "falls back without a round trip when the client cannot ask" $ do + r <- request handlers "tools/call" noCaps (callDeploy []) + firstText r `shouldBe` Just "no target: Unavailable" + + it "still derives IO handlers" $ do + r <- request noHandlers { tools = Just ioTools } "tools/call" formCaps (callDeploy []) + firstText r `shouldBe` Just "deployed billing" + + it "asks from a handler with structured output" $ do + let hs = noHandlers { tools = Just outputTools } + r1 <- request hs "tools/call" formCaps (callDeploy []) + fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Go?") + r2 <- request hs "tools/call" formCaps $ callDeploy $ answering r1 ["proceed" .= True] + at ["result", "structuredContent"] r2 `shouldBe` Just (object ["deployed" .= True]) + + it "asks from a derived prompt" $ do + let get extra = request handlers "prompts/get" formCaps $ + ["name" .= ("briefing" :: Text), "arguments" .= object ["team" .= ("ops" :: Text)]] ++ extra + r1 <- get [] + fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Include incidents for ops?") + r2 <- get (answering r1 ["proceed" .= True]) + firstText r2 `shouldBe` Just "briefing with incidents" + + it "asks from a derived resource" $ do + let readIt extra = request handlers "resources/read" formCaps $ + ["uri" .= ("resource://secrets" :: Text)] ++ extra + r1 <- readIt [] + fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Reveal secrets?") + r2 <- readIt (answering r1 ["proceed" .= False]) + firstText r2 `shouldBe` Just "hidden" diff --git a/test/Spec/DerivedOutput.hs b/test/Spec/DerivedOutput.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DerivedOutput.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for derived structured output (ADR 0005): the outputSchema +-- generated from a result record, and the ToolOutput result forms. +module Spec.DerivedOutput (spec) where + +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestHelpers +import TestTypes + +weatherHandlers :: (ToolListHandler, ToolCallHandler) +weatherHandlers = $(deriveToolHandlerWithOutputDescription ''WeatherTool 'handleWeatherTool ''WeatherReport + [ ("GetWeather", "Current weather"), ("wrTemperature", "Degrees Celsius") ]) + +callWeather :: Text -> [(Text, Value)] -> IO (Either Error (Outcome ToolResult)) +callWeather name args = snd weatherHandlers anonCtx name (valueArgs args) + +-- The serialized form the derivation guarantees for 'sampleReport' +expectedReport :: Text -> Maybe Int -> Value +expectedReport place humidity = object $ + [ "wrTemperature" .= (21 :: Int) + , "wrSky" .= ("sky_cloudy" :: Text) + , "wrWind" .= object ["windSpeedKph" .= (12.5 :: Double), "windGusting" .= False] + , "wrAlerts" .= (["wind advisory for " <> place] :: [Text]) + ] ++ maybe [] (\h -> ["wrHumidity" .= h]) humidity + +spec :: Spec +spec = describe "Derived structured output" $ do + + describe "outputSchema derivation" $ do + it "every tool of the splice carries the output record's object schema" $ do + defs <- fst weatherHandlers anonCtx + map toolDefinitionName defs `shouldBe` + ["get_weather", "broken_station", "custom_report", "plain_forecast"] + case map toolDefinitionOutputSchema defs of + (s:rest) -> do + s `shouldSatisfy` (/= Nothing) + all (== s) rest `shouldBe` True + [] -> expectationFailure "no tools derived" + + it "mirrors field types: enum, nested record, list, optional Maybe" $ do + defs <- fst weatherHandlers anonCtx + case defs of + [] -> expectationFailure "no tools derived" + (d:_) -> case toolDefinitionOutputSchema d of + Nothing -> expectationFailure "outputSchema missing" + Just s -> do + schemaRequired s `shouldBe` ["wrTemperature", "wrSky", "wrWind", "wrAlerts"] + fmap schemaTypeName (lookup "wrSky" (schemaProps s)) `shouldBe` Just "string" + fmap schemaShape (lookup "wrSky" (schemaProps s)) `shouldBe` + Just (SchemaString (Just ["sky_clear", "sky_cloudy", "sky_raining"])) + fmap schemaTypeName (lookup "wrWind" (schemaProps s)) `shouldBe` Just "object" + fmap schemaTypeName (lookup "wrAlerts" (schemaProps s)) `shouldBe` Just "array" + fmap schemaDescription (lookup "wrTemperature" (schemaProps s)) `shouldBe` + Just (Just "Degrees Celsius") + + describe "ToolOutput results" $ do + it "serializes the typed value into structuredContent with a matching text block" $ do + result <- callWeather "get_weather" [("wtCity", String "Cape Town")] + case completed result of + Right tr -> do + toolResultIsError tr `shouldBe` False + toolResultStructured tr `shouldBe` Just (expectedReport "Cape Town" (Just 60)) + case toolResultContent tr of + [ContentText t] -> + decode (BSL.fromStrict (TE.encodeUtf8 t)) `shouldBe` + Just (expectedReport "Cape Town" (Just 60)) + other -> expectationFailure $ "expected one text block, got: " ++ show other + Left err -> expectationFailure $ "expected result, got error: " ++ show err + + it "renders the text block canonically (sorted keys, build-plan independent)" $ do + result <- callWeather "get_weather" [("wtCity", String "Cape Town")] + case completed result of + Right tr -> toolResultContent tr `shouldBe` + [ContentText "{\"wrAlerts\":[\"wind advisory for Cape Town\"],\"wrHumidity\":60,\"wrSky\":\"sky_cloudy\",\"wrTemperature\":21,\"wrWind\":{\"windGusting\":false,\"windSpeedKph\":12.5}}"] + Left err -> expectationFailure $ "expected result, got error: " ++ show err + + it "omits Nothing fields from the serialized value" $ do + result <- callWeather "custom_report" [("wtRegion", String "Karoo")] + case completed result of + Right tr -> toolResultStructured tr `shouldBe` Just (expectedReport "Karoo" Nothing) + Left err -> expectationFailure $ "expected result, got error: " ++ show err + + it "keeps caller-supplied content blocks with ToolOutputWith" $ do + result <- callWeather "custom_report" [("wtRegion", String "Karoo")] + case completed result of + Right tr -> toolResultContent tr `shouldBe` [ContentText "Report for Karoo"] + Left err -> expectationFailure $ "expected result, got error: " ++ show err + + it "reports ToolOutputError as an isError result" $ do + result <- callWeather "broken_station" [("wtStation", String "X1")] + case completed result of + Right tr -> do + toolResultIsError tr `shouldBe` True + toolResultStructured tr `shouldBe` Nothing + toolResultContent tr `shouldBe` [ContentText "station offline: X1"] + Left err -> expectationFailure $ "expected isError result, got: " ++ show err + + it "passes ToolOutputRaw through untouched" $ do + result <- callWeather "plain_forecast" [("wtNote", String "sunny")] + case completed result of + Right tr -> do + toolResultStructured tr `shouldBe` Nothing + toolResultContent tr `shouldBe` [ContentText "sunny"] + Left err -> expectationFailure $ "expected result, got error: " ++ show err diff --git a/test/Spec/GoldenWire.hs b/test/Spec/GoldenWire.hs new file mode 100644 --- /dev/null +++ b/test/Spec/GoldenWire.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Golden wire-format conformance corpus: @test/golden/@ holds, per case, +-- a JSON-RPC request (@\.request.json@) and the reference server's +-- exact response (@\.response.json@), enumerated by +-- @test/golden/manifest.json@. This spec replays every request through +-- 'handleMcpMessage' and compares the response against the fixture. +-- +-- The corpus is deliberately API-agnostic — request and response are plain +-- wire bytes, so any MCP implementation that reproduces the reference +-- server described in @test/golden/README.md@ can consume it. Within this +-- library it pins two promises: the legacy fixtures were generated from +-- @main@ at v0.2.0 (commit @7bd1bcc@), anchoring "dual-era support leaves +-- legacy responses unchanged", and the modern fixtures pin the 2026-07-28 +-- envelope. +-- +-- Responses are compared as parsed 'Value's, not raw bytes: aeson's object +-- key order depends on the aeson\/hashable versions in the build plan, which +-- vary across the CI matrix, while 'Value' equality is stable and still +-- catches every added, removed, renamed or changed field. +-- +-- To add a case: write the @.request.json@ by hand, add its manifest entry, +-- and run the suite with @GOLDEN_ACCEPT=1@ — a missing response fixture is +-- then written from the current output. Existing fixtures are never +-- overwritten — delete one first to regenerate it, and never regenerate the +-- legacy fixtures from a branch that intends to keep legacy output +-- unchanged. +module Spec.GoldenWire (spec) where + +import Control.Monad (forM_) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (toList) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) +import Test.Hspec +import TestHelpers (testStateCodec) + +goldenServerInfo :: McpServerInfo +goldenServerInfo = McpServerInfo + { serverName = "Golden Server" + , serverVersion = "1.0.0" + , serverInstructions = "Golden fixture server" + } + +-- Deterministic manual handlers (no Template Haskell): one prompt, one +-- resource, one happy tool, one failing tool. Documented for external +-- consumers in test/golden/README.md — keep the two in sync. +goldenHandlers :: McpServerHandlers +goldenHandlers = noHandlers + { prompts = Just (promptList, promptGet) + , resources = Just (resourceList, resourceRead) + , tools = Just (toolList, toolCall) + } + where + promptList _ = pure + [ mkPromptDefinition "greet" "Greet someone" + [ArgumentDefinition "name" "Who to greet" True] + ] + promptGet _ name args = case name of + "greet" -> pure $ Right $ Complete $ PromptResult (Just "A greeting") + [PromptMessage RoleUser (ContentText ("Hello, " <> Map.findWithDefault "?" "name" args <> "!"))] + _ -> pure $ Left $ InvalidPromptName name + + resourceList _ = pure + [ (mkResourceDefinition "resource://info" "info") + { resourceDefinitionDescription = Just "Some info" + , resourceDefinitionMimeType = Just "text/plain" + } + ] + resourceRead _ uri + | show uri == "resource://info" = pure $ Right $ Complete $ ResourceText uri "text/plain" "The golden info" + | otherwise = pure $ Left $ ResourceNotFound $ T.pack $ show uri + + toolList _ = pure + [ mkToolDefinition "echo" "Echo the text" + (Schema Nothing (SchemaObject + [("text", Schema (Just "The text") (SchemaString Nothing))] ["text"])) + ] + toolCall _ name args = case name of + "echo" -> case Map.lookup "text" args of + Just (String t) -> pure $ Right $ Complete $ toolResult [ContentText ("echo: " <> t)] + _ -> pure $ Left $ MissingRequiredParams "field 'text' is missing" + "boom" -> pure $ Right $ Complete $ toolError "kaboom" + _ -> pure $ Left $ UnknownTool name + +-- The extended set's structured-output tool, derived so the corpus pins +-- exactly what the TH derivation puts on the wire (ADR 0005). The field +-- selectors are intentionally unused: the generated serializer binds +-- fields by pattern-matching. +data GoldenEchoOutput = GoldenEchoOutput + { echoedText :: Text + , echoedLength :: Int + } + + +data GoldenStructTool = EchoStructured { input :: Text } + +-- Selector uses, so -Wunused-top-binds stays quiet +_selectors :: (GoldenEchoOutput -> Text, GoldenEchoOutput -> Int, GoldenStructTool -> Text) +_selectors = (echoedText, echoedLength, input) + +goldenStructHandler :: ClientContext -> GoldenStructTool -> IO (ToolOutput GoldenEchoOutput) +goldenStructHandler _ (EchoStructured t) = + pure $ ToolOutput (GoldenEchoOutput t (T.length t)) + +-- The extended set's annotated tool (ADR 0006): read-only hints, icon and +-- title on the definition; annotated content on the result +data GoldenAnnotatedTool = AnnotatedProbe { probe :: Text } + +goldenAnnotatedHandler :: ClientContext -> GoldenAnnotatedTool -> IO ToolResult +goldenAnnotatedHandler _ (AnnotatedProbe p) = pure $ toolResult + [ ContentAnnotated + defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.5 } + (ContentText ("probed: " <> p)) + ] + +$(pure []) + +structuredTools :: (ToolListHandler, ToolCallHandler) +structuredTools = $(deriveToolHandlerWithOutputDescription + ''GoldenStructTool 'goldenStructHandler ''GoldenEchoOutput + [ ("EchoStructured", "Echo with structured output") + , ("input", "The text") + , ("echoedText", "The echoed text") + , ("echoedLength", "Its length") + ]) + +annotatedTools :: (ToolListHandler, ToolCallHandler) +annotatedTools = $(deriveToolHandlerWithOptions + ''GoldenAnnotatedTool 'goldenAnnotatedHandler + [ ("AnnotatedProbe", defaultDefinitionOptions + { optDescription = Just "A read-only probe" + , optTitle = Just "Probe" + , optIcons = [icon "https://example.com/probe.png"] + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + , optFieldDescriptions = [("probe", "What to probe")] + }) + ]) + +-- | 'goldenHandlers' extended with the handler slots and tools introduced +-- after v0.2.0. Used only for the fixtures of methods/behaviors that +-- postdate the legacy anchor: extending the main handler set would change +-- the advertised capabilities and perturb the v0.2.0-anchored initialize +-- fixture. +extendedHandlers :: McpServerHandlers +extendedHandlers = goldenHandlers + { resourceTemplates = Just $ \_ -> pure + [ (mkResourceTemplateDefinition "resource://item/{itemId}" "item") + { resourceTemplateDescription = Just "An item" + , resourceTemplateMimeType = Just "text/plain" + } + ] + , completions = Just $ \_ _ref _arg partial _ctx -> pure $ Right $ + completionResult (filter (T.isPrefixOf partial) ["alpha", "beta"]) + , tools = do + (baseList, baseCall) <- tools goldenHandlers + let (sList, sCall) = structuredTools + (aList, aCall) = annotatedTools + pure ( \c -> concat <$> sequence [baseList c, sList c, aList c] + , \c n a -> case n of + "echo_structured" -> sCall c n a + "annotated_probe" -> aCall c n a + _ -> baseCall c n a + ) + } + +-- | 'goldenHandlers' with one tool that asks for input (multi round-trip +-- requests): @confirm@ asks for a boolean @ok@ under the key @proceed@, +-- with a request state, until it receives an answer. +mrtrHandlers :: McpServerHandlers +mrtrHandlers = goldenHandlers + { tools = Just + ( \_ -> pure [] + , \ctx _name _args -> pure $ Right $ + case Map.lookup "proceed" (clientInputResponses ctx) of + Nothing -> InputRequired + (Map.singleton "proceed" (ElicitForm "Proceed?" + (schema (SchemaObject [("ok", schema SchemaBoolean)] ["ok"])))) + (Just "confirming") + Just _ -> Complete (toolResult [ContentText "confirmed"]) + ) + } + +-- | A fixture value of @""@ matches any string: used for values a +-- server generates afresh, such as a sealed @requestState@. Returns the +-- actual value with those strings replaced, ready for an equality check. +matchOpaque :: Value -> Value -> Value +matchOpaque (String "") (String _) = String "" +matchOpaque (Object f) (Object a) = Object (KM.mapWithKey (\k v -> maybe v (`matchOpaque` v) (KM.lookup k f)) a) +matchOpaque (Array f) (Array a) | length f == length a = toJSON (zipWith matchOpaque (toList f) (toList a)) +matchOpaque _ actual = actual + +-- | One manifest entry: which case, and which reference-server variant +-- answers it. +data GoldenCase = GoldenCase + { caseName :: FilePath + , caseHandlers :: Text -- ^ "base", "extended" or "mrtr" + , caseNotifications :: Bool + } + +instance FromJSON GoldenCase where + parseJSON = withObject "GoldenCase" $ \o -> GoldenCase + <$> o .: "name" + <*> o .: "handlers" + <*> o .: "notifications" + +newtype Manifest = Manifest [GoldenCase] + +instance FromJSON Manifest where + parseJSON = withObject "Manifest" $ \o -> Manifest <$> o .: "cases" + +-- | The corpus enumeration, read while hspec constructs the spec tree. +loadManifest :: IO [GoldenCase] +loadManifest = do + bytes <- BSL.readFile "test/golden/manifest.json" + case eitherDecode bytes of + Left err -> fail ("test/golden/manifest.json does not parse: " ++ err) + Right (Manifest cs) -> pure cs + +runCase :: GoldenCase -> BSL.ByteString -> IO Value +runCase gc raw = do + jsonValue <- either (fail . ("request does not parse: " ++)) pure (eitherDecode raw) + message <- either (fail . ("request is not JSON-RPC: " ++)) pure (parseJsonRpcMessage jsonValue) + let handlers = case caseHandlers gc of + "extended" -> extendedHandlers + "mrtr" -> mrtrHandlers + _ -> goldenHandlers + support = if caseNotifications gc + then NotificationSupport { supportsLegacyPush = True, supportsListen = True } + else noNotificationSupport + maybeResponse <- handleMcpMessage goldenServerInfo defaultCacheHints testStateCodec support (\_ -> pure ()) handlers anonymousContext message + case maybeResponse of + Just responseMsg -> pure $ encodeJsonRpcMessage responseMsg + Nothing -> fail "expected a response" + +goldenCase :: GoldenCase -> Spec +goldenCase gc = + it (caseName gc) $ do + let requestPath = "test/golden/" ++ caseName gc ++ ".request.json" + responsePath = "test/golden/" ++ caseName gc ++ ".response.json" + raw <- BSL.readFile requestPath + actual <- runCase gc raw + exists <- doesFileExist responsePath + accept <- lookupEnv "GOLDEN_ACCEPT" + if not exists && accept /= Nothing + then BSL.writeFile responsePath (encode actual) + else do + fixtureBytes <- BSL.readFile responsePath + case eitherDecode fixtureBytes :: Either String Value of + Left err -> expectationFailure $ "fixture does not parse: " ++ err + Right fixture -> matchOpaque fixture actual `shouldBe` fixture + +spec :: Spec +spec = describe "Golden wire-format fixtures" $ do + cases <- runIO loadManifest + forM_ cases goldenCase 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,55 @@ +{-# 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 +import TestHelpers (testStateCodec) + +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 testStateCodec + 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,178 @@ +{-# 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 qualified Data.Text.Encoding as TE +import MCP.Server +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import Network.Wai.Internal (ResponseReceived (..)) +import Test.Hspec +import TestHelpers (testStateCodec) +import qualified Data.Map as Map + +server :: McpServerHandlers +server = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx name _ -> case name of + "boom" -> throwIO (ErrorCall "tool exploded") + "ok" -> pure $ Right $ Complete $ toToolResult ("fine" :: Text) + "ask" -> pure $ Right $ case Map.lookup "q" (clientInputResponses ctx) of + Nothing -> InputRequired + (Map.singleton "q" (ElicitForm "Sure?" (schema (SchemaObject [] [])))) + (Just "asked") + Just _ -> Complete $ toToolResult + ("answered after " <> maybe "nothing" id (clientRequestState ctx)) + _ -> pure $ Left $ UnknownTool name + ) + } + +app :: IO Wai.Application +app = mcpApplication defaultHttpConfig + { httpAllowedOrigins = Nothing + , httpStateCodec = Just testStateCodec -- shared across 'post's + } + (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 + application <- app + _ <- application 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) + +-- | A modern tools/call of the "ask" tool, with extra params. +askCall :: [(Key, Value)] -> Value +askCall extra = object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (8 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" .= object ( + [ "name" .= ("ask" :: Text) + , "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientCapabilities" .= object ["elicitation" .= object []] + ] + ] ++ extra) + ] + +modernHeaders :: Text -> [HTTP.Header] +modernHeaders name = + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", TE.encodeUtf8 name) + ] + +resultIn :: BS.ByteString -> Maybe Object +resultIn raw = do + Object o <- decodeStrict raw + Object r <- KM.lookup "result" o + pure r + +spec :: Spec +spec = describe "HTTP transport (in-process WAI)" $ do + it "carries a multi round-trip request across two POSTs" $ do + (status1, _, body1) <- post (modernHeaders "ask") (askCall []) + HTTP.statusCode status1 `shouldBe` 200 + let first = resultIn body1 + (first >>= KM.lookup "resultType") `shouldBe` Just (String "input_required") + Just (String sealed) <- pure (first >>= KM.lookup "requestState") + (status2, _, body2) <- post (modernHeaders "ask") $ askCall + [ "inputResponses" .= object ["q" .= object ["action" .= ("accept" :: Text), "content" .= object []]] + , "requestState" .= sealed + ] + HTTP.statusCode status2 `shouldBe` 200 + body2 `shouldSatisfy` ("answered after asked" `BS.isInfixOf`) + + 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`)) diff --git a/test/Spec/InputRequired.hs b/test/Spec/InputRequired.hs new file mode 100644 --- /dev/null +++ b/test/Spec/InputRequired.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for multi round-trip requests (ADR 0009, phase 1): the +-- request-state codec, and dispatch of 'InputRequired' outcomes — the +-- @input_required@ result, verified retries, and every way a retry's state +-- is rejected. +module Spec.InputRequired (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) + +-- | A tool that asks for confirmation, then reports what it was given. +confirmTool :: ToolCallHandler +confirmTool ctx _name args = pure $ Right $ + case Map.lookup "proceed" (clientInputResponses ctx) of + Nothing -> InputRequired + (Map.singleton "proceed" (ElicitForm ("Deploy " <> target <> "?") confirmSchema)) + (Just ("planned:" <> target)) + Just (ElicitResponse ElicitAccept (Just content)) -> Complete $ toolResult + [ ContentText $ "state=" <> fromMaybe "none" (clientRequestState ctx) + <> " answer=" <> T.pack (show (Map.lookup "ok" content)) + ] + Just other -> Complete $ toolError ("not confirmed: " <> T.pack (show other)) + where + target = case Map.lookup "target" args of + Just (String t) -> t + _ -> "nowhere" + +-- | A tool that sends the user to a URL. +linkTool :: ToolCallHandler +linkTool _ _ _ = pure $ Right $ + InputRequired (Map.singleton "login" (ElicitUrl "Sign in" loginUri)) Nothing + where + loginUri = fromMaybe (error "bad URI") (parseURI "https://example.com/login") + +confirmSchema :: Schema +confirmSchema = schema $ SchemaObject [("ok", schema SchemaBoolean)] ["ok"] + +handlers :: McpServerHandlers +handlers = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx name args -> case name of + "link" -> linkTool ctx name args + _ -> confirmTool ctx name args + ) + , resources = Just + ( \_ -> pure [] + , \ctx uri -> pure $ Right $ + if Map.null (clientInputResponses ctx) + then InputRequired (Map.singleton "q" (ElicitForm "Which?" confirmSchema)) Nothing + else Complete (ResourceText uri "text/plain" "read after asking") + ) + , prompts = Just + ( \_ -> pure [] + , \ctx _ _ -> pure $ Right $ + if Map.null (clientInputResponses ctx) + then InputRequired (Map.singleton "q" (ElicitForm "Tone?" confirmSchema)) (Just "p") + else Complete (PromptResult Nothing [PromptMessage RoleUser (ContentText "asked")]) + ) + } + +serverInfo :: McpServerInfo +serverInfo = McpServerInfo "T" "1" "" + +-- | Dispatch one request through the given codec and context. +runWith :: StateCodec -> ClientContext -> Text -> Value -> IO Value +runWith codec ctx method params = do + response <- handleMcpMessage serverInfo defaultCacheHints codec noNotificationSupport + (\_ -> pure ()) handlers ctx $ JsonRpcMessageRequest JsonRpcRequest + { requestJsonrpc = "2.0" + , requestId = RequestIdNumber 1 + , requestMethod = method + , requestParams = Just params + } + case response of + Just (JsonRpcMessageResponse r) -> pure (toJSON r) + other -> fail ("expected a response, got " ++ show other) + +run :: Text -> Value -> IO Value +run = runWith testStateCodec anonymousContext + +-- | Modern params with the given client capabilities. +withCaps :: Value -> [Pair] -> Value +withCaps caps extra = object $ extra ++ + [ "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientCapabilities" .= caps + ] + ] + +formCaps, urlCaps, noCaps :: Value +formCaps = object ["elicitation" .= object ["form" .= object []]] +urlCaps = object ["elicitation" .= object ["url" .= object []]] +noCaps = object [] + +callParams :: Value -> Text -> [Pair] -> Value +callParams caps target extra = withCaps caps $ + [ "name" .= ("deploy" :: Text) + , "arguments" .= object ["target" .= target] + ] ++ extra + +at :: [Key] -> Value -> Maybe Value +at [] v = Just v +at (k : ks) (Object o) = KM.lookup k o >>= at ks +at _ _ = Nothing + +stateOf :: Value -> Text +stateOf v = case at ["result", "requestState"] v of + Just (String s) -> s + _ -> error ("no requestState in " ++ show v) + +errorOf :: Value -> Maybe (Int, Text) +errorOf v = do + Number code <- at ["error", "code"] v + String msg <- at ["error", "message"] v + pure (round code, msg) + +accept :: Value +accept = object ["proceed" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]]] + +-- | The first round, then the retry with the given answers and state. +retry :: Value -> Text -> [Pair] -> IO Value +retry caps target extra = run "tools/call" (callParams caps target extra) + +spec :: Spec +spec = describe "Multi round-trip requests" $ do + describe "The AEAD state codec" $ do + let key kid n = fromMaybe (error "bad key") (stateKey kid (BS.replicate 32 n)) + keyA = key "a" 1 + keyB = key "b" 2 + + it "opens what it sealed" $ do + let codec = aeadStateCodec keyA [] + sealed <- sealState codec "hello" + openState codec sealed `shouldReturn` Right "hello" + + it "uses a fresh nonce for every state" $ do + let codec = aeadStateCodec keyA [] + s1 <- sealState codec "same" + s2 <- sealState codec "same" + s1 `shouldNotBe` s2 + + it "rejects a state altered after sealing" $ do + let codec = aeadStateCodec keyA [] + sealed <- sealState codec "hello" + -- Change one base64 character well inside the payload + let (prefix, rest) = T.splitAt (T.length (fst (T.breakOn "." sealed)) + 10) sealed + swapped = if T.head rest == 'A' then 'B' else 'A' + tampered = prefix <> T.cons swapped (T.tail rest) + openState codec tampered `shouldReturn` Left StateInvalid + + it "reports a state sealed under a key it does not have" $ do + sealed <- sealState (aeadStateCodec keyA []) "hello" + openState (aeadStateCodec keyB []) sealed `shouldReturn` Left StateUnknownKey + + it "opens states sealed under a retired key during rotation" $ do + sealed <- sealState (aeadStateCodec keyA []) "hello" + openState (aeadStateCodec keyB [keyA]) sealed `shouldReturn` Right "hello" + + it "gives each ephemeral codec its own key" $ do + c1 <- ephemeralStateCodec + c2 <- ephemeralStateCodec + sealed <- sealState c1 "hello" + openState c1 sealed `shouldReturn` Right "hello" + openState c2 sealed `shouldReturn` Left StateUnknownKey + + it "validates keys and key ids" $ do + fmap stateKeyId (stateKey "k-1_x" (BS.replicate 32 0)) `shouldBe` Just "k-1_x" + fmap stateKeyId (stateKey "k" (BS.replicate 31 0)) `shouldBe` Nothing + fmap stateKeyId (stateKey "has.dot" (BS.replicate 32 0)) `shouldBe` Nothing + fmap stateKeyId (stateKey "" (BS.replicate 32 0)) `shouldBe` Nothing + + describe "clientSupportsInput" $ do + let modern caps = anonymousContext + { clientProtocolVersion = Just "2026-07-28", clientCapabilities = Just caps } + form = ElicitForm "?" confirmSchema + url = ElicitUrl "?" (fromMaybe (error "bad URI") (parseURI "https://example.com")) + it "requires a modern client" $ + clientSupportsInput anonymousContext { clientCapabilities = Just formCaps } form `shouldBe` False + it "treats an empty elicitation capability as form only" $ do + let ctx = modern (object ["elicitation" .= object []]) + clientSupportsInput ctx form `shouldBe` True + clientSupportsInput ctx url `shouldBe` False + it "checks each elicitation mode" $ do + clientSupportsInput (modern urlCaps) url `shouldBe` True + clientSupportsInput (modern urlCaps) form `shouldBe` False + it "checks sampling and roots, and refuses other methods" $ do + let ctx = modern (object ["sampling" .= object [], "roots" .= object []]) + clientSupportsInput ctx (RawInputRequest "sampling/createMessage" Null) `shouldBe` True + clientSupportsInput ctx (RawInputRequest "roots/list" Null) `shouldBe` True + clientSupportsInput ctx (RawInputRequest "tools/call" Null) `shouldBe` False + clientSupportsInput (modern noCaps) (RawInputRequest "roots/list" Null) `shouldBe` False + + describe "The first round" $ do + it "answers with an input_required result" $ do + v <- run "tools/call" (callParams formCaps "prod" []) + at ["result", "resultType"] v `shouldBe` Just (String "input_required") + at ["result", "inputRequests", "proceed"] v `shouldBe` Just (object + [ "method" .= ("elicitation/create" :: Text) + , "params" .= object + [ "mode" .= ("form" :: Text) + , "message" .= ("Deploy prod?" :: Text) + , "requestedSchema" .= confirmSchema + ] + ]) + stateOf v `shouldSatisfy` T.isPrefixOf "test." + at ["result", "_meta", "io.modelcontextprotocol/serverInfo", "name"] v + `shouldBe` Just (String "T") + + it "does not reveal the handler's state" $ do + v <- run "tools/call" (callParams formCaps "prod" []) + stateOf v `shouldNotSatisfy` T.isInfixOf "planned" + + it "sends URL-mode elicitation" $ do + v <- run "tools/call" (withCaps urlCaps ["name" .= ("link" :: Text)]) + at ["result", "inputRequests", "login", "params"] v `shouldBe` Just (object + [ "mode" .= ("url" :: Text) + , "message" .= ("Sign in" :: Text) + , "url" .= ("https://example.com/login" :: Text) + ]) + + it "omits cacheability fields from input_required results" $ do + v <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)]) + at ["result", "resultType"] v `shouldBe` Just (String "input_required") + at ["result", "ttlMs"] v `shouldBe` Nothing + at ["result", "cacheScope"] v `shouldBe` Nothing + + it "works for prompts/get" $ do + v <- run "prompts/get" (withCaps formCaps ["name" .= ("p" :: Text)]) + at ["result", "resultType"] v `shouldBe` Just (String "input_required") + + describe "The retry" $ do + it "completes with the answers and the handler's own state" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first] + at ["result", "resultType"] v `shouldBe` Just (String "complete") + at ["result", "content"] v `shouldBe` Just (toJSON + [ContentText "state=planned:prod answer=Just (Bool True)"]) + + it "passes declined answers to the handler" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" + [ "inputResponses" .= object ["proceed" .= object ["action" .= ("decline" :: Text)]] + , "requestState" .= stateOf first + ] + at ["result", "isError"] v `shouldBe` Just (Bool True) + + it "completes a resource read after asking" $ do + first <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)]) + v <- run "resources/read" $ withCaps formCaps + [ "uri" .= ("resource://x" :: Text) + , "inputResponses" .= object ["q" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]]] + , "requestState" .= stateOf first + ] + at ["result", "resultType"] v `shouldBe` Just (String "complete") + at ["result", "ttlMs"] v `shouldSatisfy` (/= Nothing) + + describe "Rejected state" $ do + it "rejects a state presented with different arguments" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "staging" ["inputResponses" .= accept, "requestState" .= stateOf first] + errorOf v `shouldBe` Just (-32602, "Invalid requestState") + + it "rejects a state presented on another method" $ do + first <- run "prompts/get" (withCaps formCaps ["name" .= ("p" :: Text)]) + v <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text), "requestState" .= stateOf first]) + errorOf v `shouldBe` Just (-32602, "Invalid requestState") + + it "rejects a state presented by another principal" $ do + let alice = anonymousContext { clientPrincipal = Just (String "alice") } + bob = anonymousContext { clientPrincipal = Just (String "bob") } + first <- runWith testStateCodec alice "tools/call" (callParams formCaps "prod" []) + v <- runWith testStateCodec bob "tools/call" + (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first]) + errorOf v `shouldBe` Just (-32602, "Invalid requestState") + ok <- runWith testStateCodec alice "tools/call" + (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first]) + at ["result", "resultType"] ok `shouldBe` Just (String "complete") + + it "rejects an expired state" $ do + let shortLived = testStateCodec { stateLifetime = -1 } + first <- runWith shortLived anonymousContext "tools/call" (callParams formCaps "prod" []) + v <- runWith shortLived anonymousContext "tools/call" + (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first]) + fmap fst (errorOf v) `shouldBe` Just (-32602) + fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "expired") + + it "explains a state from another instance" $ do + other <- ephemeralStateCodec + first <- runWith other anonymousContext "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first] + fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "another server instance") + + it "rejects a state that is not a string" $ do + v <- retry formCaps "prod" ["requestState" .= (42 :: Int)] + fmap fst (errorOf v) `shouldBe` Just (-32602) + + it "rejects a malformed answer to an issued request" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" + ["inputResponses" .= object ["proceed" .= (1 :: Int)], "requestState" .= stateOf first] + fmap fst (errorOf v) `shouldBe` Just (-32602) + fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "proceed") + + it "rejects inputResponses that are not an object" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" ["inputResponses" .= (1 :: Int), "requestState" .= stateOf first] + fmap fst (errorOf v) `shouldBe` Just (-32602) + + describe "Answers the handler did not ask for" $ do + it "ignores answers sent without a request state" $ do + v <- retry formCaps "prod" ["inputResponses" .= accept] + at ["result", "resultType"] v `shouldBe` Just (String "input_required") + + it "ignores keys the previous round did not issue" $ do + first <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)]) + v <- run "resources/read" $ withCaps formCaps + [ "uri" .= ("resource://x" :: Text) + , "inputResponses" .= object ["sneaky" .= object ["action" .= ("accept" :: Text)]] + , "requestState" .= stateOf first + ] + -- The handler saw no answers, so it asked again. + at ["result", "resultType"] v `shouldBe` Just (String "input_required") + + it "ignores unknown keys whatever their value" $ do + first <- run "tools/call" (callParams formCaps "prod" []) + v <- retry formCaps "prod" + [ "inputResponses" .= object + [ "proceed" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]] + , "extra" .= (42 :: Int) + ] + , "requestState" .= stateOf first + ] + at ["result", "resultType"] v `shouldBe` Just (String "complete") + + describe "Clients that cannot answer" $ do + it "is a server error to ask a client without the capability" $ do + v <- run "tools/call" (callParams noCaps "prod" []) + fmap fst (errorOf v) `shouldBe` Just (-32603) + fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "proceed") + + it "is a server error to ask for a mode the client lacks" $ do + v <- run "tools/call" (withCaps formCaps ["name" .= ("link" :: Text)]) + fmap fst (errorOf v) `shouldBe` Just (-32603) + + it "is a server error to ask a legacy client" $ do + v <- run "tools/call" (object ["name" .= ("deploy" :: Text)]) + fmap fst (errorOf v) `shouldBe` Just (-32603) + + it "ignores round fields on legacy requests" $ do + v <- run "tools/call" (object + [ "name" .= ("deploy" :: Text) + , "inputResponses" .= accept + , "requestState" .= ("anything" :: Text) + ]) + -- The handler saw no answers, so it asked, which legacy cannot carry. + fmap fst (errorOf v) `shouldBe` Just (-32603) diff --git a/test/Spec/JSONConversion.hs b/test/Spec/JSONConversion.hs --- a/test/Spec/JSONConversion.hs +++ b/test/Spec/JSONConversion.hs @@ -5,7 +5,7 @@ import Data.Aeson (toJSON) import Data.Text (Text) import qualified Data.Text as T -import MCP.Server +import MCP.Server.Handlers (jsonValueToText) import Test.Hspec import Test.QuickCheck import Text.Read (readMaybe) diff --git a/test/Spec/ModernEra.hs b/test/Spec/ModernEra.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ModernEra.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for dual-era operation: modern (2026-07-28, per-request _meta) +-- requests get server/discover, the modern result envelope and header +-- validation; legacy (initialize-handshake) requests are served byte- +-- identically to before. +module Spec.ModernEra (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.Text (Text) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import MCP.Server.Transport.Http (BodyPeek (..), decodeSentinel, peekBody, + peekIsModern, validateRequestHeaders, + wantsStreamingResponse) +import qualified Network.Wai as Wai +import Test.Hspec +import TestHelpers (testStateCodec) + +testServerInfo :: McpServerInfo +testServerInfo = McpServerInfo + { serverName = "Test Server" + , serverVersion = "9.9.9" + , serverInstructions = "Use the tools." + } + +-- A server that only provides tools; the call handler reports the protocol +-- version it saw in the ClientContext. +testHandlers :: McpServerHandlers +testHandlers = noHandlers + { tools = Just + ( \_ctx -> pure [] + , \ctx _name _args -> pure $ Right $ Complete $ toToolResult + ("version=" <> maybe "none" id (clientProtocolVersion ctx)) + ) + } + +run :: JsonRpcMessage -> IO (Maybe JsonRpcMessage) +run = handleMcpMessage testServerInfo defaultCacheHints testStateCodec noNotificationSupport (\_ -> pure ()) testHandlers anonymousContext + +request :: Text -> Maybe Value -> JsonRpcMessage +request method params = JsonRpcMessageRequest $ JsonRpcRequest + { requestJsonrpc = "2.0" + , requestId = RequestIdNumber 1 + , requestMethod = method + , requestParams = params + } + +-- params carrying the standard modern _meta +modernParams :: [Pair] -> Value +modernParams extra = object $ extra ++ + [ "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientInfo" .= object ["name" .= ("test-client" :: Text)] + , "io.modelcontextprotocol/clientCapabilities" .= object [] + ] + ] + +resultObject :: Maybe JsonRpcMessage -> IO Object +resultObject (Just (JsonRpcMessageResponse r)) = case responseResult r of + Just (Object o) -> pure o + other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty +resultObject other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty + +errorOf :: Maybe JsonRpcMessage -> IO JsonRpcError +errorOf (Just (JsonRpcMessageResponse r)) = case responseError r of + Just e -> pure e + Nothing -> expectationFailure "Expected an error response" >> pure (JsonRpcError 0 "" Nothing) +errorOf other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure (JsonRpcError 0 "" Nothing) + +spec :: Spec +spec = describe "Dual-era protocol support" $ do + + describe "server/discover" $ do + it "reports all supported revisions, newest first" $ do + o <- resultObject =<< run (request "server/discover" (Just (modernParams []))) + KM.lookup "supportedVersions" o `shouldBe` + Just (toJSON (["2026-07-28", "2025-11-25", "2025-06-18", "2025-03-26", "2024-11-05"] :: [Text])) + + it "advertises only capabilities with handlers, plus identity and instructions" $ do + o <- resultObject =<< run (request "server/discover" (Just (modernParams []))) + case KM.lookup "capabilities" o of + Just (Object caps) -> do + KM.member "tools" caps `shouldBe` True + KM.member "prompts" caps `shouldBe` False + other -> expectationFailure $ "capabilities not an object: " ++ show other + KM.lookup "instructions" o `shouldBe` Just (String "Use the tools.") + case KM.lookup "_meta" o of + Just (Object m) -> + KM.lookup "io.modelcontextprotocol/serverInfo" m `shouldBe` + Just (object ["name" .= ("Test Server" :: Text), "version" .= ("9.9.9" :: Text)]) + other -> expectationFailure $ "_meta not an object: " ++ show other + + it "carries the modern result envelope even without _meta (probe)" $ do + o <- resultObject =<< run (request "server/discover" Nothing) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.member "ttlMs" o `shouldBe` True + KM.lookup "cacheScope" o `shouldBe` Just (String "private") + + describe "Modern requests" $ do + it "stamps resultType and cache fields on cacheable results" $ do + o <- resultObject =<< run (request "tools/list" (Just (modernParams []))) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.lookup "ttlMs" o `shouldBe` Just (Number 0) + KM.lookup "cacheScope" o `shouldBe` Just (String "private") + + it "stamps resultType but not cache fields on tools/call" $ do + o <- resultObject =<< run (request "tools/call" + (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []]))) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.member "ttlMs" o `shouldBe` False + + it "exposes the declared protocol version to handlers via ClientContext" $ do + o <- resultObject =<< run (request "tools/call" + (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []]))) + KM.lookup "content" o `shouldBe` + Just (toJSON [object ["type" .= ("text" :: Text), "text" .= ("version=2026-07-28" :: Text)]]) + + it "serves initialize and ping as unknown methods when a modern revision is declared" $ do + e1 <- errorOf =<< run (request "initialize" (Just (modernParams + [ "protocolVersion" .= ("2026-07-28" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ]))) + errorCode e1 `shouldBe` (-32601) + e2 <- errorOf =<< run (request "ping" (Just (modernParams []))) + errorCode e2 `shouldBe` (-32601) + + it "rejects undeclared revisions with UnsupportedProtocolVersionError" $ do + e <- errorOf =<< run (request "tools/list" (Just (object + [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2099-01-01" :: Text)] ]))) + errorCode e `shouldBe` (-32022) + case errorData e of + Just (Object d) -> do + KM.lookup "requested" d `shouldBe` Just (String "2099-01-01") + case KM.lookup "supported" d of + Just (Array _) -> pure () + other -> expectationFailure $ "supported not a list: " ++ show other + other -> expectationFailure $ "no error data: " ++ show other + + describe "Legacy requests" $ do + it "are served without the modern envelope" $ do + o <- resultObject =<< run (request "tools/list" Nothing) + KM.member "resultType" o `shouldBe` False + KM.member "ttlMs" o `shouldBe` False + KM.member "_meta" o `shouldBe` False + + it "negotiate down to the newest legacy revision when proposing 2026-07-28 via initialize" $ do + o <- resultObject =<< run (request "initialize" (Just (object + [ "protocolVersion" .= ("2026-07-28" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ]))) + KM.lookup "protocolVersion" o `shouldBe` Just (String "2025-11-25") + + describe "HTTP request metadata validation" $ do + let modernBody name = encode $ object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (7 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" .= modernParams ["name" .= name, "arguments" .= object []] + ] + reqWith hs = Wai.defaultRequest { Wai.requestHeaders = hs } + + it "peeks method, name, version and id from the body" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + peekMethod peek `shouldBe` Just "tools/call" + peekName peek `shouldBe` Just "get_weather" + peekMetaVersion peek `shouldBe` Just "2026-07-28" + peekId peek `shouldBe` RequestIdNumber 7 + peekIsModern peek `shouldBe` True + + it "accepts a fully consistent modern request" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "get_weather") + ]) peek `shouldBe` Nothing + + it "rejects a missing Mcp-Method header with HeaderMismatch" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + fmap errorCode (validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Name", "get_weather") + ]) peek) `shouldBe` Just (-32020) + + it "rejects a header/body protocol version mismatch with HeaderMismatch" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + fmap errorCode (validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2025-11-25") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "get_weather") + ]) peek) `shouldBe` Just (-32020) + + it "accepts a base64-sentinel Mcp-Name for non-ASCII names" $ do + let peek = peekBody (modernBody ("Hello, 世界" :: Text)) + validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "=?base64?SGVsbG8sIOS4lueVjA==?=") + ]) peek `shouldBe` Nothing + + it "legacy bodies keep the relaxed rules (no headers required)" $ do + let legacyBody = encode $ object + [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int) + , "method" .= ("tools/list" :: Text) ] + validateRequestHeaders (reqWith []) (peekBody legacyBody) `shouldBe` Nothing + + it "legacy bodies with an unsupported version header are rejected" $ do + let legacyBody = encode $ object + [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int) + , "method" .= ("tools/list" :: Text) ] + fmap errorCode (validateRequestHeaders + (reqWith [("MCP-Protocol-Version", "1999-01-01")]) + (peekBody legacyBody)) `shouldBe` Just (-32600) + + describe "Streaming-response selection" $ do + let tokenMeta = "\"_meta\":{\"progressToken\":\"t1\"}" + + it "streams dispatchable requests that carry a progressToken" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"tools/call\",\"params\":{\"name\":\"x\",\"arguments\":{}," <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` True + + it "keeps unknown methods on the JSON path so they retain their 404" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":2,\"method\":\"subscriptions/listen\",\"params\":{" <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + it "keeps notification bodies on the JSON path so they retain their 202" $ do + let body = "{\"jsonrpc\":\"2.0\",\"method\":\"tools/call\",\"params\":{\"name\":\"x\"," <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + it "does not stream token-less requests" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":3,\"method\":\"tools/call\",\"params\":{\"name\":\"x\"}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + describe "Sentinel decoding" $ do + it "passes plain values through" $ + decodeSentinel "us-west1" `shouldBe` "us-west1" + it "decodes base64 sentinel values" $ + decodeSentinel "=?base64?SGVsbG8sIOS4lueVjA==?=" `shouldBe` "Hello, 世界" diff --git a/test/Spec/Progress.hs b/test/Spec/Progress.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Progress.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for progress notifications and per-request client logging +-- (ADR 0007): the reportProgress/logToClient context actions and their +-- _meta-driven gating. +module Spec.Progress (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.IORef +import Data.Text (Text) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) + +progressServer :: McpServerHandlers +progressServer = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx name _ -> case name of + "work" -> do + reportProgress ctx 0.2 (Just 1.0) (Just "starting") + reportProgress ctx 0.9 Nothing Nothing + pure $ Right $ Complete $ toToolResult ("done" :: Text) + "chatty" -> do + logToClient ctx LogInfo (String "fyi") + logToClient ctx LogError (String "bad") + pure $ Right $ Complete $ toToolResult ("ok" :: Text) + _ -> pure $ Left $ UnknownTool name + ) + } + +-- Run a tools/call with the given _meta fields, collecting emitted +-- request-scoped notifications in order. +callTool :: [Pair] -> Text -> IO ([JsonRpcNotification], Maybe JsonRpcMessage) +callTool metaFields tool = do + sink <- newIORef [] + let emit n = modifyIORef' sink (++ [n]) + params = object $ + ["name" .= tool, "arguments" .= object []] + ++ (if null metaFields then [] else ["_meta" .= object metaFields]) + resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec + noNotificationSupport emit progressServer anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params))) + notifications <- readIORef sink + pure (notifications, resp) + +paramsOf :: JsonRpcNotification -> Object +paramsOf n = case notificationParams n of + Just (Object o) -> o + other -> error $ "notification params not an object: " ++ show other + +spec :: Spec +spec = describe "Progress and client logging" $ do + + describe "reportProgress" $ do + it "emits tagged, ordered notifications/progress before the response" $ do + (ns, resp) <- callTool ["progressToken" .= ("abc123" :: Text)] "work" + map notificationMethod ns `shouldBe` + ["notifications/progress", "notifications/progress"] + case map paramsOf ns of + [first', second'] -> do + KM.lookup "progressToken" first' `shouldBe` Just (String "abc123") + KM.lookup "progress" first' `shouldBe` Just (Number 0.2) + KM.lookup "total" first' `shouldBe` Just (Number 1.0) + KM.lookup "message" first' `shouldBe` Just (String "starting") + KM.lookup "progress" second' `shouldBe` Just (Number 0.9) + KM.member "total" second' `shouldBe` False + KM.member "message" second' `shouldBe` False + other -> expectationFailure $ "expected two notifications, got: " ++ show (length other) + resp `shouldSatisfy` (/= Nothing) + + it "preserves integer tokens as integers" $ do + (ns, _) <- callTool ["progressToken" .= (42 :: Int)] "work" + map (KM.lookup "progressToken" . paramsOf) ns `shouldBe` + [Just (Number 42), Just (Number 42)] + + it "is a no-op without a progressToken" $ do + (ns, resp) <- callTool [] "work" + ns `shouldBe` [] + resp `shouldSatisfy` (/= Nothing) + + describe "logToClient" $ do + it "filters below the declared level and emits at or above it" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("warning" :: Text)] "chatty" + map notificationMethod ns `shouldBe` ["notifications/message"] + case ns of + [n] -> do + KM.lookup "level" (paramsOf n) `shouldBe` Just (String "error") + KM.lookup "data" (paramsOf n) `shouldBe` Just (String "bad") + other -> expectationFailure $ "expected one notification, got: " ++ show (length other) + + it "emits everything at a permissive level" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("debug" :: Text)] "chatty" + map (KM.lookup "level" . paramsOf) ns `shouldBe` + [Just (String "info"), Just (String "error")] + + it "emits nothing when the request declared no logLevel (spec MUST NOT)" $ do + (ns, _) <- callTool [] "chatty" + ns `shouldBe` [] + + it "treats an unparseable logLevel as absent" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("loudly" :: Text)] "chatty" + ns `shouldBe` [] diff --git a/test/Spec/ProtocolVersionNegotiation.hs b/test/Spec/ProtocolVersionNegotiation.hs --- a/test/Spec/ProtocolVersionNegotiation.hs +++ b/test/Spec/ProtocolVersionNegotiation.hs @@ -10,7 +10,7 @@ import MCP.Server.Handlers (handleInitialize) import MCP.Server.JsonRpc (JsonRpcRequest(..), RequestId(..), JsonRpcResponse(..), JsonRpcError(..)) import MCP.Server.Protocol (protocolVersion) -import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..)) +import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..), noHandlers, noNotificationSupport) -- | Test that server performs proper version negotiation according to MCP spec. -- @@ -33,10 +33,8 @@ -- A server that only provides tools: capabilities in the initialize -- response should reflect exactly this. - let testHandlers = McpServerHandlers - { prompts = Nothing - , resources = Nothing - , tools = Just ( \_ctx -> pure [] + let testHandlers = noHandlers + { tools = Just ( \_ctx -> pure [] , \_ctx name _args -> pure (Left (UnknownTool name)) ) } @@ -57,7 +55,7 @@ , requestMethod = "initialize" , requestParams = Just params } - handleInitialize testServerInfo testHandlers request + handleInitialize testServerInfo noNotificationSupport testHandlers request -- Issue an initialize request proposing the given protocol version and -- return the negotiated version from the server's (non-error) response. diff --git a/test/Spec/RawSchema.hs b/test/Spec/RawSchema.hs new file mode 100644 --- /dev/null +++ b/test/Spec/RawSchema.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for raw JSON Schema keywords (ADR 0014). +module Spec.RawSchema (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Text (Text) +import MCP.Server +import Test.Hspec + +-- | Keywords none of the other shapes can express: a nullable union and a +-- recursive definition. +treeKeywords :: Object +treeKeywords = KM.fromList + [ "$defs" .= object + [ "tree" .= object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "label" .= object ["type" .= ("string" :: Text)] + , "children" .= object ["type" .= ("array" :: Text), "items" .= object ["$ref" .= ("#/$defs/tree" :: Text)]] + ] + , "required" .= (["label", "children"] :: [Text]) + ] + ] + , "type" .= ("object" :: Text) + , "properties" .= object + [ "root" .= object ["anyOf" .= [object ["type" .= ("null" :: Text)], object ["$ref" .= ("#/$defs/tree" :: Text)]]] + ] + , "required" .= (["root"] :: [Text]) + ] + +spec :: Spec +spec = describe "Raw schemas" $ do + it "serializes raw keywords as given" $ + toJSON (schema (SchemaRaw treeKeywords)) `shouldBe` Object treeKeywords + + it "adds a description, replacing one in the keywords" $ + toJSON (describedSchema "Outer" (SchemaRaw (KM.fromList ["type" .= ("integer" :: Text), "description" .= ("Inner" :: Text)]))) + `shouldBe` object ["type" .= ("integer" :: Text), "description" .= ("Outer" :: Text)] + + it "nests inside the other shapes" $ + toJSON (schema (SchemaObject [("count", schema (SchemaRaw (KM.fromList ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)])))] ["count"])) + `shouldBe` object + [ "type" .= ("object" :: Text) + , "properties" .= object ["count" .= object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]] + , "required" .= (["count"] :: [Text]) + ] + + it "reaches the wire as a tool's input schema" $ do + let definition = mkToolDefinition "plant" "Plant a tree" (schema (SchemaRaw treeKeywords)) + toJSON definition `shouldSatisfy` \case + Object fields -> KM.lookup "inputSchema" fields == Just (Object treeKeywords) + _ -> False diff --git a/test/Spec/SchemaValidation.hs b/test/Spec/SchemaValidation.hs --- a/test/Spec/SchemaValidation.hs +++ b/test/Spec/SchemaValidation.hs @@ -9,14 +9,15 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes import TestData -- Generate handlers for testing -testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlers :: (ToolListHandler, ToolCallHandler) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) -testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions) -- Helper functions for schema validation @@ -27,13 +28,11 @@ [] -> error $ "Tool not found: " ++ T.unpack toolName _ -> error $ "Multiple tools found with name: " ++ T.unpack toolName -getProperty :: Text -> ToolDefinition -> InputSchemaDefinitionProperty +getProperty :: Text -> ToolDefinition -> Schema getProperty propertyName toolDef = - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - case lookup propertyName props of - Just prop -> prop - Nothing -> error $ "Property not found: " ++ T.unpack propertyName + case lookupProp propertyName toolDef of + Just prop -> prop + Nothing -> error $ "Property not found: " ++ T.unpack propertyName assertToolExists :: Text -> [ToolDefinition] -> IO () assertToolExists toolName toolDefs = do @@ -42,18 +41,17 @@ assertHasProperty :: Text -> Text -> ToolDefinition -> IO () assertHasProperty propertyName expectedType toolDef = do let prop = getProperty propertyName toolDef - propertyType prop `shouldBe` expectedType + schemaTypeName prop `shouldBe` expectedType assertPropertyDescription :: Text -> ToolDefinition -> Text -> IO () assertPropertyDescription propertyName toolDef expectedDesc = do let prop = getProperty propertyName toolDef - propertyDescription prop `shouldBe` expectedDesc + schemaDescription prop `shouldBe` Just expectedDesc assertRequiredFields :: [Text] -> ToolDefinition -> IO () assertRequiredFields expectedFields toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject _ required -> - all (`elem` required) expectedFields `shouldBe` True + let required = schemaRequired (toolDefinitionInputSchema toolDef) + all (`elem` required) expectedFields `shouldBe` True assertToolDescription :: ToolDefinition -> Text -> IO () assertToolDescription toolDef expectedDesc = diff --git a/test/Spec/Subscriptions.hs b/test/Spec/Subscriptions.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Subscriptions.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for the change-notification machinery: the notifier, the +-- subscriptions/listen wire shapes, and era-aware capability advertisement. +module Spec.Subscriptions (spec) where + +import Control.Concurrent.STM (atomically, readTChan) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Text (Text) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import MCP.Server.Notifications +import Test.Hspec +import TestHelpers (testStateCodec) + +subId :: RequestId +subId = RequestIdNumber 7 + +fullFilterParams :: Maybe Value +fullFilterParams = Just $ object + [ "notifications" .= object + [ "toolsListChanged" .= True + , "resourceSubscriptions" .= (["resource://info"] :: [Text]) + ] + ] + +paramsOf :: JsonRpcNotification -> Object +paramsOf n = case notificationParams n of + Just (Object o) -> o + other -> error $ "notification params not an object: " ++ show other + +metaSubId :: Object -> Maybe Value +metaSubId o = do + Object m <- KM.lookup "_meta" o + KM.lookup "io.modelcontextprotocol/subscriptionId" m + +spec :: Spec +spec = describe "Change notifications" $ do + + describe "Filter parsing" $ do + it "parses the requested notification types" $ do + let f = parseNotificationFilter fullFilterParams + filterTools f `shouldBe` True + filterPrompts f `shouldBe` False + filterResources f `shouldBe` False + filterResourceSubs f `shouldBe` ["resource://info"] + + it "treats missing filters as subscribed-to-nothing" $ do + let f = parseNotificationFilter Nothing + filterIsEmpty f `shouldBe` True + + describe "Filter semantics" $ do + it "delivers only opted-in types" $ do + let f = parseNotificationFilter fullFilterParams + filterAccepts f ToolsListChangedEvent `shouldBe` True + filterAccepts f PromptsListChangedEvent `shouldBe` False + filterAccepts f ResourcesListChangedEvent `shouldBe` False + + it "matches resource updates by watched URI" $ do + let f = parseNotificationFilter fullFilterParams + filterAccepts f (ResourceUpdatedEvent "resource://info") `shouldBe` True + filterAccepts f (ResourceUpdatedEvent "resource://other") `shouldBe` False + + describe "Wire shapes" $ do + it "acknowledges with the subscription id and the honored subset" $ do + let ack = acknowledgedNotification subId (parseNotificationFilter fullFilterParams) + notificationMethod ack `shouldBe` "notifications/subscriptions/acknowledged" + let o = paramsOf ack + metaSubId o `shouldBe` Just (Number 7) + KM.lookup "notifications" o `shouldBe` Just (object + [ "toolsListChanged" .= True + , "resourceSubscriptions" .= (["resource://info"] :: [Text]) + ]) + + it "tags event notifications with the subscription id" $ do + let n = eventNotification subId (ResourceUpdatedEvent "resource://info") + notificationMethod n `shouldBe` "notifications/resources/updated" + let o = paramsOf n + metaSubId o `shouldBe` Just (Number 7) + KM.lookup "uri" o `shouldBe` Just (String "resource://info") + + it "uses the standard list_changed methods" $ do + notificationMethod (eventNotification subId ToolsListChangedEvent) + `shouldBe` "notifications/tools/list_changed" + notificationMethod (eventNotification subId PromptsListChangedEvent) + `shouldBe` "notifications/prompts/list_changed" + notificationMethod (eventNotification subId ResourcesListChangedEvent) + `shouldBe` "notifications/resources/list_changed" + + it "legacy notifications are untagged" $ do + let n = legacyEventNotification ToolsListChangedEvent + notificationMethod n `shouldBe` "notifications/tools/list_changed" + notificationParams n `shouldBe` Nothing + + it "closure responses carry resultType, the subscription id and the server identity" $ do + let r = closureResponse (McpServerInfo "S" "2.0" "") subId + responseResult r `shouldBe` Just (object + [ "resultType" .= ("complete" :: Text) + , "_meta" .= object + [ "io.modelcontextprotocol/subscriptionId" .= (7 :: Int) + , "io.modelcontextprotocol/serverInfo" .= object + [ "name" .= ("S" :: Text), "version" .= ("2.0" :: Text) ] + ] + ]) + + describe "Notifier plumbing" $ do + it "delivers published events to subscribers" $ do + (notifier, source) <- newMcpNotifier + chan <- atomically $ subscribeEvents source + notifyToolsListChanged notifier + event <- atomically $ readTChan chan + event `shouldBe` ToolsListChangedEvent + + describe "Era-aware capability advertisement" $ do + let toolsServer = noHandlers + { tools = Just (\_ -> pure [], \_ n _ -> pure (Left (UnknownTool n))) + , resources = Just (\_ -> pure [], \_ _ -> pure (Left (ResourceNotFound "x"))) + } + run support method params = handleMcpMessage + (McpServerInfo "T" "1" "") + defaultCacheHints testStateCodec + support + (\_ -> pure ()) + toolsServer + anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) + capsOf resp = case resp of + Just (JsonRpcMessageResponse r) + | Just (Object o) <- responseResult r + , Just (Object caps) <- KM.lookup "capabilities" o -> pure caps + other -> error $ "no capabilities in: " ++ show other + initParams = Just $ object + [ "protocolVersion" .= ("2025-11-25" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ] + + it "legacy initialize advertises listChanged only with legacy push" $ do + caps <- capsOf =<< run (NotificationSupport True True) "initialize" initParams + KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True]) + -- legacy subscribe (the removed resources/subscribe RPC) is never advertised + KM.lookup "resources" caps `shouldBe` Just (object ["listChanged" .= True]) + + it "legacy initialize over a push-less transport advertises neither" $ do + caps <- capsOf =<< run (NotificationSupport False True) "initialize" initParams + KM.lookup "tools" caps `shouldBe` Just (object []) + KM.lookup "resources" caps `shouldBe` Just (object []) + + it "modern discover advertises listChanged and subscribe when listen is served" $ do + caps <- capsOf =<< run (NotificationSupport False True) "server/discover" Nothing + KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True]) + KM.lookup "resources" caps `shouldBe` + Just (object ["subscribe" .= True, "listChanged" .= True]) + + it "no support means nothing extra is advertised" $ do + caps <- capsOf =<< run noNotificationSupport "server/discover" Nothing + KM.lookup "tools" caps `shouldBe` Just (object []) diff --git a/test/Spec/TemplatesCompletions.hs b/test/Spec/TemplatesCompletions.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TemplatesCompletions.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for resource templates (record constructors → URI templates) +-- and argument completion (completion/complete). +module Spec.TemplatesCompletions (spec) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec +import TestHelpers (testStateCodec) +import TestTypes + +templResourceHandlers :: (ResourceListHandler, ResourceReadHandler) +templResourceHandlers = $(deriveResourceHandler ''TemplResource 'handleTemplResource) + +templTemplates :: ResourceTemplateListHandler +templTemplates = $(deriveResourceTemplatesWithDescription ''TemplResource + [("MemberProfile", "A member's profile"), ("OrderItem", "One item of an order")]) + +readUri :: String -> IO (Either Error (Outcome ResourceContent)) +readUri s = case parseURI s of + Just uri -> snd templResourceHandlers anonCtx uri + Nothing -> fail ("bad test URI: " ++ s) + +expectText :: Either Error (Outcome ResourceContent) -> Text -> Expectation +expectText (Right (Complete (ResourceText _ _ content))) expected = content `shouldBe` expected +expectText other expected = + expectationFailure $ "Expected ResourceText '" ++ T.unpack expected ++ "' but got: " ++ show other + +-- A completion handler that records what it receives in its suggestions +testCompletions :: CompletionHandler +testCompletions _ ref argName partial ctxArgs = pure $ Right $ completionResult $ + case ref of + CompletionRefPrompt name -> + [ "prompt:" <> name <> ":" <> argName <> ":" <> partial + <> ":" <> T.intercalate "," (Map.keys ctxArgs) + ] + CompletionRefResource uri -> [ "resource:" <> uri <> ":" <> argName ] + +completionServer :: McpServerHandlers +completionServer = noHandlers { completions = Just testCompletions } + +runReq :: McpServerHandlers -> Text -> Maybe Value -> IO (Maybe JsonRpcMessage) +runReq handlers method params = + handleMcpMessage + (McpServerInfo "T" "1" "") + defaultCacheHints testStateCodec + noNotificationSupport + (\_ -> pure ()) + handlers + anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) + +resultOf :: Maybe JsonRpcMessage -> IO Object +resultOf (Just (JsonRpcMessageResponse r)) = case responseResult r of + Just (Object o) -> pure o + other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty +resultOf other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty + +spec :: Spec +spec = describe "Resource templates and completions" $ do + + describe "Template derivation" $ do + it "advertises record constructors as URI templates" $ do + templates <- templTemplates anonCtx + map resourceTemplateURITemplate templates `shouldBe` + [ "resource://member_profile/{memberId}" + , "resource://order_item/{orderId}/{itemName}" + ] + map resourceTemplateDescription templates `shouldBe` + [ Just "A member's profile", Just "One item of an order" ] + + it "excludes record constructors from the static resource list" $ do + statics <- fst templResourceHandlers anonCtx + map resourceDefinitionURI statics `shouldBe` ["resource://catalog"] + + describe "Template reads" $ do + it "still reads static resources" $ do + result <- readUri "resource://catalog" + result `expectText` "The catalog" + + it "reads a single-parameter template" $ do + result <- readUri "resource://member_profile/alice" + result `expectText` "Profile of alice" + + it "percent-decodes template segments" $ do + result <- readUri "resource://member_profile/alice%20smith" + result `expectText` "Profile of alice smith" + + it "ignores query strings and fragments when matching templates" $ do + result <- readUri "resource://member_profile/alice?x=1" + result `expectText` "Profile of alice" + result2 <- readUri "resource://member_profile/alice#frag" + result2 `expectText` "Profile of alice" + + it "reads a multi-parameter template with typed segments" $ do + result <- readUri "resource://order_item/42/widget" + result `expectText` "Order 42 item widget" + + it "rejects segments that fail the field's type" $ do + result <- readUri "resource://order_item/notanum/widget" + case result of + Left (InvalidParams msg) -> msg `shouldSatisfy` T.isInfixOf "template field 'orderId'" + other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other + + it "falls through to ResourceNotFound on a segment-count mismatch" $ do + result <- readUri "resource://member_profile/a/b" + case result of + Left (ResourceNotFound _) -> pure () + other -> expectationFailure $ "Expected ResourceNotFound but got: " ++ show other + + describe "resources/templates/list dispatch" $ do + it "returns templates and carries the modern cache envelope" $ do + let handlers = noHandlers { resourceTemplates = Just templTemplates } + o <- resultOf =<< runReq handlers "resources/templates/list" (Just (object + [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)] ])) + KM.member "resourceTemplates" o `shouldBe` True + KM.member "ttlMs" o `shouldBe` True + KM.lookup "resultType" o `shouldBe` Just (String "complete") + + it "answers -32601 when no template handler is configured" $ do + resp <- runReq noHandlers "resources/templates/list" Nothing + case resp of + Just (JsonRpcMessageResponse r) -> + fmap errorCode (responseError r) `shouldBe` Just (-32601) + other -> expectationFailure $ "Expected a response, got: " ++ show other + + it "answers resources/list with an empty list for a templates-only server" $ do + let handlers = noHandlers { resourceTemplates = Just templTemplates } + o <- resultOf =<< runReq handlers "resources/list" Nothing + KM.lookup "resources" o `shouldBe` Just (toJSON ([] :: [ResourceDefinition])) + + describe "completion/complete" $ do + it "dispatches prompt refs with context arguments" $ do + o <- resultOf =<< runReq completionServer "completion/complete" (Just (object + [ "ref" .= object ["type" .= ("ref/prompt" :: Text), "name" .= ("recipe" :: Text)] + , "argument" .= object ["name" .= ("idea" :: Text), "value" .= ("pa" :: Text)] + , "context" .= object ["arguments" .= object ["cuisine" .= ("italian" :: Text)]] + ])) + KM.lookup "completion" o `shouldBe` + Just (object ["values" .= (["prompt:recipe:idea:pa:cuisine"] :: [Text])]) + + it "dispatches resource template refs" $ do + o <- resultOf =<< runReq completionServer "completion/complete" (Just (object + [ "ref" .= object ["type" .= ("ref/resource" :: Text), "uri" .= ("resource://member_profile/{memberId}" :: Text)] + , "argument" .= object ["name" .= ("memberId" :: Text), "value" .= ("al" :: Text)] + ])) + KM.lookup "completion" o `shouldBe` + Just (object ["values" .= (["resource:resource://member_profile/{memberId}:memberId"] :: [Text])]) + + it "answers -32601 when no completion handler is configured" $ do + resp <- runReq noHandlers "completion/complete" Nothing + case resp of + Just (JsonRpcMessageResponse r) -> + fmap errorCode (responseError r) `shouldBe` Just (-32601) + other -> expectationFailure $ "Expected a response, got: " ++ show other + + describe "Capabilities" $ do + it "advertises completions and resources-via-templates when configured" $ do + let handlers = noHandlers + { resourceTemplates = Just templTemplates + , completions = Just testCompletions + } + o <- resultOf =<< runReq handlers "server/discover" Nothing + case KM.lookup "capabilities" o of + Just (Object caps) -> do + KM.member "completions" caps `shouldBe` True + KM.member "resources" caps `shouldBe` True + KM.member "tools" caps `shouldBe` False + other -> expectationFailure $ "capabilities not an object: " ++ show other diff --git a/test/Spec/ToolCallParsing.hs b/test/Spec/ToolCallParsing.hs --- a/test/Spec/ToolCallParsing.hs +++ b/test/Spec/ToolCallParsing.hs @@ -8,22 +8,21 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes -allTypesHandlers :: (ToolListHandler IO, ToolCallHandler IO) +allTypesHandlers :: (ToolListHandler, ToolCallHandler) allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool) -callTool :: Text -> [(Text, Text)] -> IO (Either Error Content) -callTool = snd allTypesHandlers anonCtx +callTool :: Text -> [(Text, Text)] -> IO (Either Error (Outcome ToolResult)) +callTool name args = snd allTypesHandlers anonCtx name (stringArgs args) -shouldBeRight :: IO (Either Error Content) -> Text -> IO () +shouldBeRight :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeRight action expected = do result <- action - case result of - Right (ContentText content) -> content `shouldBe` expected - other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other + result `shouldBeTextResult` expected -shouldBeInvalidParams :: IO (Either Error Content) -> Text -> IO () +shouldBeInvalidParams :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeInvalidParams action expectedSubstring = do result <- action case result of @@ -31,7 +30,7 @@ T.isInfixOf expectedSubstring msg `shouldBe` True other -> expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other -shouldBeMissingParams :: IO (Either Error Content) -> Text -> IO () +shouldBeMissingParams :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeMissingParams action expectedSubstring = do result <- action case result of @@ -146,3 +145,14 @@ shouldBeMissingParams (callTool "required_fields" [("rfText", "hello")]) "is missing" + + describe "Integer exponent bound" $ do + -- Regression: aeson keeps huge exponents compact, so without a bound a + -- ~13-byte payload like 1e100000 would materialize a 100001-digit Integer. + it "rejects huge exponents without materializing the Integer" $ do + result <- snd allTypesHandlers anonCtx "optional_fields" + (valueArgs [("ofInteger", Number (read "1e100000"))]) + case result of + Left (InvalidParams msg) -> + msg `shouldSatisfy` T.isInfixOf "exponent too large" + other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other diff --git a/test/Spec/TypedArgs.hs b/test/Spec/TypedArgs.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TypedArgs.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for the 0.2 typed-argument features: native JSON values, +-- enumerations, lists, nested records, isError results and multi-message +-- prompts. +module Spec.TypedArgs (spec) where + +import Data.Aeson (object, toJSON, (.=)) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestHelpers +import TestTypes + +typedHandlers :: (ToolListHandler, ToolCallHandler) +typedHandlers = $(deriveToolHandler ''TypedTool 'handleTypedTool) + +convHandlers :: (PromptListHandler, PromptGetHandler) +convHandlers = $(derivePromptHandler ''ConvPrompt 'handleConvPrompt) + +callTyped :: Text -> [(Text, Value)] -> IO (Either Error (Outcome ToolResult)) +callTyped name args = snd typedHandlers anonCtx name (valueArgs args) + +toolNamed :: Text -> [ToolDefinition] -> ToolDefinition +toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of + (d:_) -> d + [] -> error $ "tool not found: " ++ T.unpack n + +expectInvalidParams :: Either Error (Outcome ToolResult) -> Text -> Expectation +expectInvalidParams (Left (InvalidParams msg)) expectedSubstring = + msg `shouldSatisfy` T.isInfixOf expectedSubstring +expectInvalidParams other expectedSubstring = + expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other + +spec :: Spec +spec = describe "Typed tool arguments" $ do + + describe "Enumerations" $ do + it "decodes enum arguments from strings" $ do + result <- callTyped "paint" [("color", String "green"), ("brightness", Number 5)] + result `shouldBeTextResult` "Painting Green at 5" + + it "rejects unknown enum values with the allowed set" $ do + result <- callTyped "paint" [("color", String "purple"), ("brightness", Number 5)] + expectInvalidParams result "expected one of: red, green, blue" + + it "generates a string schema with enum values" $ do + toolDefs <- fst typedHandlers anonCtx + let paintDef = toolNamed "paint" toolDefs + case lookupProp "color" paintDef of + Just prop -> schemaShape prop `shouldBe` SchemaString (Just ["red", "green", "blue"]) + Nothing -> expectationFailure "color property missing" + + describe "Native JSON values" $ do + it "accepts native numbers" $ do + result <- callTyped "paint" [("color", String "red"), ("brightness", Number 7)] + result `shouldBeTextResult` "Painting Red at 7" + + it "still accepts numbers sent as strings (lenient)" $ do + result <- callTyped "paint" [("color", String "red"), ("brightness", String "7")] + result `shouldBeTextResult` "Painting Red at 7" + + it "rejects non-integral numbers for Int fields" $ do + result <- callTyped "paint" [("color", String "red"), ("brightness", Number 7.5)] + expectInvalidParams result "field 'brightness'" + + describe "Lists" $ do + it "decodes arrays of integers" $ do + result <- callTyped "bulk_add" [("values", toJSON [1 :: Int, 2, 3])] + result `shouldBeTextResult` "Sum: 6" + + it "rejects mistyped array elements" $ do + result <- callTyped "bulk_add" [("values", toJSON [Number 1, String "x"])] + expectInvalidParams result "Failed to parse Int" + + it "generates an array schema" $ do + toolDefs <- fst typedHandlers anonCtx + let bulkDef = toolNamed "bulk_add" toolDefs + fmap schemaTypeName (lookupProp "values" bulkDef) `shouldBe` Just "array" + + describe "Nested records" $ do + it "decodes nested objects" $ do + result <- callTyped "query_data" + [("filters", object ["tags" .= (["a", "b"] :: [Text]), "maxCount" .= (7 :: Int)])] + result `shouldBeTextResult` "Query tags=a,b max=7" + + it "treats missing optional nested fields as Nothing" $ do + result <- callTyped "query_data" + [("filters", object ["tags" .= (["a"] :: [Text])])] + result `shouldBeTextResult` "Query tags=a" + + it "reports missing required nested fields with their path" $ do + result <- callTyped "query_data" [("filters", object [])] + expectInvalidParams result "field 'tags' is missing" + + it "rejects non-object values for record fields" $ do + result <- callTyped "query_data" [("filters", String "nope")] + expectInvalidParams result "field 'filters'" + + it "generates a nested object schema" $ do + toolDefs <- fst typedHandlers anonCtx + let queryDef = toolNamed "query_data" toolDefs + case lookupProp "filters" queryDef of + Just prop -> do + schemaTypeName prop `shouldBe` "object" + map fst (schemaProps prop) `shouldBe` ["tags", "maxCount"] + schemaRequired prop `shouldBe` ["tags"] + Nothing -> expectationFailure "filters property missing" + + describe "Tool execution errors" $ do + it "reports handler failures as isError results, not protocol errors" $ do + result <- callTyped "always_fails" [("reason", String "boom")] + case completed result of + Right tr -> do + toolResultIsError tr `shouldBe` True + toolResultContent tr `shouldBe` [ContentText "boom"] + Left err -> expectationFailure $ "Expected isError result but got protocol error: " ++ show err + + describe "ToToolResult list semantics" $ do + it "propagates isError when merging a list of results" $ do + let merged = toToolResult [toolError "boom", toolResult [ContentText "ok"]] + toolResultIsError merged `shouldBe` True + toolResultContent merged `shouldBe` [ContentText "boom", ContentText "ok"] + + describe "Multi-message prompts" $ do + it "returns a described multi-message conversation with roles" $ do + result <- snd convHandlers anonCtx "conversation" (promptArgsMap [("topic", "haskell")]) + case completed result of + Right (PromptResult desc msgs) -> do + desc `shouldBe` Just "About haskell" + map promptMessageRole msgs `shouldBe` [RoleUser, RoleAssistant] + Left err -> expectationFailure $ "Expected prompt result but got: " ++ show err diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -5,6 +5,7 @@ import Data.Aeson import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as TE import MCP.Server.Protocol @@ -61,7 +62,8 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Result: √16 = 4, π ≈ 3.14159"] , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- 2025-06-18: New _meta field + , toolsCallStructuredContent = Nothing + , toolsCallMeta = Nothing } let encoded = encode response -- Just verify the JSON can be encoded and contains Unicode @@ -87,7 +89,8 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Mathematical result: √(π²+e²) ≈ 4.53"] , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- 2025-06-18: New _meta field + , toolsCallStructuredContent = Nothing + , toolsCallMeta = Nothing } let json = toJSON response -- Verify the JSON can be encoded and contains Unicode @@ -168,56 +171,45 @@ it "handles complete Unicode workflow without Template Haskell" $ do -- Create manual handlers with Unicode content let promptListHandler = return [ - PromptDefinition - { promptDefinitionName = "math_formula" - , promptDefinitionDescription = "Generate mathematical formulas with Unicode: ∀∃∈√" - , promptDefinitionArguments = [ArgumentDefinition "formula" "Mathematical expression" True] - , promptDefinitionTitle = Nothing -- 2025-06-18: New title field - } + mkPromptDefinition "math_formula" + "Generate mathematical formulas with Unicode: ∀∃∈√" + [ArgumentDefinition "formula" "Mathematical expression" True] ] let promptGetHandler name args = case name of - "math_formula" -> case lookup "formula" args of - Just formula -> return $ Right $ ContentText $ "Formula: " <> formula <> " → √(solution)" + "math_formula" -> case Map.lookup "formula" args of + Just formula -> return $ Right $ Complete $ toPromptResult $ ContentText $ "Formula: " <> formula <> " → √(solution)" Nothing -> return $ Left $ MissingRequiredParams "formula" _ -> return $ Left $ InvalidPromptName name let resourceListHandler = return [ - ResourceDefinition - { resourceDefinitionURI = "resource://unicode_symbols" - , resourceDefinitionName = "unicode_symbols" - , resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑" + (mkResourceDefinition "resource://unicode_symbols" "unicode_symbols") + { resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑" , resourceDefinitionMimeType = Just "text/plain" - , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field } ] let resourceReadHandler uri = if show uri == "resource://unicode_symbols" - then return $ Right $ ResourceText uri "text/plain" "Symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅" + then return $ Right $ Complete $ ResourceText uri "text/plain" "Symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅" else return $ Left $ ResourceNotFound $ T.pack $ show uri let toolListHandler = return [ - ToolDefinition - { toolDefinitionName = "calculate" - , toolDefinitionDescription = "Calculate with Unicode symbols: √∑∏" - , toolDefinitionInputSchema = InputSchemaDefinitionObject - { properties = [("expression", InputSchemaDefinitionProperty "string" "Mathematical expression")] - , required = ["expression"] - } - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } + mkToolDefinition "calculate" "Calculate with Unicode symbols: √∑∏" + (schema $ SchemaObject + [("expression", describedSchema "Mathematical expression" (SchemaString Nothing))] + ["expression"]) ] let toolCallHandler name args = case name of - "calculate" -> case lookup "expression" args of - Just expr -> return $ Right $ ContentText $ "Result: " <> expr <> " → √answer" - Nothing -> return $ Left $ MissingRequiredParams "expression" + "calculate" -> case Map.lookup "expression" args of + Just (String expr) -> return $ Right $ Complete $ toToolResult $ ContentText $ "Result: " <> expr <> " → √answer" + _ -> return $ Left $ MissingRequiredParams "expression" _ -> return $ Left $ UnknownTool name -- Handlers above ignore the per-request client context - let ctx = ClientContext Nothing Nothing - let handlers = McpServerHandlers + let ctx = anonymousContext + let handlers = noHandlers { prompts = Just (const promptListHandler, const promptGetHandler) , resources = Just (const resourceListHandler, const resourceReadHandler) , tools = Just (const toolListHandler, const toolCallHandler) @@ -234,9 +226,9 @@ toolList `shouldSatisfy` (not . null) -- Test actual Unicode handling - promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") ctx "math_formula" [("formula", "√(x²+y²)")] + promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") ctx "math_formula" (Map.fromList [("formula", "√(x²+y²)")]) case promptResult of - Right (ContentText txt) -> txt `shouldSatisfy` T.isInfixOf "√" + Right (Complete (PromptResult _ [PromptMessage _ (ContentText txt)])) -> txt `shouldSatisfy` T.isInfixOf "√" _ -> expectationFailure "Expected successful prompt result" uri <- case parseURI "resource://unicode_symbols" of @@ -244,12 +236,12 @@ Nothing -> fail "Invalid URI" resourceResult <- snd (case resources handlers of Just h -> h; Nothing -> error "No resources") ctx uri case resourceResult of - Right (ResourceText _ _ txt) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉" + Right (Complete (ResourceText _ _ txt)) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉" _ -> expectationFailure "Expected successful resource result" - toolResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") ctx "calculate" [("expression", "∫₀^∞ e^(-x²) dx = √π/2")] - case toolResult of - Right (ContentText txt) -> do + callResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") ctx "calculate" (Map.fromList [("expression", String "∫₀^∞ e^(-x²) dx = √π/2")]) + case callResult of + Right (Complete tr) | [ContentText txt] <- toolResultContent tr -> do txt `shouldSatisfy` T.isInfixOf "√" txt `shouldSatisfy` T.isInfixOf "∫" _ -> expectationFailure "Expected successful tool result" diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/TestHelpers.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared helpers for exercising the 0.2 handler API from tests. +module TestHelpers + ( -- * Building argument maps + stringArgs + , valueArgs + , promptArgsMap + -- * Result expectations + , completed + , shouldBeTextResult + , shouldBeTextResultContaining + , shouldBePromptText + -- * Request state + , testStateCodec + -- * Schema access + , schemaTypeName + , schemaProps + , schemaRequired + , lookupProp + ) where + +import Data.Aeson (Value (..)) +import qualified Data.ByteString as BS +import qualified Data.Aeson.KeyMap as KM +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import Test.Hspec + +-- | Tool arguments where every value is a JSON string (exercises the lenient +-- string-fallback parsing that pre-0.2 clients rely on). +stringArgs :: [(Text, Text)] -> Map Text Value +stringArgs = Map.fromList . map (fmap String) + +-- | Tool arguments with native JSON values. +valueArgs :: [(Text, Value)] -> Map Text Value +valueArgs = Map.fromList + +-- | Prompt arguments (string-valued per the MCP spec). +promptArgsMap :: [(Text, Text)] -> Map Text Text +promptArgsMap = Map.fromList + +-- | A handler result that should be complete, with an unexpected request +-- for input turned into an error so that a @case@ on it stays exhaustive. +completed :: Either Error (Outcome a) -> Either Error a +completed (Right (Complete a)) = Right a +completed (Right (InputRequired _ _)) = Left (InternalError "unexpected request for input") +completed (Left err) = Left err + +-- | Expect a successful, non-error tool result with exactly one text block. +shouldBeTextResult :: Either Error (Outcome ToolResult) -> Text -> Expectation +shouldBeTextResult (Right (Complete tr)) expected + | not (toolResultIsError tr) + , [ContentText content] <- toolResultContent tr = content `shouldBe` expected +shouldBeTextResult other expected = + expectationFailure $ "Expected text result '" ++ T.unpack expected ++ "' but got: " ++ show other + +-- | Like 'shouldBeTextResult' but with substring matching. +shouldBeTextResultContaining :: Either Error (Outcome ToolResult) -> Text -> Expectation +shouldBeTextResultContaining (Right (Complete tr)) expected + | not (toolResultIsError tr) + , [ContentText content] <- toolResultContent tr = + content `shouldSatisfy` T.isInfixOf expected +shouldBeTextResultContaining other expected = + expectationFailure $ "Expected text result containing '" ++ T.unpack expected ++ "' but got: " ++ show other + +-- | Expect a prompt result of a single user message with the given text. +shouldBePromptText :: Either Error (Outcome PromptResult) -> Text -> Expectation +shouldBePromptText (Right (Complete (PromptResult _ [PromptMessage RoleUser (ContentText content)]))) expected = + content `shouldBe` expected +shouldBePromptText other expected = + expectationFailure $ "Expected prompt text '" ++ T.unpack expected ++ "' but got: " ++ show other + +-- | A request-state codec with a fixed key, so tests need no IO to build +-- one and can open what the server sealed. +testStateCodec :: StateCodec +testStateCodec = case stateKey "test" (BS.replicate 32 7) of + Just key -> aeadStateCodec key [] + Nothing -> error "testStateCodec: invalid key" + +-- | The JSON Schema type keyword for a schema. +schemaTypeName :: Schema -> Text +schemaTypeName s = case schemaShape s of + SchemaString _ -> "string" + SchemaInteger -> "integer" + SchemaNumber -> "number" + SchemaBoolean -> "boolean" + SchemaArray _ -> "array" + SchemaObject _ _ -> "object" + SchemaRaw keywords -> case KM.lookup "type" keywords of + Just (String name) -> name + _ -> "raw" + +-- | The properties of an object schema (empty for non-objects). +schemaProps :: Schema -> [(Text, Schema)] +schemaProps s = case schemaShape s of + SchemaObject props _ -> props + _ -> [] + +-- | The required field names of an object schema. +schemaRequired :: Schema -> [Text] +schemaRequired s = case schemaShape s of + SchemaObject _ req -> req + _ -> [] + +-- | Look up a property schema in a tool's input schema. +lookupProp :: Text -> ToolDefinition -> Maybe Schema +lookupProp name def = lookup name (schemaProps (toolDefinitionInputSchema def)) diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -4,12 +4,16 @@ import Data.Text (Text) import qualified Data.Text as T -import MCP.Server (ClientContext(..), Content(..), ResourceContent(..)) +import MCP.Server (ClientContext, anonymousContext, Content (..), MessageRole (..), + PromptMessage (..), PromptResult (..), + ResourceContent (..), ToolOutput (..), + ToolResult, toolError, + toolResult) import Network.URI (URI) -- Context passed to handlers in tests (no transport-level identity) anonCtx :: ClientContext -anonCtx = ClientContext Nothing Nothing +anonCtx = anonymousContext -- Test data types for end-to-end testing data TestPrompt @@ -135,6 +139,100 @@ , "float=" <> maybe "Nothing" (T.pack . show) f , "bool=" <> maybe "Nothing" (T.pack . show) b ] + +-- Types exercising 0.2 typed arguments: enums, lists, nested records +data Color = Red | Green | Blue + deriving (Show, Eq) + +data Filters = Filters { tags :: [Text], maxCount :: Maybe Int } + deriving (Show, Eq) + +data TypedTool + = Paint { color :: Color, brightness :: Int } + | BulkAdd { values :: [Int] } + | QueryData { filters :: Filters } + | AlwaysFails { reason :: Text } + deriving (Show, Eq) + +handleTypedTool :: ClientContext -> TypedTool -> IO ToolResult +handleTypedTool _ (Paint c b) = + pure $ toolResult [ContentText $ "Painting " <> T.pack (show c) <> " at " <> T.pack (show b)] +handleTypedTool _ (BulkAdd vs) = + pure $ toolResult [ContentText $ "Sum: " <> T.pack (show (sum vs))] +handleTypedTool _ (QueryData (Filters ts mc)) = + pure $ toolResult [ContentText $ "Query tags=" <> T.intercalate "," ts + <> maybe "" ((" max=" <>) . T.pack . show) mc] +handleTypedTool _ (AlwaysFails msg) = + pure $ toolError msg + +-- Resource type mixing static resources and templates (record constructors) +data TemplResource + = Catalog + | MemberProfile { memberId :: Text } + | OrderItem { orderId :: Int, itemName :: Text } + deriving (Show, Eq) + +handleTemplResource :: ClientContext -> URI -> TemplResource -> IO ResourceContent +handleTemplResource _ uri Catalog = + pure $ ResourceText uri "text/plain" "The catalog" +handleTemplResource _ uri (MemberProfile uid) = + pure $ ResourceText uri "text/plain" ("Profile of " <> uid) +handleTemplResource _ uri (OrderItem oid item) = + pure $ ResourceText uri "text/plain" ("Order " <> T.pack (show oid) <> " item " <> item) + +-- Types exercising derived structured output (ADR 0005) +data Wind = Wind { windSpeedKph :: Double, windGusting :: Bool } + deriving (Show, Eq) + +data Sky = SkyClear | SkyCloudy | SkyRaining + deriving (Show, Eq) + +data WeatherReport = WeatherReport + { wrTemperature :: Int + , wrSky :: Sky + , wrWind :: Wind + , wrAlerts :: [Text] + , wrHumidity :: Maybe Int + } deriving (Show, Eq) + +data WeatherTool + = GetWeather { wtCity :: Text } + | BrokenStation { wtStation :: Text } + | CustomReport { wtRegion :: Text } + | PlainForecast { wtNote :: Text } + deriving (Show, Eq) + +sampleReport :: Text -> Maybe Int -> WeatherReport +sampleReport place humidity = WeatherReport + { wrTemperature = 21 + , wrSky = SkyCloudy + , wrWind = Wind 12.5 False + , wrAlerts = ["wind advisory for " <> place] + , wrHumidity = humidity + } + +handleWeatherTool :: ClientContext -> WeatherTool -> IO (ToolOutput WeatherReport) +handleWeatherTool _ (GetWeather c) = + pure $ ToolOutput (sampleReport c (Just 60)) +handleWeatherTool _ (BrokenStation s) = + pure $ ToolOutputError ("station offline: " <> s) +handleWeatherTool _ (CustomReport r) = + pure $ ToolOutputWith [ContentText ("Report for " <> r)] (sampleReport r Nothing) +handleWeatherTool _ (PlainForecast n) = + pure $ ToolOutputRaw (toolResult [ContentText n]) + +-- A prompt whose handler produces a multi-message conversation +data ConvPrompt = Conversation { topic :: Text } + deriving (Show, Eq) + +handleConvPrompt :: ClientContext -> ConvPrompt -> IO PromptResult +handleConvPrompt _ (Conversation t) = pure $ PromptResult + { promptResultDescription = Just ("About " <> t) + , promptResultMessages = + [ PromptMessage RoleUser (ContentText ("Tell me about " <> t)) + , PromptMessage RoleAssistant (ContentText ("Here is what I know about " <> t)) + ] + } -- Test descriptions for custom description functionality testDescriptions :: [(String, String)] diff --git a/test/golden/README.md b/test/golden/README.md new file mode 100644 --- /dev/null +++ b/test/golden/README.md @@ -0,0 +1,78 @@ +# MCP wire-format conformance corpus + +Each case in this directory is a pair of files: + +- `.request.json` — a single JSON-RPC request, exactly as it would + arrive on the wire (one line). +- `.response.json` — the reference server's exact response. + +`manifest.json` enumerates the cases and states, per case, which +reference-server variant answers it (`handlers`) and whether the serving +transport can deliver change notifications (`notifications`). Responses are +compared as **parsed JSON** (structural equality), not raw bytes, so object +key order never matters — with one deliberate exception: JSON embedded +*inside a string* (the structured-output text block) is compared as part of +the string, so those bytes are canonical: compact, object keys sorted. A +fixture string `""` matches any string: it stands for values a +server generates afresh, such as a sealed `requestState`. + +The corpus is deliberately **API-agnostic**: nothing in it refers to this +library's types or Haskell at all. Any MCP server implementation that +reproduces the reference server below can replay the requests and diff the +responses — the cases then pin protocol behavior (error codes, era +envelopes, capability advertisement) rather than any particular API. + +## Eras + +- `legacy/` — requests carry no modern `_meta`; they are answered under the + revision negotiated by `initialize` (2024-11-05 … 2025-11-25 share this + wire format for the operations covered here). These fixtures were + generated from mcp-server v0.2.0 and are the anchor for "newer protocol + work leaves legacy responses unchanged" — **never regenerate them** from a + branch that intends to preserve legacy output. +- `modern/` — requests declare a revision (2026-07-28) in params `_meta`; + responses carry the modern envelope: `resultType`, server identity in + result `_meta`, and `ttlMs`/`cacheScope` on the cacheable methods. + +## The reference server + +Identity: name `Golden Server`, version `1.0.0`, instructions +`Golden fixture server`. Cache hints: `ttlMs` 0, scope `private`. + +The `base` handler set: + +| Feature | Definition | Behavior | +|---|---|---| +| Tool `echo` | input schema: object, required `text` (string, described "The text") | returns one text content block `echo: ` | +| Tool `boom` | not listed | any call returns `isError: true` with text `kaboom` | +| Prompt `greet` | one required argument `name` ("Who to greet") | description `A greeting`, one user message `Hello, !` | +| Resource `resource://info` | name `info`, description `Some info`, `text/plain` | text contents `The golden info` | + +The `extended` handler set adds (used only for methods that postdate the +v0.2.0 anchor, so the anchored capability fixtures stay untouched): + +| Feature | Definition | Behavior | +|---|---|---| +| Resource template `resource://item/{itemId}` | name `item`, description `An item`, `text/plain` | — | +| Completions | any ref/argument | values = `["alpha", "beta"]` filtered by prefix of the partial value | +| Tool `echo_structured` | input schema: object, required `input` (string, "The text"); output schema: object, required `echoedText` (string, "The echoed text") and `echoedLength` (integer, "Its length"); description `Echo with structured output` | returns `structuredContent` `{"echoedText": , "echoedLength": }` plus one text content block containing the same JSON | +| Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: ` annotated with audience `["user"]`, priority `0.5` | + +The `mrtr` handler set is the `base` set with one tool, which asks for +input (multi round-trip requests, 2026-07-28): + +| Feature | Definition | Behavior | +|---|---|---| +| Tool `confirm` | not listed | without an answer under `proceed`: an `input_required` result asking, under the key `proceed`, for an `elicitation/create` form (message `Proceed?`, schema: object, required boolean `ok`), with a request state; with one: one text block `confirmed` | + +Cases with `"notifications": true` are answered as if the transport can +deliver change notifications (stdio with a configured notifier: legacy push +and modern `subscriptions/listen`), which flips the advertised +`listChanged`/`subscribe` capability flags. + +## Adding a case + +Write the `.request.json` by hand, add a manifest entry, and run the test +suite with `GOLDEN_ACCEPT=1`: the missing `.response.json` is written from +the current implementation's output. Existing response fixtures are never +overwritten — delete one first to regenerate it deliberately. diff --git a/test/golden/legacy/completion-complete.request.json b/test/golden/legacy/completion-complete.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/completion-complete.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":12,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"}}} diff --git a/test/golden/legacy/completion-complete.response.json b/test/golden/legacy/completion-complete.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/completion-complete.response.json @@ -0,0 +1,1 @@ +{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}} diff --git a/test/golden/legacy/initialize-notifying.request.json b/test/golden/legacy/initialize-notifying.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize-notifying.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":13,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}} diff --git a/test/golden/legacy/initialize-notifying.response.json b/test/golden/legacy/initialize-notifying.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize-notifying.response.json @@ -0,0 +1,1 @@ +{"id":13,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true},"tools":{"listChanged":true}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}} diff --git a/test/golden/legacy/initialize.request.json b/test/golden/legacy/initialize.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}} diff --git a/test/golden/legacy/initialize.response.json b/test/golden/legacy/initialize.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize.response.json @@ -0,0 +1,1 @@ +{"id":1,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{},"resources":{},"tools":{}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}} diff --git a/test/golden/legacy/ping.request.json b/test/golden/legacy/ping.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/ping.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":2,"method":"ping"} diff --git a/test/golden/legacy/ping.response.json b/test/golden/legacy/ping.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/ping.response.json @@ -0,0 +1,1 @@ +{"id":2,"jsonrpc":"2.0","result":{}} diff --git a/test/golden/legacy/prompts-get.request.json b/test/golden/legacy/prompts-get.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-get.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":8,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"}}} diff --git a/test/golden/legacy/prompts-get.response.json b/test/golden/legacy/prompts-get.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-get.response.json @@ -0,0 +1,1 @@ +{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}} diff --git a/test/golden/legacy/prompts-list.request.json b/test/golden/legacy/prompts-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":7,"method":"prompts/list"} diff --git a/test/golden/legacy/prompts-list.response.json b/test/golden/legacy/prompts-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-list.response.json @@ -0,0 +1,1 @@ +{"id":7,"jsonrpc":"2.0","result":{"prompts":[{"arguments":[{"description":"Who to greet","name":"name","required":true}],"description":"Greet someone","name":"greet"}]}} diff --git a/test/golden/legacy/resources-list.request.json b/test/golden/legacy/resources-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":9,"method":"resources/list"} diff --git a/test/golden/legacy/resources-list.response.json b/test/golden/legacy/resources-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-list.response.json @@ -0,0 +1,1 @@ +{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}} diff --git a/test/golden/legacy/resources-read.request.json b/test/golden/legacy/resources-read.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-read.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":10,"method":"resources/read","params":{"uri":"resource://info"}} diff --git a/test/golden/legacy/resources-read.response.json b/test/golden/legacy/resources-read.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-read.response.json @@ -0,0 +1,1 @@ +{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}} diff --git a/test/golden/legacy/resources-templates-list.request.json b/test/golden/legacy/resources-templates-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-templates-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":11,"method":"resources/templates/list"} diff --git a/test/golden/legacy/resources-templates-list.response.json b/test/golden/legacy/resources-templates-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-templates-list.response.json @@ -0,0 +1,1 @@ +{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}} diff --git a/test/golden/legacy/tools-call-annotated.request.json b/test/golden/legacy/tools-call-annotated.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":16,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"}}} diff --git a/test/golden/legacy/tools-call-annotated.response.json b/test/golden/legacy/tools-call-annotated.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.response.json @@ -0,0 +1,1 @@ +{"id":16,"jsonrpc":"2.0","result":{"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}]}} diff --git a/test/golden/legacy/tools-call-boom.request.json b/test/golden/legacy/tools-call-boom.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-boom.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":6,"method":"tools/call","params":{"name":"boom","arguments":{}}} diff --git a/test/golden/legacy/tools-call-boom.response.json b/test/golden/legacy/tools-call-boom.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-boom.response.json @@ -0,0 +1,1 @@ +{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}} diff --git a/test/golden/legacy/tools-call-echo.request.json b/test/golden/legacy/tools-call-echo.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-echo.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"}}} diff --git a/test/golden/legacy/tools-call-echo.response.json b/test/golden/legacy/tools-call-echo.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-echo.response.json @@ -0,0 +1,1 @@ +{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}} diff --git a/test/golden/legacy/tools-call-input-required.request.json b/test/golden/legacy/tools-call-input-required.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-input-required.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":43,"method":"tools/call","params":{"name":"confirm","arguments":{}}} diff --git a/test/golden/legacy/tools-call-input-required.response.json b/test/golden/legacy/tools-call-input-required.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-input-required.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32603,"message":"Internal error: the handler requested input, which the client's protocol revision does not support"},"id":43,"jsonrpc":"2.0"} diff --git a/test/golden/legacy/tools-call-structured.request.json b/test/golden/legacy/tools-call-structured.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-structured.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":15,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"}}} diff --git a/test/golden/legacy/tools-call-structured.response.json b/test/golden/legacy/tools-call-structured.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-structured.response.json @@ -0,0 +1,1 @@ +{"id":15,"jsonrpc":"2.0","result":{"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"structuredContent":{"echoedLength":6,"echoedText":"golden"}}} diff --git a/test/golden/legacy/tools-call-unknown.request.json b/test/golden/legacy/tools-call-unknown.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-unknown.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"nope","arguments":{}}} diff --git a/test/golden/legacy/tools-call-unknown.response.json b/test/golden/legacy/tools-call-unknown.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-unknown.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"} diff --git a/test/golden/legacy/tools-list-extended.request.json b/test/golden/legacy/tools-list-extended.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list-extended.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":14,"method":"tools/list"} diff --git a/test/golden/legacy/tools-list-extended.response.json b/test/golden/legacy/tools-list-extended.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list-extended.response.json @@ -0,0 +1,1 @@ +{"id":14,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"},{"description":"Echo with structured output","inputSchema":{"properties":{"input":{"description":"The text","type":"string"}},"required":["input"],"type":"object"},"name":"echo_structured","outputSchema":{"properties":{"echoedLength":{"description":"Its length","type":"integer"},"echoedText":{"description":"The echoed text","type":"string"}},"required":["echoedText","echoedLength"],"type":"object"}},{"annotations":{"idempotentHint":true,"readOnlyHint":true},"description":"A read-only probe","icons":[{"src":"https://example.com/probe.png"}],"inputSchema":{"properties":{"probe":{"description":"What to probe","type":"string"}},"required":["probe"],"type":"object"},"name":"annotated_probe","title":"Probe"}]}} diff --git a/test/golden/legacy/tools-list.request.json b/test/golden/legacy/tools-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":3,"method":"tools/list"} diff --git a/test/golden/legacy/tools-list.response.json b/test/golden/legacy/tools-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list.response.json @@ -0,0 +1,1 @@ +{"id":3,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}]}} diff --git a/test/golden/manifest.json b/test/golden/manifest.json new file mode 100644 --- /dev/null +++ b/test/golden/manifest.json @@ -0,0 +1,171 @@ +{ + "description": "Wire-level MCP conformance corpus: each case is a JSON-RPC request and the reference server's exact response, per protocol era. See README.md for the reference server definition.", + "comparison": "parsed-json-equality", + "cases": [ + { + "name": "legacy/completion-complete", + "handlers": "extended", + "notifications": false + }, + { + "name": "legacy/initialize", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/initialize-notifying", + "handlers": "base", + "notifications": true + }, + { + "name": "legacy/ping", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/prompts-get", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/prompts-list", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/resources-list", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/resources-read", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/resources-templates-list", + "handlers": "extended", + "notifications": false + }, + { + "name": "legacy/tools-call-annotated", + "handlers": "extended", + "notifications": false + }, + { + "name": "legacy/tools-call-boom", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/tools-call-echo", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/tools-call-input-required", + "handlers": "mrtr", + "notifications": false + }, + { + "name": "legacy/tools-call-structured", + "handlers": "extended", + "notifications": false + }, + { + "name": "legacy/tools-call-unknown", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/tools-list", + "handlers": "base", + "notifications": false + }, + { + "name": "legacy/tools-list-extended", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/completion-complete", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/initialize", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/ping", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/prompts-get", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/resources-read", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/resources-templates-list", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/server-discover", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/server-discover-notifying", + "handlers": "base", + "notifications": true + }, + { + "name": "modern/tools-call-annotated", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/tools-call-echo", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/tools-call-input-required", + "handlers": "mrtr", + "notifications": false + }, + { + "name": "modern/tools-call-input-unsupported", + "handlers": "mrtr", + "notifications": false + }, + { + "name": "modern/tools-call-invalid-request-state", + "handlers": "mrtr", + "notifications": false + }, + { + "name": "modern/tools-call-structured", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/tools-list", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/unsupported-version", + "handlers": "base", + "notifications": false + } + ] +} diff --git a/test/golden/modern/completion-complete.request.json b/test/golden/modern/completion-complete.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/completion-complete.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":30,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/completion-complete.response.json b/test/golden/modern/completion-complete.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/completion-complete.response.json @@ -0,0 +1,1 @@ +{"id":30,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"completion":{"values":["alpha"]},"resultType":"complete"}} diff --git a/test/golden/modern/initialize.request.json b/test/golden/modern/initialize.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/initialize.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":27,"method":"initialize","params":{"protocolVersion":"2026-07-28","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/initialize.response.json b/test/golden/modern/initialize.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/initialize.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32601,"message":"Method not found: initialize (not part of protocol revision 2026-07-28)"},"id":27,"jsonrpc":"2.0"} diff --git a/test/golden/modern/ping.request.json b/test/golden/modern/ping.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/ping.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":28,"method":"ping","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/ping.response.json b/test/golden/modern/ping.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/ping.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32601,"message":"Method not found: ping (not part of protocol revision 2026-07-28)"},"id":28,"jsonrpc":"2.0"} diff --git a/test/golden/modern/prompts-get.request.json b/test/golden/modern/prompts-get.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/prompts-get.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":24,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/prompts-get.response.json b/test/golden/modern/prompts-get.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/prompts-get.response.json @@ -0,0 +1,1 @@ +{"id":24,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}],"resultType":"complete"}} diff --git a/test/golden/modern/resources-read.request.json b/test/golden/modern/resources-read.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-read.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":25,"method":"resources/read","params":{"uri":"resource://info","_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/resources-read.response.json b/test/golden/modern/resources-read.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-read.response.json @@ -0,0 +1,1 @@ +{"id":25,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}],"resultType":"complete","ttlMs":0}} diff --git a/test/golden/modern/resources-templates-list.request.json b/test/golden/modern/resources-templates-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-templates-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":29,"method":"resources/templates/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/resources-templates-list.response.json b/test/golden/modern/resources-templates-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-templates-list.response.json @@ -0,0 +1,1 @@ +{"id":29,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}],"resultType":"complete","ttlMs":0}} diff --git a/test/golden/modern/server-discover-notifying.request.json b/test/golden/modern/server-discover-notifying.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover-notifying.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":31,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/server-discover-notifying.response.json b/test/golden/modern/server-discover-notifying.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover-notifying.response.json @@ -0,0 +1,1 @@ +{"id":31,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true,"subscribe":true},"tools":{"listChanged":true}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}} diff --git a/test/golden/modern/server-discover.request.json b/test/golden/modern/server-discover.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":21,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/server-discover.response.json b/test/golden/modern/server-discover.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover.response.json @@ -0,0 +1,1 @@ +{"id":21,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{},"resources":{},"tools":{}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}} diff --git a/test/golden/modern/tools-call-annotated.request.json b/test/golden/modern/tools-call-annotated.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-annotated.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":33,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-annotated.response.json b/test/golden/modern/tools-call-annotated.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-annotated.response.json @@ -0,0 +1,1 @@ +{"id":33,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}],"resultType":"complete"}} diff --git a/test/golden/modern/tools-call-echo.request.json b/test/golden/modern/tools-call-echo.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-echo.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":23,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-echo.response.json b/test/golden/modern/tools-call-echo.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-echo.response.json @@ -0,0 +1,1 @@ +{"id":23,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"echo: hi","type":"text"}],"resultType":"complete"}} diff --git a/test/golden/modern/tools-call-input-required.request.json b/test/golden/modern/tools-call-input-required.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-required.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":40,"method":"tools/call","params":{"name":"confirm","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{"elicitation":{}}}}} diff --git a/test/golden/modern/tools-call-input-required.response.json b/test/golden/modern/tools-call-input-required.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-required.response.json @@ -0,0 +1,1 @@ +{"id":40,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"inputRequests":{"proceed":{"method":"elicitation/create","params":{"message":"Proceed?","mode":"form","requestedSchema":{"properties":{"ok":{"type":"boolean"}},"required":["ok"],"type":"object"}}}},"requestState":"","resultType":"input_required"}} diff --git a/test/golden/modern/tools-call-input-unsupported.request.json b/test/golden/modern/tools-call-input-unsupported.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-unsupported.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":42,"method":"tools/call","params":{"name":"confirm","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-input-unsupported.response.json b/test/golden/modern/tools-call-input-unsupported.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-unsupported.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32603,"message":"Internal error: the handler requested input the client cannot provide (proceed)"},"id":42,"jsonrpc":"2.0"} diff --git a/test/golden/modern/tools-call-invalid-request-state.request.json b/test/golden/modern/tools-call-invalid-request-state.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-invalid-request-state.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":41,"method":"tools/call","params":{"name":"confirm","arguments":{},"inputResponses":{"proceed":{"action":"accept","content":{"ok":true}}},"requestState":"test.not-a-sealed-state","_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{"elicitation":{}}}}} diff --git a/test/golden/modern/tools-call-invalid-request-state.response.json b/test/golden/modern/tools-call-invalid-request-state.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-invalid-request-state.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32602,"message":"Invalid requestState"},"id":41,"jsonrpc":"2.0"} diff --git a/test/golden/modern/tools-call-structured.request.json b/test/golden/modern/tools-call-structured.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-structured.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":32,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-structured.response.json b/test/golden/modern/tools-call-structured.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-structured.response.json @@ -0,0 +1,1 @@ +{"id":32,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"resultType":"complete","structuredContent":{"echoedLength":6,"echoedText":"golden"}}} diff --git a/test/golden/modern/tools-list.request.json b/test/golden/modern/tools-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-list.response.json b/test/golden/modern/tools-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-list.response.json @@ -0,0 +1,1 @@ +{"id":22,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resultType":"complete","tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}],"ttlMs":0}} diff --git a/test/golden/modern/unsupported-version.request.json b/test/golden/modern/unsupported-version.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/unsupported-version.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2099-01-01"}}} diff --git a/test/golden/modern/unsupported-version.response.json b/test/golden/modern/unsupported-version.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/unsupported-version.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32022,"data":{"requested":"2099-01-01","supported":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"]},"message":"Unsupported protocol version"},"id":26,"jsonrpc":"2.0"}