diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,230 @@ # Revision history for mcp-server -## 0.1.0.21 - ??? +## 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 +248,7 @@ * `http-simple-example` is now built with `-threaded`, which Warp requires; previously every request crashed with a `TimerManager` error. -## 0.1.0.20 - ??? +## 0.1.0.20 - 2026-07-31 * Fix protocol version negotiation: echo back any compatible revision the client proposes (`2024-11-05`, `2025-03-26`, `2025-06-18`, `2025-11-25`) instead of diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ ## Features -- **Complete MCP Implementation**: Negotiates MCP protocol revisions `2024-11-05` through `2025-11-25` (the shared wire format for tool/resource/prompt operations) +- **Complete MCP Implementation**: Dual-era server — legacy revisions `2024-11-05` through `2025-11-25` via the `initialize` handshake, and the stateless `2026-07-28` revision via per-request `_meta` (including `server/discover`, `resultType`, and cacheability fields) - **Type-Safe API**: Leverage Haskell's type system for robust MCP servers - **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces - **Template Haskell Support**: Automatic handler derivation from data types @@ -14,7 +14,12 @@ - ✅ **Prompts**: User-controlled prompt templates with arguments - ✅ **Resources**: Application-controlled readable resources +- ✅ **Resource Templates**: Parameterized resources via URI templates - ✅ **Tools**: Model-controlled callable functions +- ✅ **Completions**: Argument autocompletion for prompts and templates +- ✅ **Change Notifications**: `listChanged`/resource-update pushes, via `subscriptions/listen` (2026-07-28) or legacy stdio delivery +- ✅ **Progress & Logging**: `notifications/progress` and `notifications/message` scoped to the requesting client +- ✅ **Cancellation**: `notifications/cancelled` (stdio) and stream closure (HTTP) interrupt in-flight handlers - ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation - ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses @@ -33,6 +38,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +import Data.Text (Text) import MCP.Server import MCP.Server.Derive @@ -55,6 +61,11 @@ handleTool _ (Search query) = pure $ ContentText $ "Search results for " <> query handleTool _ (Order item) = pure $ ContentText $ "Ordered " <> item +-- Template Haskell staging: this empty splice ends the declaration group, +-- so the derive splices below can see the types above. (Alternatively, +-- declare the types in a separate module, as the examples/ do.) +$(pure []) + -- Derive handlers automatically main :: IO () main = runMcpServerStdio serverInfo handlers @@ -64,7 +75,10 @@ , serverVersion = "1.0.0" , serverInstructions = "A sample MCP server" } - handlers = McpServerHandlers + -- Start from 'noHandlers' and record-update the features you provide: + -- constructing McpServerHandlers directly breaks (at runtime!) when a + -- field is missed, and the library grows new handler slots over time. + handlers = noHandlers { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) , tools = Just $(deriveToolHandler ''MyTool 'handleTool) @@ -82,19 +96,78 @@ -- Becomes: "get_value", "set_value", "search_items" ``` -#### Automatic Type Conversion +#### Typed Tool Arguments -The derivation system automatically converts Text arguments to appropriate Haskell types: +Tool arguments are decoded from full JSON values, and the generated +`inputSchema` mirrors the field types: ```haskell -data MyTool = Calculate { number :: Int, factor :: Double, enabled :: Bool } --- Text "42" -> Int 42 --- Text "3.14" -> Double 3.14 --- Text "true" -> Bool True +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 + } + +data MyTool = Search + { query :: Text + , color :: Color -- "red" | "green" | "blue" + , filters :: Filters -- { "tags": [...], "maxCount": ... } + , limit :: Maybe Int + } ``` -Supported conversions: `Int`, `Integer`, `Double`, `Float`, `Bool`, and `Text` (no conversion). +Primitive fields (`Int`, `Integer`, `Double`, `Float`, `Bool`, `Text`) are +parsed leniently: the native JSON type and its string representation are +both accepted (`42` or `"42"`), since many clients send numbers and +booleans as strings. +Prompt arguments are string-valued per the MCP specification, so prompt +records are limited to primitive and enumeration fields. + +#### Tool Results + +Simple handlers can return plain `Content` (or `Text`). Return a full +`ToolResult` for multiple content blocks, structured content, or to report +execution failures with `isError` — which the spec prefers over protocol +errors, so the model can see what went wrong and react: + +```haskell +handleTool :: ClientContext -> MyTool -> IO ToolResult +handleTool _ (Search q _ _ _) + | T.null q = pure $ toolError "query must not be empty" + | otherwise = pure $ toolResult [ContentText ("Results for " <> q)] +``` + +Prompt handlers can likewise return a `PromptResult` with a description and +a multi-message conversation (user and assistant roles). + +#### Derived Output Schemas + +Tools can be typed on the way out too: give the derivation a result record +and it derives the tool's `outputSchema` (same field rules as inputs — +primitives, `Maybe`, lists, enums, nested records) and serializes your typed +values into `structuredContent`, guaranteed to match the schema. Per the +spec's recommendation, the JSON is also returned as a text content block for +clients that predate structured output: + +```haskell +data WeatherReport = WeatherReport + { temperature :: Int + , sky :: Sky -- enum + , alerts :: [Text] + , humidity :: Maybe Int -- optional, 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`. + #### Nested Parameter Types You can nest parameter types with automatic unwrapping: @@ -122,6 +195,44 @@ -- Generates: "resource://menu", "resource://specials" ``` +#### Resource Templates + +Record constructors become parameterized resource *templates* (RFC 6570 URI +templates), with one percent-decoded path segment per field: + +```haskell +data MyResource + = Menu -- static: resource://menu + | ProductDetail { sku :: Text } -- resource://product_detail/{sku} + | OrderItem { orderId :: Int, itemName :: Text } -- resource://order_item/{orderId}/{itemName} +``` + +The read handler derived by `deriveResourceHandler` matches template URIs +(e.g. `resource://product_detail/ABC123`) and decodes the segments into the +constructor's fields — typed fields like `Int` are parsed, and a failing +segment yields an invalid-params error. Advertise the templates via +`resources/templates/list` with: + +```haskell +resourceTemplates = Just $(deriveResourceTemplates ''MyResource) +``` + +#### Argument Completion + +Provide a `completions` handler to serve `completion/complete` for prompt +arguments and resource-template parameters: + +```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 [] +``` + +The `completions` capability is advertised automatically when the handler is +present. + #### Unsupported Patterns We do not support positional (unnamed) parameters: @@ -135,6 +246,33 @@ All parameter types must ultimately resolve to records with named fields to generate proper MCP schemas. +#### Tool Annotations, Icons and Titles + +The `WithOptions` derivation variants take per-constructor +`DefinitionOptions` — description, title, icons, behavioral annotations +(which drive client permission UX, e.g. auto-approving read-only tools), +and argument descriptions scoped to the constructor: + +```haskell +tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("Search", defaultDefinitionOptions + { optDescription = Just "Search the catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optIcons = [icon "https://example.com/search.png"] + , optFieldDescriptions = [("q", "Search terms")] + }) + ]) +``` + +Content blocks can carry annotations too (`audience`, `priority`, +`lastModified`), attached with the `ContentAnnotated` wrapper: + +```haskell +ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 } + (ContentText "important result") +``` + ## Custom Descriptions You can provide custom descriptions for constructors and fields using the `*WithDescription` variants: @@ -150,7 +288,7 @@ ] -- Use in derivation -handlers = McpServerHandlers +handlers = noHandlers { prompts = Just $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt descriptions) , tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) , resources = Just $(deriveResourceHandlerWithDescription ''MyResource 'handleResource descriptions) @@ -165,23 +303,113 @@ import MCP.Server -- Manual handler implementation. Every handler receives the per-request --- 'ClientContext' as its first argument. +-- 'ClientContext' as its first argument. Prompt arguments are string-valued +-- (Map Text Text); tool arguments are full JSON values (Map Text Value). promptListHandler :: ClientContext -> IO [PromptDefinition] -promptGetHandler :: ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content) +promptGetHandler :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) -- ... implement your custom logic main :: IO () main = runMcpServerStdio serverInfo handlers where - handlers = McpServerHandlers + handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) - , resources = Nothing -- Not supported - , tools = Nothing -- Not supported } ``` -## HTTP Transport (NEW!) +## Progress and Per-Request Logging +Handlers can report progress on long-running work and send log messages to +the calling client through actions on the `ClientContext`: + +```haskell +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 +``` + +Both are safe to call unconditionally: + +- `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` — the spec forbids it otherwise — and + drops messages below the declared level. + +Delivery is transport-appropriate: on stdio the notifications interleave +before the response; on HTTP, a request that opted in is answered with an +SSE response stream carrying the notifications followed by the final +response (requests that didn't opt in keep the single-JSON response). + +## Cancellation + +In-flight requests can be cancelled, and per the spec the server then stops +work as soon as practical and sends nothing further for that request: + +- **stdio**: each request runs in its own task; a `notifications/cancelled` + naming its id cancels the task (cancellations for unknown or completed ids + are ignored, as required). +- **HTTP**: closing the response stream is the cancellation signal. For SSE + responses the handler is cancelled as soon as the disconnect is detected + (within one keep-alive interval). For single-JSON responses a disconnect + is only detected at the final write — the handler runs to completion + first — so mid-handler cancellation applies to streaming requests: + clients wanting cancellable calls should opt into streaming via a + `progressToken`. + +A consequence of cancellable requests: **requests are now served +concurrently on both transports** (stdio previously processed them strictly +sequentially). Handlers touching shared mutable state must synchronize +(`MVar`, `STM`, ...) — as was already required for HTTP servers. + +Cancellation is delivered to handler code as an asynchronous exception (the +standard GHC mechanism, as used by `timeout` and `cancel`). Handlers are +interruptible wherever they block in `IO`; a handler that acquires resources +must release them with `bracket`/`finally` so cancellation cannot leak them: + +```haskell +handleTool ctx (ImportData file) = + bracket (openFile file ReadMode) hClose $ \h -> do + ... +``` + +Handlers that must not be interrupted mid-operation can shield critical +sections with `mask`, but should keep them short — cancellation waits for +them. + +## Change Notifications + +Servers whose tool/prompt/resource lists change at runtime can push change +notifications. Create a notifier, hand its source to the transport, and call +the notifier when things change: + +```haskell +main :: IO () +main = do + (notifier, source) <- newMcpNotifier + _ <- forkIO $ appLogic notifier -- calls notifyToolsListChanged etc. + runMcpServerStdioWithConfig + defaultStdioConfig { stdioNotifications = Just source } + serverInfo handlers +``` + +Delivery is transport- and era-aware, and the `listChanged`/`subscribe` +capabilities are advertised automatically where delivery is actually +possible: + +- **Modern clients (2026-07-28)** open a `subscriptions/listen` stream (a + long-lived SSE response over HTTP) and receive only the notification types + they opted into, tagged with their subscription id — including + `notifications/resources/updated` for watched URIs. +- **Legacy stdio clients** receive spontaneous untagged notifications once + their `notifications/initialized` arrives (the lifecycle's ready signal). +- **Legacy HTTP clients** have no delivery channel (this library does not + offer the deprecated GET SSE stream), so nothing is advertised to them. + +## HTTP Transport + The library supports the MCP Streamable HTTP transport. Compile your executable with `ghc-options: -threaded` — Warp requires the threaded runtime: @@ -194,12 +422,15 @@ -- Custom configuration main = runMcpServerHttpWithConfig customConfig serverInfo handlers where - customConfig = HttpConfig + customConfig = defaultHttpConfig { httpPort = 8080 , httpHost = "0.0.0.0" , httpEndpoint = "/api/mcp" , httpVerbose = True -- Enable detailed logging - , httpAuthorize = Nothing -- No authentication (see below) + , httpAllowedOrigins = Just ["https://app.example.com"] + -- Origin validation (DNS-rebinding protection): requests with an + -- Origin header outside this list are rejected with 403. Nothing + -- disables the check (only for servers unreachable from browsers). } ``` @@ -221,17 +452,64 @@ **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`) +- POST `/mcp` for JSON-RPC messages (GET returns 405 — server-to-client + notifications flow over the `subscriptions/listen` POST response stream, + not a standalone GET stream) +- Dual-era protocol support: legacy revisions (`2024-11-05`–`2025-11-25`) + negotiate via `initialize`; the stateless `2026-07-28` revision declares its + version per request in `_meta`, with full request-metadata header + validation (`MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` including the + base64 sentinel encoding) +- Change notifications as long-lived SSE streams via `httpNotifications` + (see [Change Notifications](#change-notifications)) - Optional pluggable bearer-token authentication via `httpAuthorize` +- Origin validation via `httpAllowedOrigins` +- Cacheability hints for modern list/read results via `httpCacheHints` +### Embedding in an existing WAI stack + +`runMcpServerHttp` starts its own Warp server, but the MCP endpoint is a +plain [WAI](https://hackage.haskell.org/package/wai) application underneath, +and it is exported — so you can mount it inside whatever you already run +(your own Warp settings, TLS, middleware, or a larger router): + +```haskell +import MCP.Server (mcpApplication, defaultHttpConfig) +import qualified Network.Wai.Handler.Warp as Warp + +main :: IO () +main = Warp.runSettings mySettings $ \req respond -> + -- route /mcp to the MCP endpoint, everything else to your app + mcpApplication defaultHttpConfig serverInfo handlers req respond +``` + +`httpPort`/`httpHost` are ignored when embedding (they only configure the +server `runMcpServerHttp` starts); the endpoint path, Origin validation, +bearer auth and `subscriptions/listen` streaming all apply as usual. + +## Conformance corpus + +The wire-format fixtures under +[`test/golden/`](test/golden/README.md) double as an **API-agnostic MCP +conformance corpus**: each case is a raw JSON-RPC `.request.json` and the +exact `.response.json` a reference server answers, per protocol era +(legacy `initialize`-negotiated revisions and the stateless `2026-07-28` +revision), enumerated by a `manifest.json`. Nothing in the corpus is +Haskell-specific — any MCP server implementation that reproduces the small +reference server described in the corpus README can replay the requests and +diff the responses. Contributions of new cases are welcome. + +## Roadmap + +Design decisions and planned work live as ADRs under +[`specs/`](specs/README.md), ordered by [`specs/ROADMAP.md`](specs/ROADMAP.md). + ## Examples The library includes several examples: - **`examples/Simple/`**: Basic key-value store using Template Haskell derivation (STDIO) -- **`examples/Complete/`**: Full-featured example with prompts, resources, and tools (STDIO) +- **`examples/Complete/`**: Full-featured example with prompts, resources, a resource template, tools (enum/nested/list arguments, `isError`), and completions (STDIO) - **`examples/HttpSimple/`**: HTTP version of the simple key-value store ## Docker Usage @@ -266,7 +544,8 @@ ## Documentation -- [MCP Specification](https://modelcontextprotocol.io/specification/2025-11-25/) +- [MCP Specification (2026-07-28)](https://modelcontextprotocol.io/specification/2026-07-28/) +- [MCP Specification (2025-11-25, newest legacy revision)](https://modelcontextprotocol.io/specification/2025-11-25/) - [API Documentation](https://hackage.haskell.org/package/mcp-server) - [Examples](examples/) diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -3,6 +3,9 @@ module Main where +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Text as T import MCP.Server import MCP.Server.Derive import System.IO (hSetEncoding, stderr, stdout, utf8) @@ -23,19 +26,45 @@ pure $ ResourceText uri "text/plain" "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf" handleResource _ uri HeadlineBannerAd = pure $ ResourceText uri "text/plain" "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎" +handleResource _ uri (ProductDetail sku) = + pure $ ResourceText uri "text/plain" $ "Details for product " <> sku <> ": in stock, $9.99" -handleTool :: ClientContext -> MyTool -> IO Content -handleTool _ (SearchForProduct q category) = - case category of - Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories" - Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products" -handleTool _ (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items" -handleTool _ Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!" +-- Tool handlers return a full ToolResult: execution failures are reported +-- with isError so the model can see them (returning plain Content works too +-- for simple tools — see the other examples). +handleTool :: ClientContext -> MyTool -> IO ToolResult +handleTool ctx (SearchForProduct q category) = do + -- Progress reporting is safe to call unconditionally: it is a no-op + -- unless the request carried a progressToken + reportProgress ctx 0.5 (Just 1.0) (Just "searching the catalog") + result <- case category of + Nothing -> pure $ toolResult [ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"] + Just cat -> pure $ toolResult [ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"] + reportProgress ctx 1.0 (Just 1.0) Nothing + pure result +handleTool _ (AddToCart sku quantities) + | any (<= 0) quantities = pure $ toolError "Quantities must be positive" + | otherwise = pure $ toolResult + [ContentText $ "Added " <> T.pack (show (sum quantities)) <> " of item " <> sku <> " to your cart"] +handleTool _ (Checkout speed (Address street city zipCode)) = + pure $ toolResult + [ ContentText $ "Checkout completed! Order #12345 will ship " + <> T.pack (show speed) <> " to " <> street <> ", " <> city + <> maybe "" (" " <>) zipCode + ] handleTool _ (ComplexTool field1 field2 field3 field4 field5) = - pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> + pure $ toolResult + [ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> maybe "" (", " <>) field3 <> ", " <> field4 <> - maybe "" (", " <>) field5 + maybe "" (", " <>) field5] +-- Argument autocompletion for the Recipe prompt's idea argument +handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult) +handleComplete _ (CompletionRefPrompt "recipe") "idea" partial _ = + pure $ Right $ completionResult $ + filter (T.isPrefixOf (T.toLower partial)) ["pancakes", "pasta", "pizza"] +handleComplete _ _ _ _ _ = pure $ Right $ completionResult [] + main :: IO () main = do -- Set UTF-8 encoding to handle Unicode characters properly @@ -44,15 +73,32 @@ -- Derive the handlers using Template Haskell let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) - tools = $(deriveToolHandler ''MyTool 'handleTool) + templates = $(deriveResourceTemplates ''MyResource) + -- Per-constructor options: descriptions, behavioral hints for + -- client permission UX, icons, and constructor-scoped argument + -- descriptions + tools = $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("SearchForProduct", defaultDefinitionOptions + { optDescription = Just "Search the product catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optFieldDescriptions = [("q", "Search terms"), ("category", "Restrict to a category")] + }) + , ("Checkout", defaultDefinitionOptions + { optToolAnnotations = Just defaultToolAnnotations + { toolDestructiveHint = Just True } + }) + ]) in runMcpServerStdio McpServerInfo { serverName = "Complete Example MCP Server" , serverVersion = "0.3.0" , serverInstructions = "An example MCP server that handles prompts, resources, and tools." } - McpServerHandlers + noHandlers { prompts = Just prompts , resources = Just resources + , resourceTemplates = Just templates , tools = Just tools + , completions = Just handleComplete } diff --git a/examples/Complete/Types.hs b/examples/Complete/Types.hs --- a/examples/Complete/Types.hs +++ b/examples/Complete/Types.hs @@ -15,11 +15,29 @@ = ProductCategories | SaleItems | HeadlineBannerAd + -- A record constructor becomes a resource template: + -- resource://product_detail/{productSku} + | ProductDetail { productSku :: Text } deriving (Show, Eq) +-- An enumeration argument: all-nullary data types become string enums in +-- the generated schema ("standard", "express", "overnight") +data ShippingSpeed + = Standard + | Express + | Overnight + deriving (Show, Eq) + +-- A nested record argument: appears as a JSON object in the schema +data Address = Address + { street :: Text + , city :: Text + , zipCode :: Maybe Text + } deriving (Show, Eq) + data MyTool = SearchForProduct { q :: Text, category :: Maybe Text } - | AddToCart { sku :: Text } - | Checkout + | AddToCart { sku :: Text, quantities :: [Int] } + | Checkout { speed :: ShippingSpeed, shipTo :: Address } | ComplexTool { field1 :: Text, field2 :: Text, field3 :: Maybe Text, field4 :: Text, field5 :: Maybe Text } deriving (Show, Eq) diff --git a/examples/HttpSimple/Main.hs b/examples/HttpSimple/Main.hs --- a/examples/HttpSimple/Main.hs +++ b/examples/HttpSimple/Main.hs @@ -36,8 +36,6 @@ , serverVersion = "1.0.0" , serverInstructions = "A simple HTTP key-value store with GetValue and SetValue tools" } - McpServerHandlers - { prompts = Nothing -- No prompts in this example - , resources = Nothing -- No resources in this example - , tools = Just tools -- Only tools in this example + noHandlers + { tools = Just tools -- Only tools in this example } diff --git a/examples/Simple/Main.hs b/examples/Simple/Main.hs --- a/examples/Simple/Main.hs +++ b/examples/Simple/Main.hs @@ -36,8 +36,6 @@ , serverVersion = "1.0.0" , serverInstructions = "A simple key-value store with GetValue and SetValue tools" } - McpServerHandlers - { prompts = Nothing -- No prompts in this example - , resources = Nothing -- No resources in this example - , tools = Just tools -- Only tools in this example + noHandlers + { tools = Just tools -- Only tools in this example } diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.21 +version: 0.2.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 @@ -69,6 +74,7 @@ MCP.Server.Derive MCP.Server.Handlers MCP.Server.JsonRpc + MCP.Server.Notifications MCP.Server.Protocol MCP.Server.Transport.Http MCP.Server.Transport.Stdio @@ -84,11 +90,15 @@ -- 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, http-types >=0.12 && <1, network-uri >=2.6 && <2.8, + scientific >=0.3 && <0.4, + stm >=2.5 && <2.6, template-haskell >=2.16 && <2.25, text >=1.2 && <3, wai >=3.2 && <4, @@ -131,6 +141,7 @@ -- Other library packages from which modules are imported. build-depends: base, + containers, mcp-server, text, @@ -170,12 +181,22 @@ other-modules: Spec.AdvancedDerivation Spec.BasicDerivation + Spec.Cancellation + Spec.DefinitionMetadata + Spec.DerivedOutput + Spec.GoldenWire Spec.JSONConversion + Spec.ModernEra + Spec.Progress Spec.ProtocolVersionNegotiation 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 +211,14 @@ build-depends: QuickCheck, aeson, + async, base, bytestring, + containers, + directory, hspec, mcp-server, network-uri, + stm, text, + wai, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -4,48 +4,47 @@ module MCP.Server ( -- * Server Runtime runMcpServerStdio + , runMcpServerStdioWithConfig , runMcpServerHttp , runMcpServerHttpWithConfig -- * Transport Configuration + , StdioConfig(..) + , defaultStdioConfig , HttpConfig(..) + , defaultHttpConfig + , mcpApplication - -- * Utility Functions - , jsonValueToText + -- * 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.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.Types --- | Convert JSON Value to Text representation suitable for handlers -jsonValueToText :: Value -> Text -jsonValueToText (String t) = t -jsonValueToText (Number n) = - -- Check if it's a whole number, if so format as integer - if fromInteger (round n) == n - then T.pack $ show (round n :: Integer) - else T.pack $ show n -jsonValueToText (Bool True) = "true" -jsonValueToText (Bool False) = "false" -jsonValueToText Null = "" -jsonValueToText v = T.pack $ show v - -- | Run an MCP server using STDIO transport -runMcpServerStdio :: McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerStdio serverInfo handlers = transportRunStdio serverInfo handlers +runMcpServerStdio :: McpServerInfo -> McpServerHandlers -> IO () +runMcpServerStdio = transportRunStdio +-- | Run an MCP server using STDIO transport with custom configuration +runMcpServerStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO () +runMcpServerStdioWithConfig = transportRunStdioWithConfig + -- | Run an MCP server using HTTP transport with default configuration -runMcpServerHttp :: McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerHttp serverInfo handlers = transportRunHttp defaultHttpConfig serverInfo handlers +runMcpServerHttp :: McpServerInfo -> McpServerHandlers -> IO () +runMcpServerHttp = transportRunHttp defaultHttpConfig -- | Run an MCP server using HTTP transport with custom configuration -runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO () -runMcpServerHttpWithConfig config serverInfo handlers = transportRunHttp config serverInfo handlers +runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () +runMcpServerHttpWithConfig = transportRunHttp diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -1,26 +1,98 @@ +{-# 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', +-- '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. module MCP.Server.Derive ( -- * Template Haskell Derivation derivePromptHandler , derivePromptHandlerWithDescription + , derivePromptHandlerWithOptions , deriveResourceHandler , deriveResourceHandlerWithDescription + , deriveResourceHandlerWithOptions + , deriveResourceTemplates + , deriveResourceTemplatesWithDescription + , deriveResourceTemplatesWithOptions , deriveToolHandler , deriveToolHandlerWithDescription + , deriveToolHandlerWithOptions + , deriveToolHandlerWithOutput + , deriveToolHandlerWithOutputDescription + , deriveToolHandlerWithOutputOptions + + -- * Per-constructor customization + , DefinitionOptions(..) + , defaultDefinitionOptions ) where -import qualified Data.Map as Map +import Control.Monad (zipWithM) +import Data.Aeson (Value (..)) +import Data.List (intercalate) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift, lift) import qualified Data.Char as Char 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 ------------------------------------------------------------------------------- @@ -52,20 +124,23 @@ 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 +-- 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)] @@ -89,7 +164,268 @@ requiredFieldNames fields = [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ] +-- Extract field information from a (possibly wrapped) parameter record type +extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] +extractFieldsFromParamType paramType = do + case paramType of + ConT typeName -> do + cons <- reifyCons typeName + case cons of + Just [RecC _ fields] -> return fields + Just [NormalC _ [(_bang, innerType)]] -> extractFieldsFromParamType innerType + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType + +-- Names used to communicate between the generated lambda and its cases +ctxName, argNameN, argsName, uriName :: Name +ctxName = mkName "ctx" +argNameN = mkName "name" +argsName = mkName "args" +uriName = mkName "uri" + ------------------------------------------------------------------------------- +-- Value parsers (tool arguments) +------------------------------------------------------------------------------- + +-- Build a parser expression of type @Value -> Either Text a@ for a field type +mkValueParser :: Type -> Q Exp +mkValueParser ty = case ty of + ConT n | nameBase n == "Int" -> [| valueInt |] + | nameBase n == "Integer" -> [| valueInteger |] + | nameBase n == "Double" -> [| valueDouble |] + | nameBase n == "Float" -> [| valueFloat |] + | nameBase n == "Bool" -> [| valueBool |] + | nameBase n == "Text" -> [| valueText |] + AppT ListT inner -> [| valueArray $(mkValueParser inner) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> mkEnumValueParser n cs + Just [RecC icn ifields] -> mkObjectParser n icn ifields + Just [NormalC icn [(_bang, inner)]] -> [| fmap $(conE icn) . $(mkValueParser inner) |] + _ -> fail $ "Unsupported tool argument type: " ++ show n + _ -> fail $ "Unsupported tool argument type: " ++ show ty + +-- Parser for an enumeration: a JSON string matching a snake_cased constructor +mkEnumValueParser :: Name -> [Con] -> Q Exp +mkEnumValueParser tyName cons = do + textParser <- mkEnumTextParser tyName cons + [| \v -> case v of + String s -> $(return textParser) s + _ -> Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) <> " from: " <> renderValue v) |] + +-- Parser of type @Text -> Either Text a@ for an enumeration +mkEnumTextParser :: Name -> [Con] -> Q Exp +mkEnumTextParser tyName cons = do + let expected = intercalate ", " [snakeName (conName c) | c <- cons] + sVar <- newName "s" + matches <- mapM (enumMatch . conName) cons + fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) + <> " from: " <> $(varE sVar) + <> " (expected one of: " <> $(litE $ stringL expected) <> ")") |] + let defaultMatch = Match WildP (NormalB fallback) [] + return $ LamE [VarP sVar] $ + CaseE (AppE (VarE 'T.unpack) (VarE sVar)) (matches ++ [defaultMatch]) + where + enumMatch cn = do + body <- [| Right $(conE cn) |] + return $ Match (LitP $ StringL $ snakeName cn) (NormalB body) [] + +-- Parser for a nested record: a JSON object decoded field by field +mkObjectParser :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp +mkObjectParser tyName icn ifields = do + vVar <- newName "v" + oVar <- newName "o" + chain <- foldl (\acc f -> [| $acc <*> $(fieldExtractor oVar f) |]) + [| pure $(conE icn) |] + ifields + fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) + <> " object from: " <> renderValue $(varE vVar)) |] + objP <- conP 'Object [varP oVar] + return $ LamE [VarP vVar] $ + CaseE (VarE vVar) + [ Match objP (NormalB chain) [] + , Match WildP (NormalB fallback) [] + ] + where + fieldExtractor oVar (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + if isOptional + then [| optionalField $fname $(mkValueParser innerType) $(varE oVar) |] + else [| requiredField $fname $(mkValueParser innerType) $(varE oVar) |] + +------------------------------------------------------------------------------- +-- Text parsers (prompt arguments) +------------------------------------------------------------------------------- + +-- Build a parser expression of type @Text -> Either Text a@ for a prompt field +mkTextParser :: Type -> Q Exp +mkTextParser ty = case ty of + ConT n | nameBase n == "Int" -> [| parseInt |] + | nameBase n == "Integer" -> [| parseInteger |] + | nameBase n == "Double" -> [| parseDouble |] + | nameBase n == "Float" -> [| parseFloat |] + | nameBase n == "Bool" -> [| parseBool |] + | nameBase n == "Text" -> [| parseText |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> mkEnumTextParser n cs + _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show n + _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show ty + +------------------------------------------------------------------------------- +-- Value serializers (structured output) +------------------------------------------------------------------------------- + +-- Build a serializer expression of type @a -> Value@ that mirrors +-- 'mkSchemaShape' exactly: what the schema promises is what the value +-- contains (snake_cased enums, 'Maybe' fields omitted when 'Nothing'). +mkValueBuilder :: Type -> Q Exp +mkValueBuilder ty = case ty of + ConT n | nameBase n `elem` ["Int", "Integer", "Double", "Float", "Bool", "Text"] -> + [| toJSON |] + AppT ListT inner -> + [| \xs -> toJSON (map $(mkValueBuilder inner) xs) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> do + vVar <- newName "v" + matches <- mapM enumMatch cs + return $ LamE [VarP vVar] $ CaseE (VarE vVar) matches + Just [RecC icn ifields] -> mkRecordBuilder icn ifields + Just [NormalC icn [(_bang, inner)]] -> do + xVar <- newName "x" + wrapped <- conP icn [varP xVar] + body <- [| $(mkValueBuilder inner) $(varE xVar) |] + return $ LamE [wrapped] body + _ -> fail $ "Unsupported output field type: " ++ show n + _ -> fail $ "Unsupported output field type: " ++ show ty + where + enumMatch c = do + let cn = conName c + body <- [| String $(litE $ stringL $ snakeName cn) |] + pat <- conP cn [] + return $ Match pat (NormalB body) [] + +-- Serializer for a record: an object with one entry per field, omitting +-- 'Maybe' fields that are 'Nothing'. Fields are bound by pattern-matching +-- the constructor — never by accessor application, which would be ambiguous +-- for users with DuplicateRecordFields enabled. +mkRecordBuilder :: Name -> [(Name, Bang, Type)] -> Q Exp +mkRecordBuilder con fields = do + vars <- mapM (const $ newName "f") fields + pat <- conP con (map varP vars) + fieldExps <- zipWithM fieldPairs vars fields + body <- [| object (concat $(return $ ListE fieldExps)) |] + return $ LamE [pat] body + where + fieldPairs var (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + if isOptional + then [| omitNothing $fname $(mkValueBuilder innerType) $(varE var) |] + else [| [ $fname .= $(mkValueBuilder innerType) $(varE var) ] |] + +-- The output type must (possibly through single-constructor wrappers) +-- resolve to a record: outputSchema is an object schema per the spec. +requireOutputRecord :: Name -> Q () +requireOutputRecord n = do + cons <- reifyCons n + case cons of + Just [RecC _ (_:_)] -> pure () + Just [NormalC _ [(_bang, ConT inner)]] -> requireOutputRecord inner + _ -> fail $ "Output type " ++ show n + ++ " must be a record (outputSchema is an object schema)" + +------------------------------------------------------------------------------- +-- Argument decoding for a constructor +------------------------------------------------------------------------------- + +data ArgStyle = ToolArgs | ToolArgsOutput Exp | PromptArgs + +-- Build a decoder expression of type @Either Error @ reading from +-- the in-scope arguments map bound to 'argsName'. +mkConDecoder :: ArgStyle -> Con -> Q Exp +mkConDecoder _ (NormalC cn []) = [| Right $(conE cn) |] +mkConDecoder style (RecC cn fields) = mkFieldsDecoder style (conE cn) fields +mkConDecoder style (NormalC cn [(_bang, paramType)]) = + wrapParam paramType + where + wrapParam ty = case ty of + ConT typeName -> do + cons <- reifyCons typeName + case cons of + Just [RecC icn ifields] -> do + inner <- mkFieldsDecoder style (conE icn) ifields + [| $(conE cn) <$> $(return inner) |] + Just [NormalC icn [(_b, innerTy)]] -> do + innerCon <- mkConDecoder style (NormalC icn [(_b, innerTy)]) + [| $(conE cn) <$> $(return innerCon) |] + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show ty +mkConDecoder _ con = fail $ "Unsupported constructor type: " ++ show (conName con) + +-- Applicative chain over the constructor's fields, reading from 'argsName' +mkFieldsDecoder :: ArgStyle -> Q Exp -> [(Name, Bang, Type)] -> Q Exp +mkFieldsDecoder style con fields = + foldl (\acc f -> [| $acc <*> $(argExtractor f) |]) [| pure $con |] fields + where + argExtractor (fieldName, _, fieldType) = do + let (isOptional, innerType) = unwrapMaybe fieldType + let fname = litE $ stringL $ nameBase fieldName + case style of + PromptArgs + | isOptional -> [| optionalTextArg $fname $(mkTextParser innerType) $(varE argsName) |] + | otherwise -> [| requiredTextArg $fname $(mkTextParser innerType) $(varE argsName) |] + _ -- tool styles share the Value-based argument decoding + | isOptional -> [| optionalArg $fname $(mkValueParser innerType) $(varE argsName) |] + | otherwise -> [| requiredArg $fname $(mkValueParser innerType) $(varE argsName) |] + +------------------------------------------------------------------------------- +-- Schema generation +------------------------------------------------------------------------------- + +-- Build a 'SchemaType' expression for a field type +mkSchemaShape :: [(String, String)] -> Type -> Q Exp +mkSchemaShape descriptions ty = case ty of + ConT n | nameBase n == "Int" -> [| SchemaInteger |] + | nameBase n == "Integer" -> [| SchemaInteger |] + | nameBase n == "Double" -> [| SchemaNumber |] + | nameBase n == "Float" -> [| SchemaNumber |] + | nameBase n == "Bool" -> [| SchemaBoolean |] + | nameBase n == "Text" -> [| SchemaString Nothing |] + AppT ListT inner -> + [| SchemaArray (Schema Nothing $(mkSchemaShape descriptions inner)) |] + ConT n -> do + cons <- reifyCons n + case cons of + Just cs | not (null cs), all isNullary cs -> do + let vals = listE [litE $ stringL $ snakeName (conName c) | c <- cs] + [| SchemaString (Just $vals) |] + Just [RecC _ ifields] -> mkObjectShape descriptions ifields + Just [NormalC _ [(_bang, inner)]] -> mkSchemaShape descriptions inner + _ -> fail $ "Unsupported tool argument type: " ++ show n + _ -> fail $ "Unsupported tool argument type: " ++ show ty + +-- Build a 'SchemaType' object expression from record fields +mkObjectShape :: [(String, String)] -> [(Name, Bang, Type)] -> Q Exp +mkObjectShape descriptions fields = do + props <- mapM prop fields + let reqd = listE [litE $ stringL fn | fn <- requiredFieldNames fields] + [| SchemaObject $(return $ ListE props) $reqd |] + where + prop (fieldName, _, fieldType) = do + let fieldStr = nameBase fieldName + let description = descriptionFor descriptions fieldStr fieldStr + let (_, innerType) = unwrapMaybe fieldType + [| ( $(litE $ stringL fieldStr) + , Schema (Just $(litE $ stringL description)) $(mkSchemaShape descriptions innerType) + ) |] + +------------------------------------------------------------------------------- -- Prompt derivation ------------------------------------------------------------------------------- @@ -98,26 +434,39 @@ -- -- > $(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 +derivePromptHandlerWithDescription typeName handlerName descriptions = + derivePromptHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions + +-- | Derive prompt handlers with per-constructor '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 (mkPromptDefWithDescription descriptions) constructors + promptDefs <- traverse (mkPromptDef conOpts globalDescs) 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 |] + cases <- traverse (mkDispatchCase PromptArgs handlerName) constructors + defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> $(varE argNameN) |] 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"))) + 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] - _ -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" -- | Derive prompt handlers from a data type. -- Usage: @@ -127,39 +476,22 @@ derivePromptHandler typeName handlerName = derivePromptHandlerWithDescription typeName handlerName [] -mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkPromptDefWithDescription descriptions con = do +mkPromptDef :: (String -> DefinitionOptions) -> [(String, String)] -> Con -> Q Exp +mkPromptDef conOpts globalDescs 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" + 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 = $(litE $ stringL description) + , promptDefinitionDescription = $(lift description) , promptDefinitionArguments = $(return $ ListE args) - , promptDefinitionTitle = Nothing + , promptDefinitionTitle = $(lift (optTitle opts)) + , promptDefinitionIcons = $(lift (optIcons opts)) } |] --- 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) @@ -175,160 +507,77 @@ -- 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" +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 -> do + r <- $(varE handlerName) $(varE ctxName) v + pure (Right (toToolResult r)) |] + ToolArgsOutput builder -> + [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> do + r <- $(varE handlerName) $(varE ctxName) v + pure (Right (resolveToolOutput $(return builder) r)) |] + PromptArgs -> + [| case $(return decoder) of + Left err -> pure (Left err) + Right v -> do + r <- $(varE handlerName) $(varE ctxName) v + pure (Right (toPromptResult r)) |] 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. +-- +-- 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 = 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) |] +deriveResourceHandlerWithDescription typeName handlerName descriptions = + deriveResourceHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) - -- 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) [] +-- | Derive resource handlers with per-constructor 'DefinitionOptions' +-- (description, title, icons). +deriveResourceHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveResourceHandlerWithOptions typeName handlerName opts = + deriveResourceHandlerGeneric typeName handlerName (optionsFor opts) - let readHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "uri")] $ - CaseE (AppE (VarE 'show) (VarE (mkName "uri"))) - (map clauseToMatch cases ++ [defaultMatch]) +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] - _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type" -- | Derive resource handlers from a data type. -- Usage: @@ -338,34 +587,121 @@ deriveResourceHandler typeName handlerName = deriveResourceHandlerWithDescription typeName handlerName [] -mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkResourceDefWithDescription descriptions (NormalC name []) = do +-- | 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 +-- '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 constructorName = nameBase name - let description = case lookup constructorName descriptions of - Just desc -> Just desc - Nothing -> Just constructorName + 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 = $(case description of - Just desc -> [| Just $(litE $ stringL desc) |] - Nothing -> [| Nothing |]) + , resourceDefinitionDescription = Just $(lift description) , resourceDefinitionMimeType = Just "text/plain" - , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field + , resourceDefinitionTitle = $(lift (optTitle opts)) + , resourceDefinitionIcons = $(lift (optIcons opts)) } |] -mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" +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 Right <$> $(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 -> Right <$> $(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" -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" +-- 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 @@ -376,25 +712,22 @@ -- -- > $(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]) +deriveToolHandlerWithDescription typeName handlerName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions Nothing - return $ TupE [Just listHandlerExp, Just callHandlerExp] - _ -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" +-- | Derive tool handlers with per-constructor '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: @@ -404,31 +737,83 @@ deriveToolHandler typeName handlerName = deriveToolHandlerWithDescription typeName handlerName [] -mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkToolDefWithDescription descriptions con = do +-- | 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 @'ToolOutput' \@, whose typed values the derivation +-- serializes into @structuredContent@ — guaranteed to match the schema. +-- +-- > handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport) +-- > $(deriveToolHandlerWithOutput ''MyTool 'handleTool ''WeatherReport) +deriveToolHandlerWithOutput :: Name -> Name -> Name -> Q Exp +deriveToolHandlerWithOutput typeName handlerName outputName = + deriveToolHandlerWithOutputDescription typeName handlerName outputName [] + +-- | 'deriveToolHandlerWithOutput' with custom descriptions. The +-- description list is shared with the output type: entries matching output +-- field names describe the @outputSchema@ properties. +deriveToolHandlerWithOutputDescription :: Name -> Name -> Name -> [(String, String)] -> Q Exp +deriveToolHandlerWithOutputDescription typeName handlerName outputName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions (Just outputName) + +-- | 'deriveToolHandlerWithOutput' with per-constructor +-- '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 description = descriptionFor descriptions (nameBase name) (nameBase name) + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) fields <- getConFields con - props <- traverse (mkProperty descriptions) fields - let required = requiredFieldNames fields + shapeExp <- mkObjectShape (fieldDescsFor opts globalDescs) 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 + , 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)) } |] - -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) - }) |] diff --git a/src/MCP/Server/Derive/Internal.hs b/src/MCP/Server/Derive/Internal.hs --- a/src/MCP/Server/Derive/Internal.hs +++ b/src/MCP/Server/Derive/Internal.hs @@ -1,18 +1,69 @@ {-# 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 ) where -import Data.Text (Text) -import qualified Data.Text as T -import Text.Read (readMaybe) +import Data.Aeson (ToJSON (..), Value (..), encode) +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.Types (Content (..), Error (..), + ToolOutput (..), ToolResult (..), + toolError, toolResult) + +-- --------------------------------------------------------------------------- +-- Text-based parsers (prompt arguments are strings per the MCP spec) +-- --------------------------------------------------------------------------- + parseText :: Text -> Either Text Text parseText = Right @@ -41,3 +92,175 @@ "true" -> Right True "false" -> Right False _ -> Left $ "Failed to parse Bool from: " <> t + +-- --------------------------------------------------------------------------- +-- Value-based parsers (tool arguments are full JSON values) +-- --------------------------------------------------------------------------- + +-- | A short rendering of a JSON value for error messages. +renderValue :: Value -> Text +renderValue (String t) = t +renderValue v = TE.decodeUtf8 $ BSL.toStrict $ encode v + +valueText :: Value -> Either Text Text +valueText (String t) = Right t +valueText v = Left $ "Failed to parse Text from: " <> renderValue v + +valueInt :: Value -> Either Text Int +valueInt (Number n) = case toBoundedInteger n of + Just i -> Right i + Nothing -> Left $ "Failed to parse Int from: " <> renderValue (Number n) +valueInt (String t) = parseInt t +valueInt v = Left $ "Failed to parse Int from: " <> renderValue v + +valueInteger :: Value -> Either Text Integer +valueInteger (Number n) + -- Bound the exponent before materializing the Integer: aeson keeps huge + -- exponents compact, so a tiny payload like 1e1000000000 would otherwise + -- allocate a billion-digit Integer (same bound aeson itself uses for its + -- FromJSON Integer instance). + | base10Exponent n > 1024 = + Left "Failed to parse Integer: exponent too large" + | otherwise = case floatingOrInteger n :: Either Double Integer of + Right i -> Right i + Left _ -> Left $ "Failed to parse Integer from: " <> renderValue (Number n) +valueInteger (String t) = parseInteger t +valueInteger v = Left $ "Failed to parse Integer from: " <> renderValue v + +valueDouble :: Value -> Either Text Double +valueDouble (Number n) = Right (toRealFloat n) +valueDouble (String t) = parseDouble t +valueDouble v = Left $ "Failed to parse Double from: " <> renderValue v + +valueFloat :: Value -> Either Text Float +valueFloat (Number n) = Right (toRealFloat n) +valueFloat (String t) = parseFloat t +valueFloat v = Left $ "Failed to parse Float from: " <> renderValue v + +valueBool :: Value -> Either Text Bool +valueBool (Bool b) = Right b +valueBool (String t) = parseBool t +valueBool v = Left $ "Failed to parse Bool from: " <> renderValue v + +valueArray :: (Value -> Either Text a) -> Value -> Either Text [a] +valueArray p (Array xs) = traverse p (toList xs) +valueArray _ v = Left $ "Failed to parse array from: " <> renderValue v + +-- --------------------------------------------------------------------------- +-- Argument extraction from the top-level arguments map +-- --------------------------------------------------------------------------- + +prefixed :: Text -> Either Text a -> Either Error a +prefixed name = either (Left . InvalidParams . (("field '" <> name <> "': ") <>)) Right + +-- | A required tool argument: missing yields 'MissingRequiredParams', a parse +-- failure yields 'InvalidParams' with the field name prefixed. +requiredArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error a +requiredArg name p args = case Map.lookup name args of + Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing" + Just v -> prefixed name (p v) + +-- | An optional tool argument: absent (or JSON null) becomes 'Nothing'. +optionalArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error (Maybe a) +optionalArg name p args = case Map.lookup name args of + Nothing -> Right Nothing + Just Null -> Right Nothing + Just v -> Just <$> prefixed name (p v) + +-- | A required prompt argument (string-valued). +requiredTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error a +requiredTextArg name p args = case Map.lookup name args of + Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing" + Just t -> prefixed name (p t) + +-- | An optional prompt argument (string-valued). +optionalTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error (Maybe a) +optionalTextArg name p args = case Map.lookup name args of + Nothing -> Right Nothing + Just t -> Just <$> prefixed name (p t) + +-- --------------------------------------------------------------------------- +-- Field extraction from nested JSON objects +-- --------------------------------------------------------------------------- + +-- | A required field of a nested object argument. +requiredField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text a +requiredField name p o = case KM.lookup (Key.fromText name) o of + Nothing -> Left $ "field '" <> name <> "' is missing" + Just v -> either (Left . (("field '" <> name <> "': ") <>)) Right (p v) + +-- | An optional field of a nested object argument: absent or null is 'Nothing'. +optionalField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text (Maybe a) +optionalField name p o = case KM.lookup (Key.fromText name) o of + Nothing -> Right Nothing + Just Null -> Right Nothing + Just v -> either (Left . (("field '" <> name <> "': ") <>)) (Right . Just) (p v) + +-- --------------------------------------------------------------------------- +-- Resource template matching +-- --------------------------------------------------------------------------- + +-- | Match a URI against a template of the form @\{a}\/{b}\/…@: the +-- rendered URI must start with the prefix and continue with exactly @n@ +-- non-empty, slash-separated segments, which are returned percent-decoded. +-- Any query or fragment on the URI is ignored — templates declare only path +-- variables (a literal @?@ or @#@ inside a segment value arrives +-- percent-encoded and is unaffected). +matchTemplateSegments :: Text -> Int -> String -> Maybe [Text] +matchTemplateSegments prefix n uriStr = do + let base = T.takeWhile (\c -> c /= '?' && c /= '#') (T.pack uriStr) + rest <- T.stripPrefix prefix base + let segs = T.splitOn "/" rest + if length segs == n && all (not . T.null) segs + then Just (map (T.pack . unEscapeString . T.unpack) segs) + else Nothing + +-- | Decode one matched template segment into a field value. +templateField :: Text -> (Text -> Either Text a) -> [Text] -> Int -> Either Error a +templateField name p segs i = case drop i segs of + (s:_) -> either (Left . InvalidParams . (("template field '" <> name <> "': ") <>)) Right (p s) + [] -> Left $ InvalidParams $ "missing segment for template field '" <> name <> "'" + +-- --------------------------------------------------------------------------- +-- Structured output +-- --------------------------------------------------------------------------- + +-- | Turn a 'ToolOutput' into the 'ToolResult' that goes on the wire, given +-- the generated serializer for the output type. A plain '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 + +-- | Compact JSON with objects in sorted-key order, independent of the +-- aeson\/hashable pair in the build plan. 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 . encode . Canonical + +-- 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 + +-- | 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)] diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs --- a/src/MCP/Server/Handlers.hs +++ b/src/MCP/Server/Handlers.hs @@ -9,25 +9,33 @@ -- * 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.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) @@ -62,51 +70,203 @@ -- Per MCP spec: "If the server supports the requested protocol version, -- it MUST respond with the same version. Otherwise, the server MUST respond -- with another protocol version it supports." +-- +-- Only /legacy/ revisions are eligible here: a client that negotiates via +-- @initialize@ is legacy by definition, so proposing @2026-07-28@ (or +-- anything unknown) negotiates down to the newest legacy revision rather +-- than promising stateless semantics inside a handshake. validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion | clientVersion `elem` supportedVersions = Right clientVersion -- Supported: echo the client's own version | otherwise = Right protocolVersion -- Unknown: negotiate down to the server's default version --- | Handle an MCP message and return a response if needed -handleMcpMessage :: (MonadIO m) - => McpServerInfo - -> McpServerHandlers m +-- | Look up an @io.modelcontextprotocol/\@ entry in a request's +-- params @_meta@ object. +metaLookup :: Text -> Maybe Value -> Maybe Value +metaLookup key params = plainMetaLookup ("io.modelcontextprotocol/" <> key) params + +-- | Look up an unprefixed key in a request's params @_meta@ object +-- (e.g. @progressToken@, which the spec defines without a prefix). +plainMetaLookup :: Text -> Maybe Value -> Maybe Value +plainMetaLookup key params = do + Object o <- params + Object m <- KM.lookup "_meta" o + KM.lookup (Key.fromText key) m + +-- | The protocol revision a request declares in its params @_meta@ +-- (modern, 2026-07-28+ clients). 'Nothing' for legacy requests. +metaProtocolVersion :: Maybe Value -> Maybe Text +metaProtocolVersion params = case metaLookup "protocolVersion" params of + Just (String v) -> Just v + _ -> Nothing + +-- | The @UnsupportedProtocolVersionError@ (-32022) for a declared version +-- this library does not implement, listing what it does. +unsupportedVersionError :: Text -> JsonRpcError +unsupportedVersionError requested = JsonRpcError + { errorCode = -32022 + , errorMessage = "Unsupported protocol version" + , errorData = Just $ object + [ "supported" .= allVersions + , "requested" .= requested + ] + } + +-- | Methods whose modern results carry the required cacheability fields. +cacheableMethods :: [Text] +cacheableMethods = + [ "server/discover" + , "tools/list" + , "prompts/list" + , "resources/list" + , "resources/read" + , "resources/templates/list" + ] + +-- | Stamp the modern-revision result envelope onto a successful response: +-- @resultType: \"complete\"@, the server's identity in result @_meta@, and +-- (for cacheable methods) @ttlMs@ and @cacheScope@. Error responses and +-- 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 = insertCache . KM.insert "resultType" (String "complete") . insertMeta + 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@. +-- +-- @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 + -> 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 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 <- 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 handlers ctx req + "resources/list" -> handleResourcesList handlers ctx req + "resources/read" -> handleResourcesRead handlers ctx req + "resources/templates/list" -> handleResourcesTemplatesList handlers ctx req + "tools/list" -> handleToolsList handlers ctx req + "tools/call" -> handleToolsCall 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 +290,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 +-- 'decorateModern'. +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,7 +365,7 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle prompts/get request -handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handlePromptsGet :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handlePromptsGet handlers ctx req = case prompts handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -191,7 +388,9 @@ , errorData = Nothing } Success getReq -> do - let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq) + -- 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) result <- getHandler ctx (promptsGetName getReq) args case result of Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -199,18 +398,24 @@ , errorMessage = errorMessageFromMcpError err , errorData = Nothing } - Right content -> do + Right promptRes -> do let response = PromptsGetResponse - { promptsGetDescription = Nothing - , promptsGetMessages = [PromptMessage RoleUser content] - , promptsGetMeta = Nothing -- Can be extended for additional metadata + { promptsGetDescription = promptResultDescription promptRes + , promptsGetMessages = promptResultMessages promptRes + , promptsGetMeta = Nothing } return $ makeSuccessResponse (requestId req) (toJSON response) -- | 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,7 +429,7 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle resources/read request -handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handleResourcesRead :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleResourcesRead handlers ctx req = case resources handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -260,8 +465,62 @@ } return $ makeSuccessResponse (requestId req) (toJSON response) +-- | 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 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,7 +536,7 @@ return $ makeSuccessResponse (requestId req) (toJSON response) -- | Handle tools/call request -handleToolsCall :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse +handleToolsCall :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleToolsCall handlers ctx req = case tools handlers of Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -300,7 +559,8 @@ , errorData = Nothing } Success callReq -> do - let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq) + -- Tool arguments are passed through as full JSON values. + let args = fromMaybe Map.empty (toolsCallArguments callReq) result <- callHandler ctx (toolsCallName callReq) args case result of Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -308,11 +568,12 @@ , errorMessage = errorMessageFromMcpError err , errorData = Nothing } - Right content -> do + Right toolRes -> do let response = ToolsCallResponse - { toolsCallContent = [content] - , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- Can be extended for structured output + { toolsCallContent = toolResultContent toolRes + , toolsCallIsError = if toolResultIsError toolRes then Just True else Nothing + , toolsCallStructuredContent = toolResultStructured toolRes + , toolsCallMeta = toolResultMeta toolRes } return $ makeSuccessResponse (requestId req) (toJSON response) diff --git a/src/MCP/Server/JsonRpc.hs b/src/MCP/Server/JsonRpc.hs --- a/src/MCP/Server/JsonRpc.hs +++ b/src/MCP/Server/JsonRpc.hs @@ -20,9 +20,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 +39,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 +140,16 @@ toJSON (JsonRpcMessageResponse resp) = toJSON resp toJSON (JsonRpcMessageNotification notif) = toJSON notif +-- | Classify by shape instead of parse-fallthrough: a request with a +-- malformed field must fail as a request, not silently succeed as a +-- notification (which has fewer required fields). instance FromJSON JsonRpcMessage where - parseJSON v = parseRequest v <|> parseResponse v <|> parseNotification v - where - parseRequest = fmap JsonRpcMessageRequest . parseJSON - parseResponse = fmap JsonRpcMessageResponse . parseJSON - parseNotification = fmap JsonRpcMessageNotification . parseJSON + parseJSON = withObject "JsonRpcMessage" $ \o -> + case (KM.member "method" o, KM.member "id" o) of + (True, True) -> JsonRpcMessageRequest <$> parseJSON (Object o) + (True, False) -> JsonRpcMessageNotification <$> parseJSON (Object o) + (False, True) -> JsonRpcMessageResponse <$> parseJSON (Object o) + (False, False) -> fail "Not a JSON-RPC message: no method and no id" -- | Create a successful JSON-RPC response makeSuccessResponse :: RequestId -> Value -> JsonRpcResponse diff --git a/src/MCP/Server/Notifications.hs b/src/MCP/Server/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Notifications.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Server-initiated change notifications. +-- +-- Create a notifier with 'newMcpNotifier', hand the 'NotificationSource' to +-- a transport via its configuration ('MCP.Server.Transport.Stdio.StdioConfig' +-- \/ 'MCP.Server.Transport.Http.HttpConfig'), keep the 'McpNotifier', and +-- call its actions whenever your tool\/prompt\/resource lists (or a specific +-- resource) change: +-- +-- > (notifier, source) <- newMcpNotifier +-- > let config = defaultStdioConfig { stdioNotifications = Just source } +-- > _ <- forkIO $ appLogic notifier +-- > runMcpServerStdioWithConfig config serverInfo handlers +-- +-- Delivery is transport- and era-specific: modern (2026-07-28) clients open +-- a @subscriptions\/listen@ stream and receive only the notification types +-- they opted into, tagged with their subscription id; legacy stdio clients +-- receive untagged notifications spontaneously after @initialize@. Legacy +-- HTTP has no delivery channel (this library dropped the deprecated GET SSE +-- stream), so the @listChanged@ capabilities are not advertised there. +module MCP.Server.Notifications + ( -- * Notifier + McpNotifier(..) + , NotificationSource + , newMcpNotifier + , ChangeEvent(..) + , subscribeEvents + + -- * Subscription wire format (used by transports) + , NotificationFilter(..) + , parseNotificationFilter + , filterAccepts + , filterIsEmpty + , acknowledgedNotification + , eventNotification + , legacyEventNotification + , closureResponse + ) where + +import Control.Concurrent.STM (STM, TChan, atomically, + dupTChan, newBroadcastTChanIO, + writeTChan) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI (URI) + +import MCP.Server.JsonRpc +import MCP.Server.Types (McpServerInfo (..)) + +-- | A change an application can announce. +data ChangeEvent + = ToolsListChangedEvent + | PromptsListChangedEvent + | ResourcesListChangedEvent + | ResourceUpdatedEvent Text -- ^ the resource URI, rendered + deriving (Show, Eq) + +-- | The application-facing handle: call these when things change. +data McpNotifier = McpNotifier + { notifyToolsListChanged :: IO () + , notifyPromptsListChanged :: IO () + , notifyResourcesListChanged :: IO () + , notifyResourceUpdated :: URI -> IO () + } + +-- | The transport-facing end of a notifier: subscribe with +-- 'subscribeEvents'. Backed by a broadcast 'TChan', so events published +-- while nobody listens are dropped rather than retained. +newtype NotificationSource = NotificationSource (TChan ChangeEvent) + +-- | Create a notifier and its source. +newMcpNotifier :: IO (McpNotifier, NotificationSource) +newMcpNotifier = do + chan <- newBroadcastTChanIO + let publish = atomically . writeTChan chan + pure + ( McpNotifier + { notifyToolsListChanged = publish ToolsListChangedEvent + , notifyPromptsListChanged = publish PromptsListChangedEvent + , notifyResourcesListChanged = publish ResourcesListChangedEvent + , notifyResourceUpdated = publish . ResourceUpdatedEvent . T.pack . show + } + , NotificationSource chan + ) + +-- | A private read end delivering every event published after the call. +subscribeEvents :: NotificationSource -> STM (TChan ChangeEvent) +subscribeEvents (NotificationSource chan) = dupTChan chan + +-- | Which notification types a @subscriptions\/listen@ request opted into. +data NotificationFilter = NotificationFilter + { filterTools :: Bool + , filterPrompts :: Bool + , filterResources :: Bool + , filterResourceSubs :: [Text] -- ^ URIs watched for updates + } deriving (Show, Eq) + +-- | Parse the @notifications@ filter out of a @subscriptions\/listen@ +-- request's params. Absent fields mean "not subscribed". +parseNotificationFilter :: Maybe Value -> NotificationFilter +parseNotificationFilter params = NotificationFilter + { filterTools = boolField "toolsListChanged" + , filterPrompts = boolField "promptsListChanged" + , filterResources = boolField "resourcesListChanged" + , filterResourceSubs = subsField + } + where + notifications = do + Object o <- params + KM.lookup "notifications" o + boolField key = case notifications of + Just (Object n) | Just (Bool b) <- KM.lookup key n -> b + _ -> False + subsField = case notifications of + Just (Object n) | Just (Array xs) <- KM.lookup "resourceSubscriptions" n -> + [u | String u <- foldr (:) [] xs] + _ -> [] + +-- | Whether a subscription with this filter receives the event. +filterAccepts :: NotificationFilter -> ChangeEvent -> Bool +filterAccepts f ToolsListChangedEvent = filterTools f +filterAccepts f PromptsListChangedEvent = filterPrompts f +filterAccepts f ResourcesListChangedEvent = filterResources f +filterAccepts f (ResourceUpdatedEvent uri) = uri `elem` filterResourceSubs f + +-- | True when the filter subscribes to nothing at all. +filterIsEmpty :: NotificationFilter -> Bool +filterIsEmpty f = + not (filterTools f || filterPrompts f || filterResources f) + && null (filterResourceSubs f) + +-- | The @_meta@ object tagging a message with its subscription id (the +-- JSON-RPC id of the @subscriptions\/listen@ request). +subscriptionMeta :: RequestId -> Pair +subscriptionMeta subId = + "_meta" .= object ["io.modelcontextprotocol/subscriptionId" .= subId] + +-- | The mandatory first message of a subscription stream: the honored +-- filter (this library honors every requested type). +acknowledgedNotification :: RequestId -> NotificationFilter -> JsonRpcNotification +acknowledgedNotification subId f = + makeNotification "notifications/subscriptions/acknowledged" $ Just $ object + [ subscriptionMeta subId + , "notifications" .= object (concat + [ ["toolsListChanged" .= True | filterTools f] + , ["promptsListChanged" .= True | filterPrompts f] + , ["resourcesListChanged" .= True | filterResources f] + , ["resourceSubscriptions" .= filterResourceSubs f | not (null (filterResourceSubs f))] + ]) + ] + +-- | The method and extra params of an event's notification. +eventBody :: ChangeEvent -> (Text, [Pair]) +eventBody ToolsListChangedEvent = ("notifications/tools/list_changed", []) +eventBody PromptsListChangedEvent = ("notifications/prompts/list_changed", []) +eventBody ResourcesListChangedEvent = ("notifications/resources/list_changed", []) +eventBody (ResourceUpdatedEvent uri) = ("notifications/resources/updated", ["uri" .= uri]) + +-- | A change event as a subscription-tagged notification (modern era). +eventNotification :: RequestId -> ChangeEvent -> JsonRpcNotification +eventNotification subId event = + let (method, extra) = eventBody event + in makeNotification method $ Just $ object (subscriptionMeta subId : extra) + +-- | A change event as an untagged notification (legacy stdio delivery). +legacyEventNotification :: ChangeEvent -> JsonRpcNotification +legacyEventNotification event = + let (method, extra) = eventBody event + in makeNotification method $ if null extra then Nothing else Just (object extra) + +-- | The graceful-closure response a server sends when it ends a +-- subscription on its own initiative (e.g. shutdown). Like every modern +-- result it carries the server identity alongside the subscription id. +closureResponse :: McpServerInfo -> RequestId -> JsonRpcResponse +closureResponse serverInfo subId = makeSuccessResponse subId $ object + [ "resultType" .= ("complete" :: Text) + , "_meta" .= object + [ "io.modelcontextprotocol/subscriptionId" .= subId + , "io.modelcontextprotocol/serverInfo" .= object + [ "name" .= serverName serverInfo + , "version" .= serverVersion serverInfo + ] + ] + ] diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -22,7 +22,12 @@ , ResourcesListResponse(..) , ResourcesReadRequest(..) , ResourcesReadResponse(..) + , ResourcesTemplatesListResponse(..) + -- * Completion Protocol + , CompleteRequest(..) + , CompleteResponse(..) + -- * Tools Protocol , ToolsListRequest(..) , ToolsListResponse(..) @@ -35,20 +40,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 +75,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 +142,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 +222,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 +304,17 @@ -- | Tools call response (2025-06-18 enhanced) data ToolsCallResponse = ToolsCallResponse - { toolsCallContent :: [Content] - , toolsCallIsError :: Maybe Bool - , toolsCallMeta :: Maybe Value -- New _meta field for structured output + { toolsCallContent :: [Content] + , toolsCallIsError :: Maybe Bool + , toolsCallStructuredContent :: Maybe Value -- ^ structuredContent (2025-06-18+) + , toolsCallMeta :: Maybe Value } deriving (Show, Eq, Generic) instance ToJSON ToolsCallResponse where toJSON resp = object $ [ "content" .= toolsCallContent resp ] ++ maybe [] (\e -> ["isError" .= e]) (toolsCallIsError resp) + ++ maybe [] (\s -> ["structuredContent" .= s]) (toolsCallStructuredContent resp) ++ maybe [] (\m -> ["_meta" .= m]) (toolsCallMeta resp) -- | List changed notification diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -6,12 +6,31 @@ 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,7 +43,9 @@ import MCP.Server.Handlers import MCP.Server.JsonRpc -import MCP.Server.Protocol (protocolVersion, supportedVersions) +import MCP.Server.Notifications +import MCP.Server.Protocol (allVersions, modernVersions, + supportedVersions) import MCP.Server.Types -- | HTTP transport configuration following the MCP Streamable HTTP specification @@ -45,6 +66,25 @@ -- handler '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. + , 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,15 +95,49 @@ , httpEndpoint = "/mcp" , httpVerbose = False , httpAuthorize = Nothing + , httpAllowedOrigins = Nothing + , httpCacheHints = defaultCacheHints + , 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) $ @@ -72,35 +146,76 @@ putStrLn $ "Starting MCP HTTP server on " ++ httpHost config ++ ":" ++ show (httpPort config) ++ httpEndpoint config Warp.runSettings settings (mcpApplication config serverInfo handlers) --- | 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. +mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> Wai.Application +mcpApplication 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 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 +228,342 @@ 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 :: HttpConfig -> McpServerInfo -> McpServerHandlers -> 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. + -- 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 config serverInfo handlers ctx body respond + | otherwise -> do + logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body) + handleJsonRpcRequest 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" + +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 :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleStreamingRequest 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) + (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 :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleJsonRpcRequest 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 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 :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +handleSingleJsonRpc 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) + (httpNotifSupport config) (\_ -> pure ()) handlers ctx message case maybeResponse of Just responseMsg -> do let responseJson = encode $ encodeJsonRpcMessage responseMsg logVerbose config $ "Sending HTTP response for: " ++ show (getMessageSummary message) respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] + (statusForResponse modern responseMsg) + [("Content-Type", "application/json")] responseJson Nothing -> do logVerbose config $ "No response needed for: " ++ show (getMessageSummary message) - -- For notifications, return 200 with empty JSON object (per MCP spec) - respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] - "{}" + -- Accepted notification: 202 with no body, per the Streamable HTTP spec + respond $ Wai.responseLBS status202 [] "" + +-- | The HTTP status for a JSON-RPC response. Modern (2026-07-28) requests +-- map protocol-level failures onto HTTP statuses — 404 for an unknown RPC +-- method, 400 for an unsupported protocol version — so era-probing clients +-- can distinguish them; legacy requests always get 200 as before. +statusForResponse :: Bool -> JsonRpcMessage -> Status +statusForResponse True (JsonRpcMessageResponse r) = case responseError r of + Just e | errorCode e == -32601 -> status404 + | errorCode e == -32022 -> status400 + _ -> status200 +statusForResponse _ _ = status200 diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -4,51 +4,269 @@ 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) +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.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. + , 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 + , 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 + + -- 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) 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 + inflight <- readMVar inflightVar + mapM_ (cancel . snd) inflight + closeAllSubscriptions + logLine "stdin closed - shutting down" + else do + input <- TIO.getLine + unless (T.null $ T.strip input) $ do + logVerbose $ "Received request: " <> input + case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of + Left err -> do + logLine $ "Parse error: " <> T.pack err + sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32700 + , errorMessage = "Parse error" + , errorData = Nothing + } + Right jsonValue -> + case parseJsonRpcMessage jsonValue of + Left err -> do + logLine $ "JSON-RPC parse error: " <> T.pack err + sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError + { errorCode = -32600 + , errorMessage = "Invalid Request" + , errorData = Nothing + } + Right message -> do + logLine $ "Processing message: " <> T.pack (show (getMessageSummary message)) + handleParsed message + loop + + loop + +-- | The request id referenced by a notifications/cancelled notification. +cancelledRequestId :: Maybe Value -> Maybe RequestId +cancelledRequestId params = do + Object o <- params + v <- KM.lookup "requestId" o + either (const Nothing) Just (parseEither parseJSON v) diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -1,45 +1,89 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} 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 + -- * Handler Types , PromptListHandler , PromptGetHandler , ResourceListHandler , ResourceReadHandler + , ResourceTemplateListHandler , ToolListHandler , ToolCallHandler + , CompletionHandler -- * Basic Types , PromptName @@ -50,11 +94,14 @@ 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) type PromptName = Text @@ -66,7 +113,14 @@ 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 '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 +133,83 @@ , "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" + 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 +data ContentAudioData = ContentAudioData + { contentAudioData :: Text -- ^ base64-encoded audio data + , contentAudioMimeType :: Text } deriving (Show, Eq, Generic) -- | Resource content compliant with MCP specification @@ -154,6 +253,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 '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 '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 'PromptResult' or @['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 +512,81 @@ 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 + 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 + 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 + ] + -- | 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 '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 +595,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 +617,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 +731,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 @@ -315,6 +768,13 @@ [ fmap ("listChanged" .=) (toolListChanged caps) ] +data CompletionCapabilities = CompletionCapabilities + { -- No sub-capabilities defined + } deriving (Show, Eq, Generic) + +instance ToJSON CompletionCapabilities where + toJSON _ = object [] + data LoggingCapabilities = LoggingCapabilities { -- No specific sub-capabilities for logging yet } deriving (Show, Eq, Generic) @@ -324,10 +784,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 +796,7 @@ [ fmap ("prompts" .=) (capabilityPrompts caps) , fmap ("resources" .=) (capabilityResources caps) , fmap ("tools" .=) (capabilityTools caps) + , fmap ("completions" .=) (capabilityCompletions caps) , fmap ("logging" .=) (capabilityLogging caps) ] @@ -347,22 +809,121 @@ -- 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. + } + +-- | 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 () + } + +-- | 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) +-- | Conservative defaults: no caching (@ttlMs = 0@), private scope. +defaultCacheHints :: CacheHints +defaultCacheHints = CacheHints + { cacheTtlMs = 0 + , cacheScopePublic = False + } + +-- | 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) + +-- | No notification delivery at all: nothing extra is advertised. +noNotificationSupport :: NotificationSupport +noNotificationSupport = NotificationSupport + { supportsLegacyPush = False + , supportsListen = False + } + -- | 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) +-- +-- Prompt arguments are string-valued per the MCP specification; tool +-- arguments are full JSON values. +type PromptListHandler = ClientContext -> IO [PromptDefinition] +type PromptGetHandler = ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) -type ResourceListHandler m = ClientContext -> m [ResourceDefinition] -type ResourceReadHandler m = ClientContext -> URI -> m (Either Error ResourceContent) +type ResourceListHandler = ClientContext -> IO [ResourceDefinition] +type ResourceReadHandler = ClientContext -> URI -> IO (Either Error ResourceContent) +type ResourceTemplateListHandler = ClientContext -> IO [ResourceTemplateDefinition] -type ToolListHandler m = ClientContext -> m [ToolDefinition] -type ToolCallHandler m = ClientContext -> ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) +type ToolListHandler = ClientContext -> IO [ToolDefinition] +type ToolCallHandler = ClientContext -> ToolName -> Map Text Value -> IO (Either Error ToolResult) +-- | Completion handler: given what is being completed ('CompletionRef'), the +-- argument name, the partial value typed so far, and any already-resolved +-- sibling arguments, produce ranked suggestions. +type CompletionHandler = ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult) + -- | Server handlers -data McpServerHandlers m = McpServerHandlers - { prompts :: Maybe (PromptListHandler m, PromptGetHandler m) - , resources :: Maybe (ResourceListHandler m, ResourceReadHandler m) - , tools :: Maybe (ToolListHandler m, ToolCallHandler m) +data McpServerHandlers = McpServerHandlers + { prompts :: Maybe (PromptListHandler, PromptGetHandler) + , resources :: Maybe (ResourceListHandler, ResourceReadHandler) + , resourceTemplates :: Maybe ResourceTemplateListHandler + -- ^ Parameterized resources (@resources\/templates\/list@). Template + -- URIs are read through the 'ResourceReadHandler' in 'resources' — + -- configure both, or template reads have nothing to serve them + -- (a templates-only configuration still answers @resources\/list@ + -- with an empty list so the advertised capability stays honest). + , tools :: Maybe (ToolListHandler, ToolCallHandler) + , completions :: Maybe CompletionHandler + -- ^ Argument autocompletion (@completion\/complete@) for prompts and + -- resource templates. + } + +-- | Handlers for a server that supports nothing — record-update the features +-- you provide, so adding new handler slots to the library does not break +-- your construction. +noHandlers :: McpServerHandlers +noHandlers = McpServerHandlers + { prompts = Nothing + , resources = Nothing + , resourceTemplates = Nothing + , tools = Nothing + , completions = Nothing } diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -7,9 +7,18 @@ import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation +import qualified Spec.Cancellation import qualified Spec.UnicodeHandling +import qualified Spec.DefinitionMetadata +import qualified Spec.DerivedOutput +import qualified Spec.GoldenWire +import qualified Spec.ModernEra +import qualified Spec.Progress import qualified Spec.ProtocolVersionNegotiation +import qualified Spec.Subscriptions +import qualified Spec.TemplatesCompletions import qualified Spec.ToolCallParsing +import qualified Spec.TypedArgs main :: IO () main = hspec $ do @@ -18,6 +27,15 @@ Spec.BasicDerivation.spec Spec.SchemaValidation.spec Spec.AdvancedDerivation.spec + Spec.Cancellation.spec Spec.UnicodeHandling.spec + Spec.DefinitionMetadata.spec + Spec.DerivedOutput.spec + Spec.GoldenWire.spec + Spec.ModernEra.spec + Spec.Progress.spec Spec.ProtocolVersionNegotiation.spec + Spec.Subscriptions.spec + Spec.TemplatesCompletions.spec Spec.ToolCallParsing.spec + Spec.TypedArgs.spec diff --git a/test/Spec/AdvancedDerivation.hs b/test/Spec/AdvancedDerivation.hs --- a/test/Spec/AdvancedDerivation.hs +++ b/test/Spec/AdvancedDerivation.hs @@ -9,20 +9,21 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes import TestData -- Generate advanced handlers for separate parameter types -testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlers :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) -testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlers :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) -testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) -testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions) -- Helper functions for advanced testing @@ -35,17 +36,13 @@ assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO () assertSchemaHasProperties expectedProps toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - let propNames = map fst props - in all (`elem` propNames) expectedProps `shouldBe` True + let propNames = map fst (schemaProps (toolDefinitionInputSchema toolDef)) + all (`elem` propNames) expectedProps `shouldBe` True -assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO () +assertToolCallResult :: ToolCallHandler -> Text -> [(Text, Text)] -> Text -> IO () assertToolCallResult handler toolName args expectedContent = do - result <- handler anonCtx toolName args - case result of - Right (ContentText content) -> content `shouldBe` expectedContent - other -> expectationFailure $ "Expected ContentText but got: " ++ show other + result <- handler anonCtx toolName (stringArgs args) + result `shouldBeTextResult` expectedContent assertToolHasDescription :: Text -> Text -> ToolDefinition -> IO () assertToolHasDescription toolName expectedDesc toolDef = do @@ -54,11 +51,9 @@ assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO () assertPropertyHasDescription propName expectedDesc toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - case lookup propName props of - Just prop -> propertyDescription prop `shouldBe` expectedDesc - Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName + case lookupProp propName toolDef of + Just prop -> schemaDescription prop `shouldBe` Just expectedDesc + Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName spec :: Spec spec = describe "Advanced Template Haskell Derivation" $ do diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -9,40 +9,26 @@ 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 @@ -53,9 +39,10 @@ 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 diff --git a/test/Spec/Cancellation.hs b/test/Spec/Cancellation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Cancellation.hs @@ -0,0 +1,80 @@ +{-# 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 + +-- A slow tools/call carrying a progressToken (so emissions are live), +-- driven from an async that the test cancels once the handler signals +-- it has started. +runCancelled :: (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 + putMVar started () + handlerBody ctx + pure $ Right $ toToolResult ("done" :: Text) + ) + } + params = object + [ "name" .= ("slow" :: Text) + , "arguments" .= object [] + , "_meta" .= object ["progressToken" .= ("t" :: Text)] + ] + task <- async $ do + resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints + 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 $ \ctx -> do + 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 $ \_ -> + bracket_ (writeIORef acquired True) (writeIORef released True) $ + threadDelay 5000000 + readIORef acquired `shouldReturn` True + readIORef released `shouldReturn` True diff --git a/test/Spec/DefinitionMetadata.hs b/test/Spec/DefinitionMetadata.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DefinitionMetadata.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for definition metadata (ADR 0006): tool annotations, icons, +-- content annotations, and the options-based derive customization. +module Spec.DefinitionMetadata (spec) where + +import Data.Aeson +import Data.Text (Text) +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes + +annotatedToolHandlers :: (ToolListHandler, ToolCallHandler) +annotatedToolHandlers = $(deriveToolHandlerWithOptions ''TestTool 'handleTestTool + [ ("Echo", defaultDefinitionOptions + { optDescription = Just "Echoes the input" + , optTitle = Just "Echo" + , optIcons = [icon "https://example.com/echo.png"] + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + , optFieldDescriptions = [("text", "What to echo")] + }) + , ("Calculate", defaultDefinitionOptions + { optFieldDescriptions = [("x", "Calculate's first operand")] + }) + ]) + +toolNamed :: Text -> [ToolDefinition] -> ToolDefinition +toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of + (d:_) -> d + [] -> error $ "tool not found: " ++ show n + +propDescription :: Text -> ToolDefinition -> Maybe Text +propDescription name def = case schemaShape (toolDefinitionInputSchema def) of + SchemaObject props _ -> lookup name props >>= schemaDescription + _ -> Nothing + +spec :: Spec +spec = describe "Definition metadata" $ do + + describe "JSON shapes" $ do + it "serializes tool annotations with only the set hints" $ do + toJSON defaultToolAnnotations { toolReadOnlyHint = Just True } `shouldBe` + object ["readOnlyHint" .= True] + + it "serializes icons, omitting empty optional fields" $ do + toJSON (icon "https://example.com/i.png") `shouldBe` + object ["src" .= ("https://example.com/i.png" :: Text)] + toJSON (Icon "u" (Just "image/png") ["48x48"]) `shouldBe` + object ["src" .= ("u" :: Text), "mimeType" .= ("image/png" :: Text), "sizes" .= (["48x48"] :: [Text])] + + it "merges content annotations into the inner block" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.8 } + toJSON (ContentAnnotated anns (ContentText "hi")) `shouldBe` + object [ "type" .= ("text" :: Text), "text" .= ("hi" :: Text) + , "annotations" .= object ["audience" .= (["user"] :: [Text]), "priority" .= (0.8 :: Double)] + ] + + it "round-trips annotated content through FromJSON" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleAssistant] } + c = ContentAnnotated anns (ContentText "hello") + decode (encode c) `shouldBe` Just c + + it "round-trips resource links carrying icons" $ do + let def = (mkResourceDefinition "resource://x" "x") + { resourceDefinitionIcons = [Icon "https://example.com/x.png" (Just "image/png") ["48x48"]] } + c = ContentResourceLink def + decode (encode c) `shouldBe` Just c + + describe "Options-based derivation" $ do + it "carries description, title, icons and annotations on the definition" $ do + defs <- fst annotatedToolHandlers anonCtx + let echoDef = toolNamed "echo" defs + toolDefinitionDescription echoDef `shouldBe` "Echoes the input" + toolDefinitionTitle echoDef `shouldBe` Just "Echo" + toolDefinitionIcons echoDef `shouldBe` [icon "https://example.com/echo.png"] + toolDefinitionAnnotations echoDef `shouldBe` Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + + it "leaves uncustomized constructors bare (constructor-name description)" $ do + defs <- fst annotatedToolHandlers anonCtx + let toggleDef = toolNamed "toggle" defs + toolDefinitionDescription toggleDef `shouldBe` "Toggle" + toolDefinitionAnnotations toggleDef `shouldBe` Nothing + toolDefinitionIcons toggleDef `shouldBe` [] + + it "scopes field descriptions to their constructor" $ do + defs <- fst annotatedToolHandlers anonCtx + -- 'text' described only on Echo; 'x' described only on Calculate + propDescription "text" (toolNamed "echo" defs) `shouldBe` Just "What to echo" + propDescription "x" (toolNamed "calculate" defs) `shouldBe` Just "Calculate's first operand" + -- Echo's options must not leak onto Calculate's same-named args + propDescription "operation" (toolNamed "calculate" defs) `shouldBe` Just "operation" + + it "still dispatches calls unchanged" $ do + result <- snd annotatedToolHandlers anonCtx "echo" mempty + case result of + Left (MissingRequiredParams msg) -> show msg `shouldContain` "text" + other -> expectationFailure $ "expected missing-params error, got: " ++ show other diff --git a/test/Spec/DerivedOutput.hs b/test/Spec/DerivedOutput.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DerivedOutput.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for derived structured output (ADR 0005): the outputSchema +-- generated from a result record, and the ToolOutput result forms. +module Spec.DerivedOutput (spec) where + +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestHelpers +import TestTypes + +weatherHandlers :: (ToolListHandler, ToolCallHandler) +weatherHandlers = $(deriveToolHandlerWithOutputDescription ''WeatherTool 'handleWeatherTool ''WeatherReport + [ ("GetWeather", "Current weather"), ("wrTemperature", "Degrees Celsius") ]) + +callWeather :: Text -> [(Text, Value)] -> IO (Either Error 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 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 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 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 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 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 result of + Right tr -> do + toolResultStructured tr `shouldBe` Nothing + toolResultContent tr `shouldBe` [ContentText "sunny"] + Left err -> expectationFailure $ "expected result, got error: " ++ show err diff --git a/test/Spec/GoldenWire.hs b/test/Spec/GoldenWire.hs new file mode 100644 --- /dev/null +++ b/test/Spec/GoldenWire.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Golden wire-format conformance corpus: @test/golden/@ holds, per case, +-- a JSON-RPC request (@\.request.json@) and the reference server's +-- exact response (@\.response.json@), enumerated by +-- @test/golden/manifest.json@. This spec replays every request through +-- 'handleMcpMessage' and compares the response against the fixture. +-- +-- The corpus is deliberately API-agnostic — request and response are plain +-- wire bytes, so any MCP implementation that reproduces the reference +-- server described in @test/golden/README.md@ can consume it. Within this +-- library it pins two promises: the legacy fixtures were generated from +-- @main@ at v0.2.0 (commit @7bd1bcc@), anchoring "dual-era support leaves +-- legacy responses unchanged", and the modern fixtures pin the 2026-07-28 +-- envelope. +-- +-- Responses are compared as parsed 'Value's, not raw bytes: aeson's object +-- key order depends on the aeson\/hashable versions in the build plan, which +-- vary across the CI matrix, while 'Value' equality is stable and still +-- catches every added, removed, renamed or changed field. +-- +-- To add a case: write the @.request.json@ by hand, add its manifest entry, +-- and run the suite with @GOLDEN_ACCEPT=1@ — a missing response fixture is +-- then written from the current output. Existing fixtures are never +-- overwritten — delete one first to regenerate it, and never regenerate the +-- legacy fixtures from a branch that intends to keep legacy output +-- unchanged. +module Spec.GoldenWire (spec) where + +import Control.Monad (forM_) +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +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 + +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 $ 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 $ 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 $ toolResult [ContentText ("echo: " <> t)] + _ -> pure $ Left $ MissingRequiredParams "field 'text' is missing" + "boom" -> pure $ Right $ 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 + ) + } + +-- | One manifest entry: which case, and which reference-server variant +-- answers it. +data GoldenCase = GoldenCase + { caseName :: FilePath + , caseHandlers :: Text -- ^ "base" or "extended" + , 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 = if caseHandlers gc == "extended" then extendedHandlers else goldenHandlers + support = if caseNotifications gc + then NotificationSupport { supportsLegacyPush = True, supportsListen = True } + else noNotificationSupport + maybeResponse <- handleMcpMessage goldenServerInfo defaultCacheHints 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 -> actual `shouldBe` fixture + +spec :: Spec +spec = describe "Golden wire-format fixtures" $ do + cases <- runIO loadManifest + forM_ cases goldenCase diff --git a/test/Spec/JSONConversion.hs b/test/Spec/JSONConversion.hs --- a/test/Spec/JSONConversion.hs +++ b/test/Spec/JSONConversion.hs @@ -5,7 +5,7 @@ import Data.Aeson (toJSON) import Data.Text (Text) import qualified Data.Text as T -import MCP.Server +import MCP.Server.Handlers (jsonValueToText) import Test.Hspec import Test.QuickCheck import Text.Read (readMaybe) diff --git a/test/Spec/ModernEra.hs b/test/Spec/ModernEra.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ModernEra.hs @@ -0,0 +1,245 @@ +{-# 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 + +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 $ toToolResult + ("version=" <> maybe "none" id (clientProtocolVersion ctx)) + ) + } + +run :: JsonRpcMessage -> IO (Maybe JsonRpcMessage) +run = handleMcpMessage testServerInfo defaultCacheHints noNotificationSupport (\_ -> pure ()) testHandlers anonymousContext + +request :: Text -> Maybe Value -> JsonRpcMessage +request method params = JsonRpcMessageRequest $ JsonRpcRequest + { requestJsonrpc = "2.0" + , requestId = RequestIdNumber 1 + , requestMethod = method + , requestParams = params + } + +-- params carrying the standard modern _meta +modernParams :: [Pair] -> Value +modernParams extra = object $ extra ++ + [ "_meta" .= object + [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text) + , "io.modelcontextprotocol/clientInfo" .= object ["name" .= ("test-client" :: Text)] + , "io.modelcontextprotocol/clientCapabilities" .= object [] + ] + ] + +resultObject :: Maybe JsonRpcMessage -> IO Object +resultObject (Just (JsonRpcMessageResponse r)) = case responseResult r of + Just (Object o) -> pure o + other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty +resultObject other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty + +errorOf :: Maybe JsonRpcMessage -> IO JsonRpcError +errorOf (Just (JsonRpcMessageResponse r)) = case responseError r of + Just e -> pure e + Nothing -> expectationFailure "Expected an error response" >> pure (JsonRpcError 0 "" Nothing) +errorOf other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure (JsonRpcError 0 "" Nothing) + +spec :: Spec +spec = describe "Dual-era protocol support" $ do + + describe "server/discover" $ do + it "reports all supported revisions, newest first" $ do + o <- resultObject =<< run (request "server/discover" (Just (modernParams []))) + KM.lookup "supportedVersions" o `shouldBe` + Just (toJSON (["2026-07-28", "2025-11-25", "2025-06-18", "2025-03-26", "2024-11-05"] :: [Text])) + + it "advertises only capabilities with handlers, plus identity and instructions" $ do + o <- resultObject =<< run (request "server/discover" (Just (modernParams []))) + case KM.lookup "capabilities" o of + Just (Object caps) -> do + KM.member "tools" caps `shouldBe` True + KM.member "prompts" caps `shouldBe` False + other -> expectationFailure $ "capabilities not an object: " ++ show other + KM.lookup "instructions" o `shouldBe` Just (String "Use the tools.") + case KM.lookup "_meta" o of + Just (Object m) -> + KM.lookup "io.modelcontextprotocol/serverInfo" m `shouldBe` + Just (object ["name" .= ("Test Server" :: Text), "version" .= ("9.9.9" :: Text)]) + other -> expectationFailure $ "_meta not an object: " ++ show other + + it "carries the modern result envelope even without _meta (probe)" $ do + o <- resultObject =<< run (request "server/discover" Nothing) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.member "ttlMs" o `shouldBe` True + KM.lookup "cacheScope" o `shouldBe` Just (String "private") + + describe "Modern requests" $ do + it "stamps resultType and cache fields on cacheable results" $ do + o <- resultObject =<< run (request "tools/list" (Just (modernParams []))) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.lookup "ttlMs" o `shouldBe` Just (Number 0) + KM.lookup "cacheScope" o `shouldBe` Just (String "private") + + it "stamps resultType but not cache fields on tools/call" $ do + o <- resultObject =<< run (request "tools/call" + (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []]))) + KM.lookup "resultType" o `shouldBe` Just (String "complete") + KM.member "ttlMs" o `shouldBe` False + + it "exposes the declared protocol version to handlers via ClientContext" $ do + o <- resultObject =<< run (request "tools/call" + (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []]))) + KM.lookup "content" o `shouldBe` + Just (toJSON [object ["type" .= ("text" :: Text), "text" .= ("version=2026-07-28" :: Text)]]) + + it "serves initialize and ping as unknown methods when a modern revision is declared" $ do + e1 <- errorOf =<< run (request "initialize" (Just (modernParams + [ "protocolVersion" .= ("2026-07-28" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ]))) + errorCode e1 `shouldBe` (-32601) + e2 <- errorOf =<< run (request "ping" (Just (modernParams []))) + errorCode e2 `shouldBe` (-32601) + + it "rejects undeclared revisions with UnsupportedProtocolVersionError" $ do + e <- errorOf =<< run (request "tools/list" (Just (object + [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2099-01-01" :: Text)] ]))) + errorCode e `shouldBe` (-32022) + case errorData e of + Just (Object d) -> do + KM.lookup "requested" d `shouldBe` Just (String "2099-01-01") + case KM.lookup "supported" d of + Just (Array _) -> pure () + other -> expectationFailure $ "supported not a list: " ++ show other + other -> expectationFailure $ "no error data: " ++ show other + + describe "Legacy requests" $ do + it "are served without the modern envelope" $ do + o <- resultObject =<< run (request "tools/list" Nothing) + KM.member "resultType" o `shouldBe` False + KM.member "ttlMs" o `shouldBe` False + KM.member "_meta" o `shouldBe` False + + it "negotiate down to the newest legacy revision when proposing 2026-07-28 via initialize" $ do + o <- resultObject =<< run (request "initialize" (Just (object + [ "protocolVersion" .= ("2026-07-28" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ]))) + KM.lookup "protocolVersion" o `shouldBe` Just (String "2025-11-25") + + describe "HTTP request metadata validation" $ do + let modernBody name = encode $ object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (7 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" .= modernParams ["name" .= name, "arguments" .= object []] + ] + reqWith hs = Wai.defaultRequest { Wai.requestHeaders = hs } + + it "peeks method, name, version and id from the body" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + peekMethod peek `shouldBe` Just "tools/call" + peekName peek `shouldBe` Just "get_weather" + peekMetaVersion peek `shouldBe` Just "2026-07-28" + peekId peek `shouldBe` RequestIdNumber 7 + peekIsModern peek `shouldBe` True + + it "accepts a fully consistent modern request" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "get_weather") + ]) peek `shouldBe` Nothing + + it "rejects a missing Mcp-Method header with HeaderMismatch" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + fmap errorCode (validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Name", "get_weather") + ]) peek) `shouldBe` Just (-32020) + + it "rejects a header/body protocol version mismatch with HeaderMismatch" $ do + let peek = peekBody (modernBody ("get_weather" :: Text)) + fmap errorCode (validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2025-11-25") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "get_weather") + ]) peek) `shouldBe` Just (-32020) + + it "accepts a base64-sentinel Mcp-Name for non-ASCII names" $ do + let peek = peekBody (modernBody ("Hello, 世界" :: Text)) + validateRequestHeaders (reqWith + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "=?base64?SGVsbG8sIOS4lueVjA==?=") + ]) peek `shouldBe` Nothing + + it "legacy bodies keep the relaxed rules (no headers required)" $ do + let legacyBody = encode $ object + [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int) + , "method" .= ("tools/list" :: Text) ] + validateRequestHeaders (reqWith []) (peekBody legacyBody) `shouldBe` Nothing + + it "legacy bodies with an unsupported version header are rejected" $ do + let legacyBody = encode $ object + [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int) + , "method" .= ("tools/list" :: Text) ] + fmap errorCode (validateRequestHeaders + (reqWith [("MCP-Protocol-Version", "1999-01-01")]) + (peekBody legacyBody)) `shouldBe` Just (-32600) + + describe "Streaming-response selection" $ do + let tokenMeta = "\"_meta\":{\"progressToken\":\"t1\"}" + + it "streams dispatchable requests that carry a progressToken" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"tools/call\",\"params\":{\"name\":\"x\",\"arguments\":{}," <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` True + + it "keeps unknown methods on the JSON path so they retain their 404" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":2,\"method\":\"subscriptions/listen\",\"params\":{" <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + it "keeps notification bodies on the JSON path so they retain their 202" $ do + let body = "{\"jsonrpc\":\"2.0\",\"method\":\"tools/call\",\"params\":{\"name\":\"x\"," <> tokenMeta <> "}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + it "does not stream token-less requests" $ do + let body = "{\"jsonrpc\":\"2.0\",\"id\":3,\"method\":\"tools/call\",\"params\":{\"name\":\"x\"}}" + wantsStreamingResponse (peekBody body) `shouldBe` False + + describe "Sentinel decoding" $ do + it "passes plain values through" $ + decodeSentinel "us-west1" `shouldBe` "us-west1" + it "decodes base64 sentinel values" $ + decodeSentinel "=?base64?SGVsbG8sIOS4lueVjA==?=" `shouldBe` "Hello, 世界" diff --git a/test/Spec/Progress.hs b/test/Spec/Progress.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Progress.hs @@ -0,0 +1,106 @@ +{-# 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 + +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 $ toToolResult ("done" :: Text) + "chatty" -> do + logToClient ctx LogInfo (String "fyi") + logToClient ctx LogError (String "bad") + pure $ Right $ 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 + noNotificationSupport emit progressServer anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params))) + notifications <- readIORef sink + pure (notifications, resp) + +paramsOf :: JsonRpcNotification -> Object +paramsOf n = case notificationParams n of + Just (Object o) -> o + other -> error $ "notification params not an object: " ++ show other + +spec :: Spec +spec = describe "Progress and client logging" $ do + + describe "reportProgress" $ do + it "emits tagged, ordered notifications/progress before the response" $ do + (ns, resp) <- callTool ["progressToken" .= ("abc123" :: Text)] "work" + map notificationMethod ns `shouldBe` + ["notifications/progress", "notifications/progress"] + case map paramsOf ns of + [first', second'] -> do + KM.lookup "progressToken" first' `shouldBe` Just (String "abc123") + KM.lookup "progress" first' `shouldBe` Just (Number 0.2) + KM.lookup "total" first' `shouldBe` Just (Number 1.0) + KM.lookup "message" first' `shouldBe` Just (String "starting") + KM.lookup "progress" second' `shouldBe` Just (Number 0.9) + KM.member "total" second' `shouldBe` False + KM.member "message" second' `shouldBe` False + other -> expectationFailure $ "expected two notifications, got: " ++ show (length other) + resp `shouldSatisfy` (/= Nothing) + + it "preserves integer tokens as integers" $ do + (ns, _) <- callTool ["progressToken" .= (42 :: Int)] "work" + map (KM.lookup "progressToken" . paramsOf) ns `shouldBe` + [Just (Number 42), Just (Number 42)] + + it "is a no-op without a progressToken" $ do + (ns, resp) <- callTool [] "work" + ns `shouldBe` [] + resp `shouldSatisfy` (/= Nothing) + + describe "logToClient" $ do + it "filters below the declared level and emits at or above it" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("warning" :: Text)] "chatty" + map notificationMethod ns `shouldBe` ["notifications/message"] + case ns of + [n] -> do + KM.lookup "level" (paramsOf n) `shouldBe` Just (String "error") + KM.lookup "data" (paramsOf n) `shouldBe` Just (String "bad") + other -> expectationFailure $ "expected one notification, got: " ++ show (length other) + + it "emits everything at a permissive level" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("debug" :: Text)] "chatty" + map (KM.lookup "level" . paramsOf) ns `shouldBe` + [Just (String "info"), Just (String "error")] + + it "emits nothing when the request declared no logLevel (spec MUST NOT)" $ do + (ns, _) <- callTool [] "chatty" + ns `shouldBe` [] + + it "treats an unparseable logLevel as absent" $ do + (ns, _) <- callTool ["io.modelcontextprotocol/logLevel" .= ("loudly" :: Text)] "chatty" + ns `shouldBe` [] diff --git a/test/Spec/ProtocolVersionNegotiation.hs b/test/Spec/ProtocolVersionNegotiation.hs --- a/test/Spec/ProtocolVersionNegotiation.hs +++ b/test/Spec/ProtocolVersionNegotiation.hs @@ -10,7 +10,7 @@ import MCP.Server.Handlers (handleInitialize) import MCP.Server.JsonRpc (JsonRpcRequest(..), RequestId(..), JsonRpcResponse(..), JsonRpcError(..)) import MCP.Server.Protocol (protocolVersion) -import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..)) +import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..), noHandlers, noNotificationSupport) -- | Test that server performs proper version negotiation according to MCP spec. -- @@ -33,10 +33,8 @@ -- A server that only provides tools: capabilities in the initialize -- response should reflect exactly this. - let testHandlers = McpServerHandlers - { prompts = Nothing - , resources = Nothing - , tools = Just ( \_ctx -> pure [] + let testHandlers = noHandlers + { tools = Just ( \_ctx -> pure [] , \_ctx name _args -> pure (Left (UnknownTool name)) ) } @@ -57,7 +55,7 @@ , requestMethod = "initialize" , requestParams = Just params } - handleInitialize testServerInfo testHandlers request + handleInitialize testServerInfo noNotificationSupport testHandlers request -- Issue an initialize request proposing the given protocol version and -- return the negotiated version from the server's (non-error) response. diff --git a/test/Spec/SchemaValidation.hs b/test/Spec/SchemaValidation.hs --- a/test/Spec/SchemaValidation.hs +++ b/test/Spec/SchemaValidation.hs @@ -9,14 +9,15 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec +import TestHelpers import TestTypes import TestData -- Generate handlers for testing -testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlers :: (ToolListHandler, ToolCallHandler) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) -testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions) -- Helper functions for schema validation @@ -27,13 +28,11 @@ [] -> error $ "Tool not found: " ++ T.unpack toolName _ -> error $ "Multiple tools found with name: " ++ T.unpack toolName -getProperty :: Text -> ToolDefinition -> InputSchemaDefinitionProperty +getProperty :: Text -> ToolDefinition -> Schema getProperty propertyName toolDef = - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject props _ -> - case lookup propertyName props of - Just prop -> prop - Nothing -> error $ "Property not found: " ++ T.unpack propertyName + case lookupProp propertyName toolDef of + Just prop -> prop + Nothing -> error $ "Property not found: " ++ T.unpack propertyName assertToolExists :: Text -> [ToolDefinition] -> IO () assertToolExists toolName toolDefs = do @@ -42,18 +41,17 @@ assertHasProperty :: Text -> Text -> ToolDefinition -> IO () assertHasProperty propertyName expectedType toolDef = do let prop = getProperty propertyName toolDef - propertyType prop `shouldBe` expectedType + schemaTypeName prop `shouldBe` expectedType assertPropertyDescription :: Text -> ToolDefinition -> Text -> IO () assertPropertyDescription propertyName toolDef expectedDesc = do let prop = getProperty propertyName toolDef - propertyDescription prop `shouldBe` expectedDesc + schemaDescription prop `shouldBe` Just expectedDesc assertRequiredFields :: [Text] -> ToolDefinition -> IO () assertRequiredFields expectedFields toolDef = do - case toolDefinitionInputSchema toolDef of - InputSchemaDefinitionObject _ required -> - all (`elem` required) expectedFields `shouldBe` True + let required = schemaRequired (toolDefinitionInputSchema toolDef) + all (`elem` required) expectedFields `shouldBe` True assertToolDescription :: ToolDefinition -> Text -> IO () assertToolDescription toolDef expectedDesc = diff --git a/test/Spec/Subscriptions.hs b/test/Spec/Subscriptions.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Subscriptions.hs @@ -0,0 +1,158 @@ +{-# 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 + +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 + support + (\_ -> pure ()) + toolsServer + anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) + capsOf resp = case resp of + Just (JsonRpcMessageResponse r) + | Just (Object o) <- responseResult r + , Just (Object caps) <- KM.lookup "capabilities" o -> pure caps + other -> error $ "no capabilities in: " ++ show other + initParams = Just $ object + [ "protocolVersion" .= ("2025-11-25" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)] + ] + + it "legacy initialize advertises listChanged only with legacy push" $ do + caps <- capsOf =<< run (NotificationSupport True True) "initialize" initParams + KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True]) + -- legacy subscribe (the removed resources/subscribe RPC) is never advertised + KM.lookup "resources" caps `shouldBe` Just (object ["listChanged" .= True]) + + it "legacy initialize over a push-less transport advertises neither" $ do + caps <- capsOf =<< run (NotificationSupport False True) "initialize" initParams + KM.lookup "tools" caps `shouldBe` Just (object []) + KM.lookup "resources" caps `shouldBe` Just (object []) + + it "modern discover advertises listChanged and subscribe when listen is served" $ do + caps <- capsOf =<< run (NotificationSupport False True) "server/discover" Nothing + KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True]) + KM.lookup "resources" caps `shouldBe` + Just (object ["subscribe" .= True, "listChanged" .= True]) + + it "no support means nothing extra is advertised" $ do + caps <- capsOf =<< run noNotificationSupport "server/discover" Nothing + KM.lookup "tools" caps `shouldBe` Just (object []) diff --git a/test/Spec/TemplatesCompletions.hs b/test/Spec/TemplatesCompletions.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TemplatesCompletions.hs @@ -0,0 +1,178 @@ +{-# 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 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 ResourceContent) +readUri s = case parseURI s of + Just uri -> snd templResourceHandlers anonCtx uri + Nothing -> fail ("bad test URI: " ++ s) + +expectText :: Either Error ResourceContent -> Text -> Expectation +expectText (Right (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 + noNotificationSupport + (\_ -> pure ()) + handlers + anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) + +resultOf :: Maybe JsonRpcMessage -> IO Object +resultOf (Just (JsonRpcMessageResponse r)) = case responseResult r of + Just (Object o) -> pure o + other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty +resultOf other = + expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty + +spec :: Spec +spec = describe "Resource templates and completions" $ do + + describe "Template derivation" $ do + it "advertises record constructors as URI templates" $ do + templates <- templTemplates anonCtx + map resourceTemplateURITemplate templates `shouldBe` + [ "resource://member_profile/{memberId}" + , "resource://order_item/{orderId}/{itemName}" + ] + map resourceTemplateDescription templates `shouldBe` + [ Just "A member's profile", Just "One item of an order" ] + + it "excludes record constructors from the static resource list" $ do + statics <- fst templResourceHandlers anonCtx + map resourceDefinitionURI statics `shouldBe` ["resource://catalog"] + + describe "Template reads" $ do + it "still reads static resources" $ do + result <- readUri "resource://catalog" + result `expectText` "The catalog" + + it "reads a single-parameter template" $ do + result <- readUri "resource://member_profile/alice" + result `expectText` "Profile of alice" + + it "percent-decodes template segments" $ do + result <- readUri "resource://member_profile/alice%20smith" + result `expectText` "Profile of alice smith" + + it "ignores query strings and fragments when matching templates" $ do + result <- readUri "resource://member_profile/alice?x=1" + result `expectText` "Profile of alice" + result2 <- readUri "resource://member_profile/alice#frag" + result2 `expectText` "Profile of alice" + + it "reads a multi-parameter template with typed segments" $ do + result <- readUri "resource://order_item/42/widget" + result `expectText` "Order 42 item widget" + + it "rejects segments that fail the field's type" $ do + result <- readUri "resource://order_item/notanum/widget" + case result of + Left (InvalidParams msg) -> msg `shouldSatisfy` T.isInfixOf "template field 'orderId'" + other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other + + it "falls through to ResourceNotFound on a segment-count mismatch" $ do + result <- readUri "resource://member_profile/a/b" + case result of + Left (ResourceNotFound _) -> pure () + other -> expectationFailure $ "Expected ResourceNotFound but got: " ++ show other + + describe "resources/templates/list dispatch" $ do + it "returns templates and carries the modern cache envelope" $ do + let handlers = noHandlers { resourceTemplates = Just templTemplates } + o <- resultOf =<< runReq handlers "resources/templates/list" (Just (object + [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)] ])) + KM.member "resourceTemplates" o `shouldBe` True + KM.member "ttlMs" o `shouldBe` True + KM.lookup "resultType" o `shouldBe` Just (String "complete") + + it "answers -32601 when no template handler is configured" $ do + resp <- runReq noHandlers "resources/templates/list" Nothing + case resp of + Just (JsonRpcMessageResponse r) -> + fmap errorCode (responseError r) `shouldBe` Just (-32601) + other -> expectationFailure $ "Expected a response, got: " ++ show other + + it "answers resources/list with an empty list for a templates-only server" $ do + let handlers = noHandlers { resourceTemplates = Just templTemplates } + o <- resultOf =<< runReq handlers "resources/list" Nothing + KM.lookup "resources" o `shouldBe` Just (toJSON ([] :: [ResourceDefinition])) + + describe "completion/complete" $ do + it "dispatches prompt refs with context arguments" $ do + o <- resultOf =<< runReq completionServer "completion/complete" (Just (object + [ "ref" .= object ["type" .= ("ref/prompt" :: Text), "name" .= ("recipe" :: Text)] + , "argument" .= object ["name" .= ("idea" :: Text), "value" .= ("pa" :: Text)] + , "context" .= object ["arguments" .= object ["cuisine" .= ("italian" :: Text)]] + ])) + KM.lookup "completion" o `shouldBe` + Just (object ["values" .= (["prompt:recipe:idea:pa:cuisine"] :: [Text])]) + + it "dispatches resource template refs" $ do + o <- resultOf =<< runReq completionServer "completion/complete" (Just (object + [ "ref" .= object ["type" .= ("ref/resource" :: Text), "uri" .= ("resource://member_profile/{memberId}" :: Text)] + , "argument" .= object ["name" .= ("memberId" :: Text), "value" .= ("al" :: Text)] + ])) + KM.lookup "completion" o `shouldBe` + Just (object ["values" .= (["resource:resource://member_profile/{memberId}:memberId"] :: [Text])]) + + it "answers -32601 when no completion handler is configured" $ do + resp <- runReq noHandlers "completion/complete" Nothing + case resp of + Just (JsonRpcMessageResponse r) -> + fmap errorCode (responseError r) `shouldBe` Just (-32601) + other -> expectationFailure $ "Expected a response, got: " ++ show other + + describe "Capabilities" $ do + it "advertises completions and resources-via-templates when configured" $ do + let handlers = noHandlers + { resourceTemplates = Just templTemplates + , completions = Just testCompletions + } + o <- resultOf =<< runReq handlers "server/discover" Nothing + case KM.lookup "capabilities" o of + Just (Object caps) -> do + KM.member "completions" caps `shouldBe` True + KM.member "resources" caps `shouldBe` True + KM.member "tools" caps `shouldBe` False + other -> expectationFailure $ "capabilities not an object: " ++ show other diff --git a/test/Spec/ToolCallParsing.hs b/test/Spec/ToolCallParsing.hs --- a/test/Spec/ToolCallParsing.hs +++ b/test/Spec/ToolCallParsing.hs @@ -3,27 +3,27 @@ module Spec.ToolCallParsing (spec) where +import Data.Aeson (Value (..)) import Data.Text (Text) import qualified Data.Text as T 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 ToolResult) +callTool name args = snd allTypesHandlers anonCtx name (stringArgs args) -shouldBeRight :: IO (Either Error Content) -> Text -> IO () +shouldBeRight :: IO (Either Error 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 ToolResult) -> Text -> IO () shouldBeInvalidParams action expectedSubstring = do result <- action case result of @@ -31,7 +31,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 ToolResult) -> Text -> IO () shouldBeMissingParams action expectedSubstring = do result <- action case result of @@ -146,3 +146,14 @@ shouldBeMissingParams (callTool "required_fields" [("rfText", "hello")]) "is missing" + + describe "Integer exponent bound" $ do + -- Regression: aeson keeps huge exponents compact, so without a bound a + -- ~13-byte payload like 1e100000 would materialize a 100001-digit Integer. + it "rejects huge exponents without materializing the Integer" $ do + result <- snd allTypesHandlers anonCtx "optional_fields" + (valueArgs [("ofInteger", Number (read "1e100000"))]) + case result of + Left (InvalidParams msg) -> + msg `shouldSatisfy` T.isInfixOf "exponent too large" + other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other diff --git a/test/Spec/TypedArgs.hs b/test/Spec/TypedArgs.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TypedArgs.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for the 0.2 typed-argument features: native JSON values, +-- enumerations, lists, nested records, isError results and multi-message +-- prompts. +module Spec.TypedArgs (spec) where + +import Data.Aeson (Value (..), 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 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 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 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 result of + Right (PromptResult desc msgs) -> do + desc `shouldBe` Just "About haskell" + map promptMessageRole msgs `shouldBe` [RoleUser, RoleAssistant] + Left err -> expectationFailure $ "Expected prompt result but got: " ++ show err diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -5,6 +5,7 @@ import Data.Aeson import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as TE import MCP.Server.Protocol @@ -61,7 +62,8 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Result: √16 = 4, π ≈ 3.14159"] , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- 2025-06-18: New _meta field + , toolsCallStructuredContent = Nothing + , toolsCallMeta = Nothing } let encoded = encode response -- Just verify the JSON can be encoded and contains Unicode @@ -87,7 +89,8 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Mathematical result: √(π²+e²) ≈ 4.53"] , toolsCallIsError = Nothing - , toolsCallMeta = Nothing -- 2025-06-18: New _meta field + , toolsCallStructuredContent = Nothing + , toolsCallMeta = Nothing } let json = toJSON response -- Verify the JSON can be encoded and contains Unicode @@ -168,27 +171,21 @@ 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 $ 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 } ] @@ -198,26 +195,21 @@ 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 $ 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 (PromptResult _ [PromptMessage _ (ContentText txt)]) -> txt `shouldSatisfy` T.isInfixOf "√" _ -> expectationFailure "Expected successful prompt result" uri <- case parseURI "resource://unicode_symbols" of @@ -247,9 +239,9 @@ Right (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 tr | [ContentText txt] <- toolResultContent tr -> do txt `shouldSatisfy` T.isInfixOf "√" txt `shouldSatisfy` T.isInfixOf "∫" _ -> expectationFailure "Expected successful tool result" diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/TestHelpers.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared helpers for exercising the 0.2 handler API from tests. +module TestHelpers + ( -- * Building argument maps + stringArgs + , valueArgs + , promptArgsMap + -- * Result expectations + , shouldBeTextResult + , shouldBeTextResultContaining + , shouldBePromptText + -- * Schema access + , schemaTypeName + , schemaProps + , schemaRequired + , lookupProp + ) where + +import Data.Aeson (Value (..)) +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 + +-- | Expect a successful, non-error tool result with exactly one text block. +shouldBeTextResult :: Either Error ToolResult -> Text -> Expectation +shouldBeTextResult (Right 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 ToolResult -> Text -> Expectation +shouldBeTextResultContaining (Right 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 PromptResult -> Text -> Expectation +shouldBePromptText (Right (PromptResult _ [PromptMessage RoleUser (ContentText content)])) expected = + content `shouldBe` expected +shouldBePromptText other expected = + expectationFailure $ "Expected prompt text '" ++ T.unpack expected ++ "' but got: " ++ show other + +-- | 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" + +-- | The properties of an object schema (empty for non-objects). +schemaProps :: Schema -> [(Text, Schema)] +schemaProps s = case schemaShape s of + SchemaObject props _ -> props + _ -> [] + +-- | The required field names of an object schema. +schemaRequired :: Schema -> [Text] +schemaRequired s = case schemaShape s of + SchemaObject _ req -> req + _ -> [] + +-- | Look up a property schema in a tool's input schema. +lookupProp :: Text -> ToolDefinition -> Maybe Schema +lookupProp name def = lookup name (schemaProps (toolDefinitionInputSchema def)) diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -4,12 +4,16 @@ import Data.Text (Text) import qualified Data.Text as T -import MCP.Server (ClientContext(..), Content(..), ResourceContent(..)) +import MCP.Server (ClientContext, anonymousContext, Content (..), MessageRole (..), + PromptMessage (..), PromptResult (..), + ResourceContent (..), ToolOutput (..), + ToolResult, toolError, + toolResult) import Network.URI (URI) -- Context passed to handlers in tests (no transport-level identity) anonCtx :: ClientContext -anonCtx = ClientContext Nothing Nothing +anonCtx = anonymousContext -- Test data types for end-to-end testing data TestPrompt @@ -135,6 +139,100 @@ , "float=" <> maybe "Nothing" (T.pack . show) f , "bool=" <> maybe "Nothing" (T.pack . show) b ] + +-- Types exercising 0.2 typed arguments: enums, lists, nested records +data Color = Red | Green | Blue + deriving (Show, Eq) + +data Filters = Filters { tags :: [Text], maxCount :: Maybe Int } + deriving (Show, Eq) + +data TypedTool + = Paint { color :: Color, brightness :: Int } + | BulkAdd { values :: [Int] } + | QueryData { filters :: Filters } + | AlwaysFails { reason :: Text } + deriving (Show, Eq) + +handleTypedTool :: ClientContext -> TypedTool -> IO ToolResult +handleTypedTool _ (Paint c b) = + pure $ toolResult [ContentText $ "Painting " <> T.pack (show c) <> " at " <> T.pack (show b)] +handleTypedTool _ (BulkAdd vs) = + pure $ toolResult [ContentText $ "Sum: " <> T.pack (show (sum vs))] +handleTypedTool _ (QueryData (Filters ts mc)) = + pure $ toolResult [ContentText $ "Query tags=" <> T.intercalate "," ts + <> maybe "" ((" max=" <>) . T.pack . show) mc] +handleTypedTool _ (AlwaysFails msg) = + pure $ toolError msg + +-- Resource type mixing static resources and templates (record constructors) +data TemplResource + = Catalog + | MemberProfile { memberId :: Text } + | OrderItem { orderId :: Int, itemName :: Text } + deriving (Show, Eq) + +handleTemplResource :: ClientContext -> URI -> TemplResource -> IO ResourceContent +handleTemplResource _ uri Catalog = + pure $ ResourceText uri "text/plain" "The catalog" +handleTemplResource _ uri (MemberProfile uid) = + pure $ ResourceText uri "text/plain" ("Profile of " <> uid) +handleTemplResource _ uri (OrderItem oid item) = + pure $ ResourceText uri "text/plain" ("Order " <> T.pack (show oid) <> " item " <> item) + +-- Types exercising derived structured output (ADR 0005) +data Wind = Wind { windSpeedKph :: Double, windGusting :: Bool } + deriving (Show, Eq) + +data Sky = SkyClear | SkyCloudy | SkyRaining + deriving (Show, Eq) + +data WeatherReport = WeatherReport + { wrTemperature :: Int + , wrSky :: Sky + , wrWind :: Wind + , wrAlerts :: [Text] + , wrHumidity :: Maybe Int + } deriving (Show, Eq) + +data WeatherTool + = GetWeather { wtCity :: Text } + | BrokenStation { wtStation :: Text } + | CustomReport { wtRegion :: Text } + | PlainForecast { wtNote :: Text } + deriving (Show, Eq) + +sampleReport :: Text -> Maybe Int -> WeatherReport +sampleReport place humidity = WeatherReport + { wrTemperature = 21 + , wrSky = SkyCloudy + , wrWind = Wind 12.5 False + , wrAlerts = ["wind advisory for " <> place] + , wrHumidity = humidity + } + +handleWeatherTool :: ClientContext -> WeatherTool -> IO (ToolOutput WeatherReport) +handleWeatherTool _ (GetWeather c) = + pure $ ToolOutput (sampleReport c (Just 60)) +handleWeatherTool _ (BrokenStation s) = + pure $ ToolOutputError ("station offline: " <> s) +handleWeatherTool _ (CustomReport r) = + pure $ ToolOutputWith [ContentText ("Report for " <> r)] (sampleReport r Nothing) +handleWeatherTool _ (PlainForecast n) = + pure $ ToolOutputRaw (toolResult [ContentText n]) + +-- A prompt whose handler produces a multi-message conversation +data ConvPrompt = Conversation { topic :: Text } + deriving (Show, Eq) + +handleConvPrompt :: ClientContext -> ConvPrompt -> IO PromptResult +handleConvPrompt _ (Conversation t) = pure $ PromptResult + { promptResultDescription = Just ("About " <> t) + , promptResultMessages = + [ PromptMessage RoleUser (ContentText ("Tell me about " <> t)) + , PromptMessage RoleAssistant (ContentText ("Here is what I know about " <> t)) + ] + } -- Test descriptions for custom description functionality testDescriptions :: [(String, String)] diff --git a/test/golden/README.md b/test/golden/README.md new file mode 100644 --- /dev/null +++ b/test/golden/README.md @@ -0,0 +1,69 @@ +# MCP wire-format conformance corpus + +Each case in this directory is a pair of files: + +- `.request.json` — a single JSON-RPC request, exactly as it would + arrive on the wire (one line). +- `.response.json` — the reference server's exact response. + +`manifest.json` enumerates the cases and states, per case, which +reference-server variant answers it (`handlers`) and whether the serving +transport can deliver change notifications (`notifications`). Responses are +compared as **parsed JSON** (structural equality), not raw bytes, so object +key order never matters — with one deliberate exception: JSON embedded +*inside a string* (the structured-output text block) is compared as part of +the string, so those bytes are canonical: compact, object keys sorted. + +The corpus is deliberately **API-agnostic**: nothing in it refers to this +library's types or Haskell at all. Any MCP server implementation that +reproduces the reference server below can replay the requests and diff the +responses — the cases then pin protocol behavior (error codes, era +envelopes, capability advertisement) rather than any particular API. + +## Eras + +- `legacy/` — requests carry no modern `_meta`; they are answered under the + revision negotiated by `initialize` (2024-11-05 … 2025-11-25 share this + wire format for the operations covered here). These fixtures were + generated from mcp-server v0.2.0 and are the anchor for "newer protocol + work leaves legacy responses unchanged" — **never regenerate them** from a + branch that intends to preserve legacy output. +- `modern/` — requests declare a revision (2026-07-28) in params `_meta`; + responses carry the modern envelope: `resultType`, server identity in + result `_meta`, and `ttlMs`/`cacheScope` on the cacheable methods. + +## The reference server + +Identity: name `Golden Server`, version `1.0.0`, instructions +`Golden fixture server`. Cache hints: `ttlMs` 0, scope `private`. + +The `base` handler set: + +| Feature | Definition | Behavior | +|---|---|---| +| Tool `echo` | input schema: object, required `text` (string, described "The text") | returns one text content block `echo: ` | +| Tool `boom` | not listed | any call returns `isError: true` with text `kaboom` | +| Prompt `greet` | one required argument `name` ("Who to greet") | description `A greeting`, one user message `Hello, !` | +| Resource `resource://info` | name `info`, description `Some info`, `text/plain` | text contents `The golden info` | + +The `extended` handler set adds (used only for methods that postdate the +v0.2.0 anchor, so the anchored capability fixtures stay untouched): + +| Feature | Definition | Behavior | +|---|---|---| +| Resource template `resource://item/{itemId}` | name `item`, description `An item`, `text/plain` | — | +| Completions | any ref/argument | values = `["alpha", "beta"]` filtered by prefix of the partial value | +| Tool `echo_structured` | input schema: object, required `input` (string, "The text"); output schema: object, required `echoedText` (string, "The echoed text") and `echoedLength` (integer, "Its length"); description `Echo with structured output` | returns `structuredContent` `{"echoedText": , "echoedLength": }` plus one text content block containing the same JSON | +| Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: ` annotated with audience `["user"]`, priority `0.5` | + +Cases with `"notifications": true` are answered as if the transport can +deliver change notifications (stdio with a configured notifier: legacy push +and modern `subscriptions/listen`), which flips the advertised +`listChanged`/`subscribe` capability flags. + +## Adding a case + +Write the `.request.json` by hand, add a manifest entry, and run the test +suite with `GOLDEN_ACCEPT=1`: the missing `.response.json` is written from +the current implementation's output. Existing response fixtures are never +overwritten — delete one first to regenerate it deliberately. diff --git a/test/golden/legacy/completion-complete.request.json b/test/golden/legacy/completion-complete.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/completion-complete.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":12,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"}}} diff --git a/test/golden/legacy/completion-complete.response.json b/test/golden/legacy/completion-complete.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/completion-complete.response.json @@ -0,0 +1,1 @@ +{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}} diff --git a/test/golden/legacy/initialize-notifying.request.json b/test/golden/legacy/initialize-notifying.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize-notifying.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":13,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}} diff --git a/test/golden/legacy/initialize-notifying.response.json b/test/golden/legacy/initialize-notifying.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize-notifying.response.json @@ -0,0 +1,1 @@ +{"id":13,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true},"tools":{"listChanged":true}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}} diff --git a/test/golden/legacy/initialize.request.json b/test/golden/legacy/initialize.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}} diff --git a/test/golden/legacy/initialize.response.json b/test/golden/legacy/initialize.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/initialize.response.json @@ -0,0 +1,1 @@ +{"id":1,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{},"resources":{},"tools":{}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}} diff --git a/test/golden/legacy/ping.request.json b/test/golden/legacy/ping.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/ping.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":2,"method":"ping"} diff --git a/test/golden/legacy/ping.response.json b/test/golden/legacy/ping.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/ping.response.json @@ -0,0 +1,1 @@ +{"id":2,"jsonrpc":"2.0","result":{}} diff --git a/test/golden/legacy/prompts-get.request.json b/test/golden/legacy/prompts-get.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-get.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":8,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"}}} diff --git a/test/golden/legacy/prompts-get.response.json b/test/golden/legacy/prompts-get.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-get.response.json @@ -0,0 +1,1 @@ +{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}} diff --git a/test/golden/legacy/prompts-list.request.json b/test/golden/legacy/prompts-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":7,"method":"prompts/list"} diff --git a/test/golden/legacy/prompts-list.response.json b/test/golden/legacy/prompts-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/prompts-list.response.json @@ -0,0 +1,1 @@ +{"id":7,"jsonrpc":"2.0","result":{"prompts":[{"arguments":[{"description":"Who to greet","name":"name","required":true}],"description":"Greet someone","name":"greet"}]}} diff --git a/test/golden/legacy/resources-list.request.json b/test/golden/legacy/resources-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":9,"method":"resources/list"} diff --git a/test/golden/legacy/resources-list.response.json b/test/golden/legacy/resources-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-list.response.json @@ -0,0 +1,1 @@ +{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}} diff --git a/test/golden/legacy/resources-read.request.json b/test/golden/legacy/resources-read.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-read.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":10,"method":"resources/read","params":{"uri":"resource://info"}} diff --git a/test/golden/legacy/resources-read.response.json b/test/golden/legacy/resources-read.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-read.response.json @@ -0,0 +1,1 @@ +{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}} diff --git a/test/golden/legacy/resources-templates-list.request.json b/test/golden/legacy/resources-templates-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-templates-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":11,"method":"resources/templates/list"} diff --git a/test/golden/legacy/resources-templates-list.response.json b/test/golden/legacy/resources-templates-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/resources-templates-list.response.json @@ -0,0 +1,1 @@ +{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}} diff --git a/test/golden/legacy/tools-call-annotated.request.json b/test/golden/legacy/tools-call-annotated.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":16,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"}}} diff --git a/test/golden/legacy/tools-call-annotated.response.json b/test/golden/legacy/tools-call-annotated.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.response.json @@ -0,0 +1,1 @@ +{"id":16,"jsonrpc":"2.0","result":{"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}]}} diff --git a/test/golden/legacy/tools-call-boom.request.json b/test/golden/legacy/tools-call-boom.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-boom.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":6,"method":"tools/call","params":{"name":"boom","arguments":{}}} diff --git a/test/golden/legacy/tools-call-boom.response.json b/test/golden/legacy/tools-call-boom.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-boom.response.json @@ -0,0 +1,1 @@ +{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}} diff --git a/test/golden/legacy/tools-call-echo.request.json b/test/golden/legacy/tools-call-echo.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-echo.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"}}} diff --git a/test/golden/legacy/tools-call-echo.response.json b/test/golden/legacy/tools-call-echo.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-echo.response.json @@ -0,0 +1,1 @@ +{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}} diff --git a/test/golden/legacy/tools-call-structured.request.json b/test/golden/legacy/tools-call-structured.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-structured.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":15,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"}}} diff --git a/test/golden/legacy/tools-call-structured.response.json b/test/golden/legacy/tools-call-structured.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-structured.response.json @@ -0,0 +1,1 @@ +{"id":15,"jsonrpc":"2.0","result":{"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"structuredContent":{"echoedLength":6,"echoedText":"golden"}}} diff --git a/test/golden/legacy/tools-call-unknown.request.json b/test/golden/legacy/tools-call-unknown.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-unknown.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"nope","arguments":{}}} diff --git a/test/golden/legacy/tools-call-unknown.response.json b/test/golden/legacy/tools-call-unknown.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-unknown.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"} diff --git a/test/golden/legacy/tools-list-extended.request.json b/test/golden/legacy/tools-list-extended.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list-extended.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":14,"method":"tools/list"} diff --git a/test/golden/legacy/tools-list-extended.response.json b/test/golden/legacy/tools-list-extended.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list-extended.response.json @@ -0,0 +1,1 @@ +{"id":14,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"},{"description":"Echo with structured output","inputSchema":{"properties":{"input":{"description":"The text","type":"string"}},"required":["input"],"type":"object"},"name":"echo_structured","outputSchema":{"properties":{"echoedLength":{"description":"Its length","type":"integer"},"echoedText":{"description":"The echoed text","type":"string"}},"required":["echoedText","echoedLength"],"type":"object"}},{"annotations":{"idempotentHint":true,"readOnlyHint":true},"description":"A read-only probe","icons":[{"src":"https://example.com/probe.png"}],"inputSchema":{"properties":{"probe":{"description":"What to probe","type":"string"}},"required":["probe"],"type":"object"},"name":"annotated_probe","title":"Probe"}]}} diff --git a/test/golden/legacy/tools-list.request.json b/test/golden/legacy/tools-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":3,"method":"tools/list"} diff --git a/test/golden/legacy/tools-list.response.json b/test/golden/legacy/tools-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-list.response.json @@ -0,0 +1,1 @@ +{"id":3,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}]}} diff --git a/test/golden/manifest.json b/test/golden/manifest.json new file mode 100644 --- /dev/null +++ b/test/golden/manifest.json @@ -0,0 +1,151 @@ +{ + "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-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-structured", + "handlers": "extended", + "notifications": false + }, + { + "name": "modern/tools-list", + "handlers": "base", + "notifications": false + }, + { + "name": "modern/unsupported-version", + "handlers": "base", + "notifications": false + } + ] +} diff --git a/test/golden/modern/completion-complete.request.json b/test/golden/modern/completion-complete.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/completion-complete.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":30,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/completion-complete.response.json b/test/golden/modern/completion-complete.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/completion-complete.response.json @@ -0,0 +1,1 @@ +{"id":30,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"completion":{"values":["alpha"]},"resultType":"complete"}} diff --git a/test/golden/modern/initialize.request.json b/test/golden/modern/initialize.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/initialize.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":27,"method":"initialize","params":{"protocolVersion":"2026-07-28","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/initialize.response.json b/test/golden/modern/initialize.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/initialize.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32601,"message":"Method not found: initialize (not part of protocol revision 2026-07-28)"},"id":27,"jsonrpc":"2.0"} diff --git a/test/golden/modern/ping.request.json b/test/golden/modern/ping.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/ping.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":28,"method":"ping","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/ping.response.json b/test/golden/modern/ping.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/ping.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32601,"message":"Method not found: ping (not part of protocol revision 2026-07-28)"},"id":28,"jsonrpc":"2.0"} diff --git a/test/golden/modern/prompts-get.request.json b/test/golden/modern/prompts-get.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/prompts-get.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":24,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/prompts-get.response.json b/test/golden/modern/prompts-get.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/prompts-get.response.json @@ -0,0 +1,1 @@ +{"id":24,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}],"resultType":"complete"}} diff --git a/test/golden/modern/resources-read.request.json b/test/golden/modern/resources-read.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-read.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":25,"method":"resources/read","params":{"uri":"resource://info","_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/resources-read.response.json b/test/golden/modern/resources-read.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-read.response.json @@ -0,0 +1,1 @@ +{"id":25,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}],"resultType":"complete","ttlMs":0}} diff --git a/test/golden/modern/resources-templates-list.request.json b/test/golden/modern/resources-templates-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-templates-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":29,"method":"resources/templates/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/resources-templates-list.response.json b/test/golden/modern/resources-templates-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/resources-templates-list.response.json @@ -0,0 +1,1 @@ +{"id":29,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}],"resultType":"complete","ttlMs":0}} diff --git a/test/golden/modern/server-discover-notifying.request.json b/test/golden/modern/server-discover-notifying.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover-notifying.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":31,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/server-discover-notifying.response.json b/test/golden/modern/server-discover-notifying.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover-notifying.response.json @@ -0,0 +1,1 @@ +{"id":31,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true,"subscribe":true},"tools":{"listChanged":true}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}} diff --git a/test/golden/modern/server-discover.request.json b/test/golden/modern/server-discover.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":21,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/server-discover.response.json b/test/golden/modern/server-discover.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/server-discover.response.json @@ -0,0 +1,1 @@ +{"id":21,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{},"resources":{},"tools":{}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}} diff --git a/test/golden/modern/tools-call-annotated.request.json b/test/golden/modern/tools-call-annotated.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-annotated.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":33,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-annotated.response.json b/test/golden/modern/tools-call-annotated.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-annotated.response.json @@ -0,0 +1,1 @@ +{"id":33,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}],"resultType":"complete"}} diff --git a/test/golden/modern/tools-call-echo.request.json b/test/golden/modern/tools-call-echo.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-echo.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":23,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-echo.response.json b/test/golden/modern/tools-call-echo.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-echo.response.json @@ -0,0 +1,1 @@ +{"id":23,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"echo: hi","type":"text"}],"resultType":"complete"}} diff --git a/test/golden/modern/tools-call-structured.request.json b/test/golden/modern/tools-call-structured.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-structured.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":32,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-call-structured.response.json b/test/golden/modern/tools-call-structured.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-structured.response.json @@ -0,0 +1,1 @@ +{"id":32,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"resultType":"complete","structuredContent":{"echoedLength":6,"echoedText":"golden"}}} diff --git a/test/golden/modern/tools-list.request.json b/test/golden/modern/tools-list.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-list.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} diff --git a/test/golden/modern/tools-list.response.json b/test/golden/modern/tools-list.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-list.response.json @@ -0,0 +1,1 @@ +{"id":22,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resultType":"complete","tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}],"ttlMs":0}} diff --git a/test/golden/modern/unsupported-version.request.json b/test/golden/modern/unsupported-version.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/unsupported-version.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2099-01-01"}}} diff --git a/test/golden/modern/unsupported-version.response.json b/test/golden/modern/unsupported-version.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/unsupported-version.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32022,"data":{"requested":"2099-01-01","supported":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"]},"message":"Unsupported protocol version"},"id":26,"jsonrpc":"2.0"}