diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,97 @@ # Revision history for mcp-server +## 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,6 +17,9 @@ - ✅ **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 @@ -35,6 +38,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +import Data.Text (Text) import MCP.Server import MCP.Server.Derive @@ -57,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 @@ -66,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) @@ -129,6 +141,33 @@ 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: @@ -207,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: @@ -222,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) @@ -246,13 +312,73 @@ main :: IO () main = runMcpServerStdio serverInfo handlers where - handlers = McpServerHandlers + handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) - , resources = Nothing -- Not supported - , tools = Nothing -- Not supported } ``` +## 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 @@ -277,12 +403,12 @@ 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 after - `initialize`. +- **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 (NEW!) +## HTTP Transport The library supports the MCP Streamable HTTP transport. Compile your executable with `ghc-options: -threaded` — Warp requires the threaded runtime: @@ -326,23 +452,64 @@ **Features:** - CORS enabled for web clients -- POST `/mcp` for JSON-RPC messages (GET returns 405 — this library does not - offer server-initiated SSE streams) +- 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 @@ -377,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 @@ -33,10 +33,15 @@ -- 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 _ (SearchForProduct q category) = - case category of +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 @@ -69,7 +74,21 @@ let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) templates = $(deriveResourceTemplates ''MyResource) - tools = $(deriveToolHandler ''MyTool 'handleTool) + -- 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" diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.0 +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. @@ -53,6 +53,8 @@ -- Extra source files to be distributed with the package, such as examples, or a tutorial module. extra-source-files: + test/golden/README.md + test/golden/manifest.json test/golden/legacy/*.json test/golden/modern/*.json -- Source repository information @@ -88,6 +90,7 @@ -- 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, @@ -178,9 +181,13 @@ 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 @@ -204,6 +211,7 @@ build-depends: QuickCheck, aeson, + async, base, bytestring, containers, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -13,6 +13,7 @@ , defaultStdioConfig , HttpConfig(..) , defaultHttpConfig + , mcpApplication -- * Change Notifications , McpNotifier(..) @@ -28,7 +29,8 @@ import MCP.Server.Transport.Stdio (StdioConfig (..), defaultStdioConfig, transportRunStdio, transportRunStdioWithConfig) -import MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig) +import MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig, + mcpApplication) import MCP.Server.Types -- | Run an MCP server using STDIO transport 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,3 +1,4 @@ +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,24 +15,84 @@ ( -- * 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 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 ------------------------------------------------------------------------------- @@ -140,8 +201,8 @@ cons <- reifyCons n case cons of Just cs | not (null cs), all isNullary cs -> mkEnumValueParser n cs - Just [RecC icon ifields] -> mkObjectParser n icon ifields - Just [NormalC icon [(_bang, inner)]] -> [| fmap $(conE icon) . $(mkValueParser inner) |] + 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 @@ -172,11 +233,11 @@ -- Parser for a nested record: a JSON object decoded field by field mkObjectParser :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp -mkObjectParser tyName icon ifields = do +mkObjectParser tyName icn ifields = do vVar <- newName "v" oVar <- newName "o" chain <- foldl (\acc f -> [| $acc <*> $(fieldExtractor oVar f) |]) - [| pure $(conE icon) |] + [| pure $(conE icn) |] ifields fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) <> " object from: " <> renderValue $(varE vVar)) |] @@ -215,10 +276,75 @@ _ -> 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 | PromptArgs +data ArgStyle = ToolArgs | ToolArgsOutput Exp | PromptArgs -- Build a decoder expression of type @Either Error @ reading from -- the in-scope arguments map bound to 'argsName'. @@ -232,11 +358,11 @@ ConT typeName -> do cons <- reifyCons typeName case cons of - Just [RecC icon ifields] -> do - inner <- mkFieldsDecoder style (conE icon) ifields + Just [RecC icn ifields] -> do + inner <- mkFieldsDecoder style (conE icn) ifields [| $(conE cn) <$> $(return inner) |] - Just [NormalC icon [(_b, innerTy)]] -> do - innerCon <- mkConDecoder style (NormalC icon [(_b, innerTy)]) + 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 @@ -251,12 +377,12 @@ let (isOptional, innerType) = unwrapMaybe fieldType let fname = litE $ stringL $ nameBase fieldName case style of - ToolArgs - | isOptional -> [| optionalArg $fname $(mkValueParser innerType) $(varE argsName) |] - | otherwise -> [| requiredArg $fname $(mkValueParser innerType) $(varE argsName) |] 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 @@ -308,12 +434,25 @@ -- -- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -derivePromptHandlerWithDescription typeName handlerName descriptions = 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) |] @@ -327,7 +466,7 @@ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just getHandlerExp] - Nothing -> 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: @@ -337,18 +476,20 @@ 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) + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack ("Handle " ++ nameBase name)) (optDescription opts) fields <- getConFields con - args <- traverse (mkArgDef descriptions) fields + 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)) } |] mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp @@ -377,6 +518,12 @@ 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) @@ -403,12 +550,22 @@ -- -- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -deriveResourceHandlerWithDescription typeName handlerName descriptions = do +deriveResourceHandlerWithDescription typeName handlerName descriptions = + deriveResourceHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) + +-- | 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) + +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 (mkResourceDefWithDescription descriptions) + resourceDefs <- traverse (mkResourceDef conOpts) (filter isNullary constructors) listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |] @@ -420,7 +577,7 @@ let readHandlerExp = LamE [VarP ctxName, VarP uriName] readBody return $ TupE [Just listHandlerExp, Just readHandlerExp] - Nothing -> 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: @@ -436,14 +593,24 @@ -- -- > $(deriveResourceTemplatesWithDescription ''MyResource [("Constructor", "Description")]) deriveResourceTemplatesWithDescription :: Name -> [(String, String)] -> Q Exp -deriveResourceTemplatesWithDescription typeName descriptions = do +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 (mkTemplateDefWithDescription descriptions) + templateDefs <- traverse (mkTemplateDef conOpts) [c | c@(RecC _ _) <- constructors] [| \_ctx -> pure $(return $ ListE templateDefs) |] - Nothing -> fail $ "deriveResourceTemplatesWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "deriveResourceTemplates: " ++ show typeName ++ " is not a data type" -- | Derive a 'ResourceTemplateListHandler' from a resource type's record -- constructors. Usage: @@ -460,38 +627,37 @@ "resource://" <> snakeName name <> concat ["/{" <> nameBase fn <> "}" | (fn, _, _) <- fields] -mkTemplateDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkTemplateDefWithDescription _ (RecC name []) = +mkTemplateDef :: (String -> DefinitionOptions) -> Con -> Q Exp +mkTemplateDef _ (RecC name []) = fail $ "Resource template constructors need at least one field: " ++ nameBase name -mkTemplateDefWithDescription descriptions (RecC name fields) = do - let description = descriptionFor descriptions (nameBase name) (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 $(litE $ stringL description) + , resourceTemplateDescription = Just $(lift description) , resourceTemplateMimeType = Just "text/plain" - , resourceTemplateTitle = Nothing + , resourceTemplateTitle = $(lift (optTitle opts)) + , resourceTemplateIcons = $(lift (optIcons opts)) } |] -mkTemplateDefWithDescription _ _ = fail "Resource templates require record constructors" +mkTemplateDef _ _ = fail "Resource templates require record constructors" -mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkResourceDefWithDescription descriptions (NormalC name []) = do +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 + , 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. @@ -546,17 +712,83 @@ -- -- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -deriveToolHandlerWithDescription typeName handlerName descriptions = do +deriveToolHandlerWithDescription typeName handlerName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions Nothing + +-- | 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: +-- +-- > $(deriveToolHandler ''MyTool 'handleTool) +deriveToolHandler :: Name -> Name -> Q Exp +deriveToolHandler typeName handlerName = + deriveToolHandlerWithDescription typeName handlerName [] + +-- | Derive tool handlers with typed, structured output: the third name is a +-- record type describing the tools' results. Its shape becomes the derived +-- @outputSchema@ (same field rules as input derivation: primitives, +-- 'Maybe', lists, all-nullary enums, nested records), and the handler +-- returns @'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 (mkToolDefWithDescription descriptions) constructors + toolDefs <- traverse (mkToolDef conOpts globalDescs (fst <$> output)) constructors listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |] -- Generate call handler with cases - cases <- traverse (mkDispatchCase ToolArgs handlerName) constructors + 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] $ @@ -564,27 +796,24 @@ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just callHandlerExp] - Nothing -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" - --- | Derive tool handlers from a data type. --- Usage: --- --- > $(deriveToolHandler ''MyTool 'handleTool) -deriveToolHandler :: Name -> Name -> Q Exp -deriveToolHandler typeName handlerName = - deriveToolHandlerWithDescription typeName handlerName [] + Nothing -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type" -mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkToolDefWithDescription descriptions con = do +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 - shapeExp <- mkObjectShape descriptions fields + shapeExp <- mkObjectShape (fieldDescsFor opts globalDescs) fields [| ToolDefinition { toolDefinitionName = $(litE $ stringL sname) - , toolDefinitionDescription = $(litE $ stringL description) + , toolDefinitionDescription = $(lift description) , toolDefinitionInputSchema = Schema Nothing $(return shapeExp) - , toolDefinitionOutputSchema = Nothing - , toolDefinitionTitle = Nothing + , 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)) } |] 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 @@ -34,11 +34,16 @@ -- * Resource template matching , matchTemplateSegments , templateField + -- * Structured output + , resolveToolOutput + , omitNothing + , canonicalJsonText ) where -import Data.Aeson (Value (..), encode) +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) @@ -51,7 +56,9 @@ import Network.URI (unEscapeString) import Text.Read (readMaybe) -import MCP.Server.Types (Error (..)) +import MCP.Server.Types (Content (..), Error (..), + ToolOutput (..), ToolResult (..), + toolError, toolResult) -- --------------------------------------------------------------------------- -- Text-based parsers (prompt arguments are strings per the MCP spec) @@ -213,3 +220,47 @@ 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 @@ -30,6 +30,7 @@ , errorMessageFromMcpError ) where +import Control.Monad (when) import Data.Aeson import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM @@ -82,10 +83,15 @@ -- | Look up an @io.modelcontextprotocol/\@ entry in a request's -- params @_meta@ object. metaLookup :: Text -> Maybe Value -> Maybe Value -metaLookup key params = do +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 ("io.modelcontextprotocol/" <> key)) m + 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. @@ -149,14 +155,20 @@ -- 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 -> IO (Maybe JsonRpcMessage) -handleMcpMessage serverInfo hints notifSupport handlers ctx0 (JsonRpcMessageRequest req) = do +handleMcpMessage serverInfo hints notifSupport emit handlers ctx0 (JsonRpcMessageRequest req) = do let params = requestParams req declaredVersion = metaProtocolVersion params case declaredVersion of @@ -172,6 +184,8 @@ { 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 @@ -206,7 +220,7 @@ else response return $ Just $ JsonRpcMessageResponse response' -handleMcpMessage _ _ _ _ _ (JsonRpcMessageNotification notif) = do +handleMcpMessage _ _ _ _ _ _ (JsonRpcMessageNotification notif) = do case notificationMethod notif of "notifications/initialized" -> hPutStrLn stderr "Received initialized notification - server is ready for operation" @@ -214,8 +228,41 @@ 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 :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse 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,17 +6,23 @@ HttpConfig(..) , transportRunHttp , defaultHttpConfig + , mcpApplication -- * Request validation (exposed for testing) , BodyPeek(..) , peekBody , peekIsModern + , wantsStreamingResponse , validateRequestHeaders , decodeSentinel ) where +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 @@ -102,8 +108,35 @@ 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 +-- +-- 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) $ @@ -113,7 +146,17 @@ 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 +-- | 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 @@ -213,6 +256,12 @@ | 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 @@ -233,14 +282,43 @@ [("Content-Type", "text/plain"), ("Allow", "POST, OPTIONS")] "Method Not Allowed" --- | The parts of a JSON-RPC body that header validation needs. +-- | 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 } +-- | 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" + ] + +-- | 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 = @@ -262,8 +340,16 @@ , 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 + _ -> 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 @@ -351,13 +437,7 @@ let subId = requestId req notifFilter = parseNotificationFilter (requestParams req) logVerbose config $ "Opening subscription stream " ++ show subId - respond $ Wai.responseStream - status200 - [ ("Content-Type", "text/event-stream") - , ("Cache-Control", "no-cache") - , ("X-Accel-Buffering", "no") - ] - $ \write flush -> do + respond $ Wai.responseStream status200 sseHeaders $ \write flush -> do chan <- atomically $ subscribeEvents src let sendJson v = do write $ B.lazyByteString $ "data: " <> encode v <> "\n\n" @@ -377,6 +457,53 @@ 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 -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived handleJsonRpcRequest config serverInfo handlers ctx modern body respond = do @@ -411,11 +538,10 @@ Right message -> do logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message) - let notifSupport = NotificationSupport - { supportsLegacyPush = False -- no legacy HTTP delivery channel - , supportsListen = httpHasNotifications config - } - maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config) notifSupport 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 diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -10,9 +10,12 @@ ) where import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar, +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 @@ -61,23 +64,39 @@ 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 hSetEncoding stderr utf8 hSetEncoding stdout utf8 - -- Subscription threads and the main loop share stdout: one line at a time. + -- 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 - sendRaw bytes = withMVar writeLock $ \_ -> do + -- 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 @@ -136,6 +155,28 @@ 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 @@ -147,15 +188,33 @@ , maybe True (`elem` modernVersions) (metaProtocolVersion (requestParams req)) -> openSubscription src req - -- notifications/cancelled referencing an open subscription tears it - -- down (no response, per the cancellation rules) + -- 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 $ - logLine $ "Ignoring cancellation for unknown request " <> T.pack (show 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: @@ -167,18 +226,14 @@ | notificationMethod n == "notifications/initialized" -> writeIORef legacyReady True _ -> pure () - response <- handleMcpMessage serverInfo (stdioCacheHints config) notifSupport 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)) + dispatchMessage message loop = do eof <- hIsEOF stdin if eof then do + inflight <- readMVar inflightVar + mapM_ (cancel . snd) inflight closeAllSubscriptions logLine "stdin closed - shutting down" else do 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,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} module MCP.Server.Types @@ -8,11 +9,21 @@ , ContentAudioData(..) , ResourceContent(..) + -- * Metadata Types + , Annotations(..) + , defaultAnnotations + , ToolAnnotations(..) + , defaultToolAnnotations + , Icon(..) + , icon + , LogLevel(..) + -- * Handler Result Types , ToolResult(..) , toolResult , toolError , ToToolResult(..) + , ToolOutput(..) , PromptResult(..) , ToPromptResult(..) , PromptMessage(..) @@ -33,9 +44,13 @@ -- * Definition Types , PromptDefinition(..) + , mkPromptDefinition , ResourceDefinition(..) + , mkResourceDefinition , ResourceTemplateDefinition(..) + , mkResourceTemplateDefinition , ToolDefinition(..) + , mkToolDefinition , ArgumentDefinition(..) -- * Completion Types @@ -86,6 +101,7 @@ 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 @@ -102,6 +118,9 @@ -- ^ 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 @@ -127,24 +146,62 @@ 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 - "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 + 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 -- ^ base64-encoded image data , contentImageMimeType :: Text @@ -204,6 +261,99 @@ 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 @@ -273,6 +423,25 @@ 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 @@ -396,14 +565,28 @@ , 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 @@ -412,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 @@ -421,7 +617,8 @@ ] ++ 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 @@ -430,6 +627,7 @@ <*> o .:? "description" <*> o .:? "mimeType" <*> o .:? "title" + <*> o .:? "icons" .!= [] -- | Resource template definition: a parameterized resource identified by an -- RFC 6570 URI template. @@ -439,8 +637,21 @@ , 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 @@ -448,7 +659,8 @@ ] ++ maybe [] (\d -> ["description" .= d]) (resourceTemplateDescription def) ++ maybe [] (\m -> ["mimeType" .= m]) (resourceTemplateMimeType def) ++ - maybe [] (\t -> ["title" .= t]) (resourceTemplateTitle 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 @@ -478,8 +690,23 @@ , 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 @@ -487,6 +714,8 @@ , "inputSchema" .= toolDefinitionInputSchema 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 @@ -590,7 +819,18 @@ , clientCapabilities :: Maybe Value -- ^ The client's declared capabilities from request @_meta@ -- (modern clients). - } deriving (Show, Eq) + , 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. @@ -601,6 +841,8 @@ , clientProtocolVersion = Nothing , clientInfo = Nothing , clientCapabilities = Nothing + , reportProgress = \_ _ _ -> pure () + , logToClient = \_ _ -> pure () } -- | Cacheability hints stamped onto modern (2026-07-28+) list/read results, diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -7,9 +7,13 @@ 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 @@ -23,9 +27,13 @@ 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 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 --- a/test/Spec/GoldenWire.hs +++ b/test/Spec/GoldenWire.hs @@ -1,32 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} --- | Golden wire-format fixtures: a canned request set is run through --- 'handleMcpMessage' and each response is compared against a checked-in --- fixture under @test/golden/@. +-- | 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 legacy fixtures were generated from @main@ at v0.2.0 (commit --- @7bd1bcc@), so they anchor the promise that dual-era support leaves --- legacy responses unchanged. The modern fixtures pin the 2026-07-28 --- envelope introduced by this revision of the library. +-- 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 create a fixture for a new case, run the suite with @GOLDEN_ACCEPT=1@: --- missing fixture files are 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. +-- 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) @@ -41,7 +50,8 @@ } -- Deterministic manual handlers (no Template Haskell): one prompt, one --- resource, one happy tool, one failing tool. +-- 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) @@ -50,8 +60,8 @@ } where promptList _ = pure - [ PromptDefinition "greet" "Greet someone" - [ArgumentDefinition "name" "Who to greet" True] Nothing + [ mkPromptDefinition "greet" "Greet someone" + [ArgumentDefinition "name" "Who to greet" True] ] promptGet _ name args = case name of "greet" -> pure $ Right $ PromptResult (Just "A greeting") @@ -59,16 +69,19 @@ _ -> pure $ Left $ InvalidPromptName name resourceList _ = pure - [ ResourceDefinition "resource://info" "info" (Just "Some info") (Just "text/plain") Nothing ] + [ (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 - [ ToolDefinition "echo" "Echo the text" + [ mkToolDefinition "echo" "Echo the text" (Schema Nothing (SchemaObject [("text", Schema (Just "The text") (SchemaString Nothing))] ["text"])) - Nothing Nothing ] toolCall _ name args = case name of "echo" -> case Map.lookup "text" args of @@ -77,96 +90,148 @@ "boom" -> pure $ Right $ toolError "kaboom" _ -> pure $ Left $ UnknownTool name --- | 'goldenHandlers' extended with the handler slots introduced after --- v0.2.0. Used only for the fixtures of methods that postdate the legacy --- anchor: extending the main handler set would change the advertised --- capabilities and perturb the v0.2.0-anchored initialize fixture. +-- 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 - [ ResourceTemplateDefinition "resource://item/{itemId}" "item" - (Just "An item") (Just "text/plain") Nothing + [ (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 + ) } --- | (fixture path, raw request). The raw requests are written out verbatim --- so the fixtures capture the full request->response wire behavior. -cases :: [(FilePath, BSL.ByteString)] -cases = - -- Legacy era: no _meta; served under the initialize-negotiated revision. - [ ("legacy/initialize", "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"initialize\",\"params\":{\"protocolVersion\":\"2025-06-18\",\"capabilities\":{},\"clientInfo\":{\"name\":\"golden-client\",\"version\":\"1.0\"}}}") - , ("legacy/ping", "{\"jsonrpc\":\"2.0\",\"id\":2,\"method\":\"ping\"}") - , ("legacy/tools-list", "{\"jsonrpc\":\"2.0\",\"id\":3,\"method\":\"tools/list\"}") - , ("legacy/tools-call-echo", "{\"jsonrpc\":\"2.0\",\"id\":4,\"method\":\"tools/call\",\"params\":{\"name\":\"echo\",\"arguments\":{\"text\":\"hi\"}}}") - , ("legacy/tools-call-unknown", "{\"jsonrpc\":\"2.0\",\"id\":5,\"method\":\"tools/call\",\"params\":{\"name\":\"nope\",\"arguments\":{}}}") - , ("legacy/tools-call-boom", "{\"jsonrpc\":\"2.0\",\"id\":6,\"method\":\"tools/call\",\"params\":{\"name\":\"boom\",\"arguments\":{}}}") - , ("legacy/prompts-list", "{\"jsonrpc\":\"2.0\",\"id\":7,\"method\":\"prompts/list\"}") - , ("legacy/prompts-get", "{\"jsonrpc\":\"2.0\",\"id\":8,\"method\":\"prompts/get\",\"params\":{\"name\":\"greet\",\"arguments\":{\"name\":\"World\"}}}") - , ("legacy/resources-list", "{\"jsonrpc\":\"2.0\",\"id\":9,\"method\":\"resources/list\"}") - , ("legacy/resources-read", "{\"jsonrpc\":\"2.0\",\"id\":10,\"method\":\"resources/read\",\"params\":{\"uri\":\"resource://info\"}}") +-- | One manifest entry: which case, and which reference-server variant +-- answers it. +data GoldenCase = GoldenCase + { caseName :: FilePath + , caseHandlers :: Text -- ^ "base" or "extended" + , caseNotifications :: Bool + } - -- Modern era: _meta declares 2026-07-28; responses carry the modern - -- envelope (resultType, serverInfo _meta, cacheability on list/read). - , ("modern/server-discover", "{\"jsonrpc\":\"2.0\",\"id\":21,\"method\":\"server/discover\",\"params\":{" <> meta <> "}}") - , ("modern/tools-list", "{\"jsonrpc\":\"2.0\",\"id\":22,\"method\":\"tools/list\",\"params\":{" <> meta <> "}}") - , ("modern/tools-call-echo", "{\"jsonrpc\":\"2.0\",\"id\":23,\"method\":\"tools/call\",\"params\":{\"name\":\"echo\",\"arguments\":{\"text\":\"hi\"}," <> meta <> "}}") - , ("modern/prompts-get", "{\"jsonrpc\":\"2.0\",\"id\":24,\"method\":\"prompts/get\",\"params\":{\"name\":\"greet\",\"arguments\":{\"name\":\"World\"}," <> meta <> "}}") - , ("modern/resources-read", "{\"jsonrpc\":\"2.0\",\"id\":25,\"method\":\"resources/read\",\"params\":{\"uri\":\"resource://info\"," <> meta <> "}}") - , ("modern/unsupported-version", "{\"jsonrpc\":\"2.0\",\"id\":26,\"method\":\"tools/list\",\"params\":{\"_meta\":{\"io.modelcontextprotocol/protocolVersion\":\"2099-01-01\"}}}") - , ("modern/initialize", "{\"jsonrpc\":\"2.0\",\"id\":27,\"method\":\"initialize\",\"params\":{\"protocolVersion\":\"2026-07-28\",\"capabilities\":{},\"clientInfo\":{\"name\":\"golden-client\",\"version\":\"1.0\"}," <> meta <> "}}") - , ("modern/ping", "{\"jsonrpc\":\"2.0\",\"id\":28,\"method\":\"ping\",\"params\":{" <> meta <> "}}") - ] +instance FromJSON GoldenCase where + parseJSON = withObject "GoldenCase" $ \o -> GoldenCase + <$> o .: "name" + <*> o .: "handlers" + <*> o .: "notifications" --- Methods introduced after v0.2.0: their fixtures originate on the branch --- that added the method (there is no earlier behavior to anchor to). -extendedCases :: [(FilePath, BSL.ByteString)] -extendedCases = - [ ("legacy/resources-templates-list", "{\"jsonrpc\":\"2.0\",\"id\":11,\"method\":\"resources/templates/list\"}") - , ("legacy/completion-complete", "{\"jsonrpc\":\"2.0\",\"id\":12,\"method\":\"completion/complete\",\"params\":{\"ref\":{\"type\":\"ref/prompt\",\"name\":\"greet\"},\"argument\":{\"name\":\"name\",\"value\":\"al\"}}}") - , ("modern/resources-templates-list", "{\"jsonrpc\":\"2.0\",\"id\":29,\"method\":\"resources/templates/list\",\"params\":{" <> meta <> "}}") - , ("modern/completion-complete", "{\"jsonrpc\":\"2.0\",\"id\":30,\"method\":\"completion/complete\",\"params\":{\"ref\":{\"type\":\"ref/prompt\",\"name\":\"greet\"},\"argument\":{\"name\":\"name\",\"value\":\"al\"}," <> meta <> "}}") - ] +newtype Manifest = Manifest [GoldenCase] -meta :: BSL.ByteString -meta = "\"_meta\":{\"io.modelcontextprotocol/protocolVersion\":\"2026-07-28\",\"io.modelcontextprotocol/clientInfo\":{\"name\":\"golden-client\",\"version\":\"1.0\"},\"io.modelcontextprotocol/clientCapabilities\":{}}" +instance FromJSON Manifest where + parseJSON = withObject "Manifest" $ \o -> Manifest <$> o .: "cases" --- Capability fixtures for a transport that delivers notifications (stdio --- with a configured source: legacy push + modern listen) -notifyingCases :: [(FilePath, BSL.ByteString)] -notifyingCases = - [ ("legacy/initialize-notifying", "{\"jsonrpc\":\"2.0\",\"id\":13,\"method\":\"initialize\",\"params\":{\"protocolVersion\":\"2025-06-18\",\"capabilities\":{},\"clientInfo\":{\"name\":\"golden-client\",\"version\":\"1.0\"}}}") - , ("modern/server-discover-notifying", "{\"jsonrpc\":\"2.0\",\"id\":31,\"method\":\"server/discover\",\"params\":{" <> meta <> "}}") - ] +-- | 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 :: NotificationSupport -> McpServerHandlers -> BSL.ByteString -> IO Value -runCase support handlers raw = do +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) - maybeResponse <- handleMcpMessage goldenServerInfo defaultCacheHints support handlers anonymousContext message + 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 :: NotificationSupport -> McpServerHandlers -> (FilePath, BSL.ByteString) -> Spec -goldenCase support handlers (name, raw) = - it name $ do - actual <- runCase support handlers raw - let path = "test/golden/" ++ name ++ ".json" - exists <- doesFileExist path +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 path (encode actual) + then BSL.writeFile responsePath (encode actual) else do - fixtureBytes <- BSL.readFile path + 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 - forM_ cases (goldenCase noNotificationSupport goldenHandlers) - forM_ extendedCases (goldenCase noNotificationSupport extendedHandlers) - forM_ notifyingCases - (goldenCase (NotificationSupport { supportsLegacyPush = True, supportsListen = True }) goldenHandlers) + cases <- runIO loadManifest + forM_ cases goldenCase diff --git a/test/Spec/ModernEra.hs b/test/Spec/ModernEra.hs --- a/test/Spec/ModernEra.hs +++ b/test/Spec/ModernEra.hs @@ -14,7 +14,8 @@ import MCP.Server.Handlers (handleMcpMessage) import MCP.Server.JsonRpc import MCP.Server.Transport.Http (BodyPeek (..), decodeSentinel, peekBody, - peekIsModern, validateRequestHeaders) + peekIsModern, validateRequestHeaders, + wantsStreamingResponse) import qualified Network.Wai as Wai import Test.Hspec @@ -37,7 +38,7 @@ } run :: JsonRpcMessage -> IO (Maybe JsonRpcMessage) -run = handleMcpMessage testServerInfo defaultCacheHints noNotificationSupport testHandlers anonymousContext +run = handleMcpMessage testServerInfo defaultCacheHints noNotificationSupport (\_ -> pure ()) testHandlers anonymousContext request :: Text -> Maybe Value -> JsonRpcMessage request method params = JsonRpcMessageRequest $ JsonRpcRequest @@ -217,6 +218,25 @@ 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" $ 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/Subscriptions.hs b/test/Spec/Subscriptions.hs --- a/test/Spec/Subscriptions.hs +++ b/test/Spec/Subscriptions.hs @@ -121,6 +121,7 @@ (McpServerInfo "T" "1" "") defaultCacheHints support + (\_ -> pure ()) toolsServer anonymousContext (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) diff --git a/test/Spec/TemplatesCompletions.hs b/test/Spec/TemplatesCompletions.hs --- a/test/Spec/TemplatesCompletions.hs +++ b/test/Spec/TemplatesCompletions.hs @@ -53,6 +53,7 @@ (McpServerInfo "T" "1" "") defaultCacheHints noNotificationSupport + (\_ -> pure ()) handlers anonymousContext (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params)) diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -171,12 +171,9 @@ 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 @@ -186,12 +183,9 @@ _ -> 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 } ] @@ -201,15 +195,10 @@ else return $ Left $ ResourceNotFound $ T.pack $ show uri let toolListHandler = return [ - ToolDefinition - { toolDefinitionName = "calculate" - , toolDefinitionDescription = "Calculate with Unicode symbols: √∑∏" - , toolDefinitionInputSchema = schema $ SchemaObject + mkToolDefinition "calculate" "Calculate with Unicode symbols: √∑∏" + (schema $ SchemaObject [("expression", describedSchema "Mathematical expression" (SchemaString Nothing))] - ["expression"] - , toolDefinitionOutputSchema = Nothing - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } + ["expression"]) ] let toolCallHandler name args = case name of diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -6,7 +6,8 @@ import qualified Data.Text as T import MCP.Server (ClientContext, anonymousContext, Content (..), MessageRole (..), PromptMessage (..), PromptResult (..), - ResourceContent (..), ToolResult, toolError, + ResourceContent (..), ToolOutput (..), + ToolResult, toolError, toolResult) import Network.URI (URI) @@ -178,6 +179,47 @@ 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 } 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.json b/test/golden/legacy/completion-complete.json deleted file mode 100644 --- a/test/golden/legacy/completion-complete.json +++ /dev/null @@ -1,1 +0,0 @@ -{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}} 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.json b/test/golden/legacy/initialize-notifying.json deleted file mode 100644 --- a/test/golden/legacy/initialize-notifying.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/legacy/initialize.json deleted file mode 100644 --- a/test/golden/legacy/initialize.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/legacy/ping.json deleted file mode 100644 --- a/test/golden/legacy/ping.json +++ /dev/null @@ -1,1 +0,0 @@ -{"id":2,"jsonrpc":"2.0","result":{}} 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.json b/test/golden/legacy/prompts-get.json deleted file mode 100644 --- a/test/golden/legacy/prompts-get.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/legacy/prompts-list.json deleted file mode 100644 --- a/test/golden/legacy/prompts-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/legacy/resources-list.json deleted file mode 100644 --- a/test/golden/legacy/resources-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/legacy/resources-read.json deleted file mode 100644 --- a/test/golden/legacy/resources-read.json +++ /dev/null @@ -1,1 +0,0 @@ -{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden 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.json b/test/golden/legacy/resources-templates-list.json deleted file mode 100644 --- a/test/golden/legacy/resources-templates-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/legacy/tools-call-boom.json deleted file mode 100644 --- a/test/golden/legacy/tools-call-boom.json +++ /dev/null @@ -1,1 +0,0 @@ -{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}} 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.json b/test/golden/legacy/tools-call-echo.json deleted file mode 100644 --- a/test/golden/legacy/tools-call-echo.json +++ /dev/null @@ -1,1 +0,0 @@ -{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}} 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.json b/test/golden/legacy/tools-call-unknown.json deleted file mode 100644 --- a/test/golden/legacy/tools-call-unknown.json +++ /dev/null @@ -1,1 +0,0 @@ -{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"} 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.json b/test/golden/legacy/tools-list.json deleted file mode 100644 --- a/test/golden/legacy/tools-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/completion-complete.json deleted file mode 100644 --- a/test/golden/modern/completion-complete.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/initialize.json deleted file mode 100644 --- a/test/golden/modern/initialize.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/ping.json deleted file mode 100644 --- a/test/golden/modern/ping.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/prompts-get.json deleted file mode 100644 --- a/test/golden/modern/prompts-get.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/resources-read.json deleted file mode 100644 --- a/test/golden/modern/resources-read.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/modern/resources-templates-list.json deleted file mode 100644 --- a/test/golden/modern/resources-templates-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/server-discover-notifying.json deleted file mode 100644 --- a/test/golden/modern/server-discover-notifying.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/modern/server-discover.json deleted file mode 100644 --- a/test/golden/modern/server-discover.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/tools-call-echo.json deleted file mode 100644 --- a/test/golden/modern/tools-call-echo.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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-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.json b/test/golden/modern/tools-list.json deleted file mode 100644 --- a/test/golden/modern/tools-list.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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/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.json b/test/golden/modern/unsupported-version.json deleted file mode 100644 --- a/test/golden/modern/unsupported-version.json +++ /dev/null @@ -1,1 +0,0 @@ -{"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"} 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"}