packages feed

mcp-server 0.1.0.21 → 0.3.0.1

raw patch · 117 files changed

Files

CHANGELOG.md view
@@ -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
README.md view
@@ -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
+ examples/Ask/Main.hs view
@@ -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 } })+                ])+            }
+ examples/Ask/Types.hs view
@@ -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")])
examples/Complete/Main.hs view
@@ -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             }
examples/Complete/Types.hs view
@@ -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)
examples/HttpSimple/Main.hs view
@@ -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             }
examples/Simple/Main.hs view
@@ -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             }
mcp-server.cabal view
@@ -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,
src/MCP/Server.hs view
@@ -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
+ src/MCP/Server/Ask.hs view
@@ -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"
src/MCP/Server/Derive.hs view
@@ -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 <ConType>@ 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' \<output\>@, 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
src/MCP/Server/Derive/Internal.hs view
@@ -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 @\<prefix\>{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)]]
src/MCP/Server/Handlers.hs view
@@ -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/\<key\>@ 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
+ src/MCP/Server/Internal/InputRound.hs view
@@ -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
+ src/MCP/Server/Internal/Json.hs view
@@ -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
src/MCP/Server/JsonRpc.hs view
@@ -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
+ src/MCP/Server/Notifications.hs view
@@ -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+          ]+      ]+  ]
src/MCP/Server/Protocol.hs view
@@ -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
+ src/MCP/Server/RequestState.hs view
@@ -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: @<key id>.<base64url(nonce || ciphertext || tag)>@. 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))
src/MCP/Server/Transport/Http.hs view
@@ -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
src/MCP/Server/Transport/Stdio.hs view
@@ -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)
src/MCP/Server/Types.hs view
@@ -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   }
+ test/AskTypes.hs view
@@ -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"
test/HspecMain.hs view
@@ -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
test/Spec/AdvancedDerivation.hs view
@@ -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
+ test/Spec/AskMonad.hs view
@@ -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)")
test/Spec/BasicDerivation.hs view
@@ -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"
+ test/Spec/Cancellation.hs view
@@ -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
+ test/Spec/DefinitionMetadata.hs view
@@ -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
+ test/Spec/DerivedAsk.hs view
@@ -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"
+ test/Spec/DerivedOutput.hs view
@@ -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
+ test/Spec/GoldenWire.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Golden wire-format conformance corpus: @test/golden/@ holds, per case,+-- a JSON-RPC request (@\<name\>.request.json@) and the reference server's+-- exact response (@\<name\>.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 @"<opaque>"@ 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 "<opaque>") (String _) = String "<opaque>"+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
+ test/Spec/HandlerExceptions.hs view
@@ -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"
+ test/Spec/HttpTransport.hs view
@@ -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`))
+ test/Spec/InputRequired.hs view
@@ -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)
test/Spec/JSONConversion.hs view
@@ -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)
+ test/Spec/ModernEra.hs view
@@ -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, 世界"
+ test/Spec/Progress.hs view
@@ -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` []
test/Spec/ProtocolVersionNegotiation.hs view
@@ -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.
+ test/Spec/RawSchema.hs view
@@ -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
test/Spec/SchemaValidation.hs view
@@ -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 =
+ test/Spec/Subscriptions.hs view
@@ -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 [])
+ test/Spec/TemplatesCompletions.hs view
@@ -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
test/Spec/ToolCallParsing.hs view
@@ -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
+ test/Spec/TypedArgs.hs view
@@ -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
test/Spec/UnicodeHandling.hs view
@@ -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"
+ test/TestHelpers.hs view
@@ -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))
test/TestTypes.hs view
@@ -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)]
+ test/golden/README.md view
@@ -0,0 +1,78 @@+# MCP wire-format conformance corpus++Each case in this directory is a pair of files:++- `<name>.request.json` — a single JSON-RPC request, exactly as it would+  arrive on the wire (one line).+- `<name>.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 `"<opaque>"` 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: <text>` |+| 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, <name>!` |+| 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": <input>, "echoedLength": <length>}` 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: <probe>` 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.
+ test/golden/legacy/completion-complete.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":12,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"}}}
+ test/golden/legacy/completion-complete.response.json view
@@ -0,0 +1,1 @@+{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}}
+ test/golden/legacy/initialize-notifying.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":13,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}}
+ test/golden/legacy/initialize-notifying.response.json view
@@ -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"}}}
+ test/golden/legacy/initialize.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}}
+ test/golden/legacy/initialize.response.json view
@@ -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"}}}
+ test/golden/legacy/ping.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":2,"method":"ping"}
+ test/golden/legacy/ping.response.json view
@@ -0,0 +1,1 @@+{"id":2,"jsonrpc":"2.0","result":{}}
+ test/golden/legacy/prompts-get.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":8,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"}}}
+ test/golden/legacy/prompts-get.response.json view
@@ -0,0 +1,1 @@+{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}}
+ test/golden/legacy/prompts-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":7,"method":"prompts/list"}
+ test/golden/legacy/prompts-list.response.json view
@@ -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"}]}}
+ test/golden/legacy/resources-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":9,"method":"resources/list"}
+ test/golden/legacy/resources-list.response.json view
@@ -0,0 +1,1 @@+{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}}
+ test/golden/legacy/resources-read.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":10,"method":"resources/read","params":{"uri":"resource://info"}}
+ test/golden/legacy/resources-read.response.json view
@@ -0,0 +1,1 @@+{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}}
+ test/golden/legacy/resources-templates-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":11,"method":"resources/templates/list"}
+ test/golden/legacy/resources-templates-list.response.json view
@@ -0,0 +1,1 @@+{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}}
+ test/golden/legacy/tools-call-annotated.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":16,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"}}}
+ test/golden/legacy/tools-call-annotated.response.json view
@@ -0,0 +1,1 @@+{"id":16,"jsonrpc":"2.0","result":{"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}]}}
+ test/golden/legacy/tools-call-boom.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":6,"method":"tools/call","params":{"name":"boom","arguments":{}}}
+ test/golden/legacy/tools-call-boom.response.json view
@@ -0,0 +1,1 @@+{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}}
+ test/golden/legacy/tools-call-echo.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"}}}
+ test/golden/legacy/tools-call-echo.response.json view
@@ -0,0 +1,1 @@+{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}}
+ test/golden/legacy/tools-call-input-required.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":43,"method":"tools/call","params":{"name":"confirm","arguments":{}}}
+ test/golden/legacy/tools-call-input-required.response.json view
@@ -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"}
+ test/golden/legacy/tools-call-structured.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":15,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"}}}
+ test/golden/legacy/tools-call-structured.response.json view
@@ -0,0 +1,1 @@+{"id":15,"jsonrpc":"2.0","result":{"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"structuredContent":{"echoedLength":6,"echoedText":"golden"}}}
+ test/golden/legacy/tools-call-unknown.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"nope","arguments":{}}}
+ test/golden/legacy/tools-call-unknown.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"}
+ test/golden/legacy/tools-list-extended.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":14,"method":"tools/list"}
+ test/golden/legacy/tools-list-extended.response.json view
@@ -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"}]}}
+ test/golden/legacy/tools-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":3,"method":"tools/list"}
+ test/golden/legacy/tools-list.response.json view
@@ -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"}]}}
+ test/golden/manifest.json view
@@ -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+    }+  ]+}
+ test/golden/modern/completion-complete.request.json view
@@ -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":{}}}}
+ test/golden/modern/completion-complete.response.json view
@@ -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"}}
+ test/golden/modern/initialize.request.json view
@@ -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":{}}}}
+ test/golden/modern/initialize.response.json view
@@ -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"}
+ test/golden/modern/ping.request.json view
@@ -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":{}}}}
+ test/golden/modern/ping.response.json view
@@ -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"}
+ test/golden/modern/prompts-get.request.json view
@@ -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":{}}}}
+ test/golden/modern/prompts-get.response.json view
@@ -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"}}
+ test/golden/modern/resources-read.request.json view
@@ -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":{}}}}
+ test/golden/modern/resources-read.response.json view
@@ -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}}
+ test/golden/modern/resources-templates-list.request.json view
@@ -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":{}}}}
+ test/golden/modern/resources-templates-list.response.json view
@@ -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}}
+ test/golden/modern/server-discover-notifying.request.json view
@@ -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":{}}}}
+ test/golden/modern/server-discover-notifying.response.json view
@@ -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}}
+ test/golden/modern/server-discover.request.json view
@@ -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":{}}}}
+ test/golden/modern/server-discover.response.json view
@@ -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}}
+ test/golden/modern/tools-call-annotated.request.json view
@@ -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":{}}}}
+ test/golden/modern/tools-call-annotated.response.json view
@@ -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"}}
+ test/golden/modern/tools-call-echo.request.json view
@@ -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":{}}}}
+ test/golden/modern/tools-call-echo.response.json view
@@ -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"}}
+ test/golden/modern/tools-call-input-required.request.json view
@@ -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":{}}}}}
+ test/golden/modern/tools-call-input-required.response.json view
@@ -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":"<opaque>","resultType":"input_required"}}
+ test/golden/modern/tools-call-input-unsupported.request.json view
@@ -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":{}}}}
+ test/golden/modern/tools-call-input-unsupported.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32603,"message":"Internal error: the handler requested input the client cannot provide (proceed)"},"id":42,"jsonrpc":"2.0"}
+ test/golden/modern/tools-call-invalid-request-state.request.json view
@@ -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":{}}}}}
+ test/golden/modern/tools-call-invalid-request-state.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32602,"message":"Invalid requestState"},"id":41,"jsonrpc":"2.0"}
+ test/golden/modern/tools-call-structured.request.json view
@@ -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":{}}}}
+ test/golden/modern/tools-call-structured.response.json view
@@ -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"}}}
+ test/golden/modern/tools-list.request.json view
@@ -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":{}}}}
+ test/golden/modern/tools-list.response.json view
@@ -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}}
+ test/golden/modern/unsupported-version.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2099-01-01"}}}
+ test/golden/modern/unsupported-version.response.json view
@@ -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"}