packages feed

mcp-server 0.2.0.0 → 0.2.0.1

raw patch · 106 files changed

+2085/−263 lines, 106 filesdep +asyncPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

API changes (from Hackage documentation)

- MCP.Server.Types: instance GHC.Classes.Eq MCP.Server.Types.ClientContext
- MCP.Server.Types: instance GHC.Internal.Show.Show MCP.Server.Types.ClientContext
+ MCP.Server: mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> Application
+ MCP.Server.Derive: DefinitionOptions :: Maybe Text -> Maybe Text -> [Icon] -> Maybe ToolAnnotations -> [(Text, Text)] -> DefinitionOptions
+ MCP.Server.Derive: [optDescription] :: DefinitionOptions -> Maybe Text
+ MCP.Server.Derive: [optFieldDescriptions] :: DefinitionOptions -> [(Text, Text)]
+ MCP.Server.Derive: [optIcons] :: DefinitionOptions -> [Icon]
+ MCP.Server.Derive: [optTitle] :: DefinitionOptions -> Maybe Text
+ MCP.Server.Derive: [optToolAnnotations] :: DefinitionOptions -> Maybe ToolAnnotations
+ MCP.Server.Derive: data DefinitionOptions
+ MCP.Server.Derive: defaultDefinitionOptions :: DefinitionOptions
+ MCP.Server.Derive: derivePromptHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp
+ MCP.Server.Derive: deriveResourceHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp
+ MCP.Server.Derive: deriveResourceTemplatesWithOptions :: Name -> [(String, DefinitionOptions)] -> Q Exp
+ MCP.Server.Derive: deriveToolHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp
+ MCP.Server.Derive: deriveToolHandlerWithOutput :: Name -> Name -> Name -> Q Exp
+ MCP.Server.Derive: deriveToolHandlerWithOutputDescription :: Name -> Name -> Name -> [(String, String)] -> Q Exp
+ MCP.Server.Derive: deriveToolHandlerWithOutputOptions :: Name -> Name -> Name -> [(String, DefinitionOptions)] -> Q Exp
+ MCP.Server.Derive: instance GHC.Classes.Eq MCP.Server.Derive.DefinitionOptions
+ MCP.Server.Derive: instance GHC.Internal.Show.Show MCP.Server.Derive.DefinitionOptions
+ MCP.Server.Derive: instance Language.Haskell.TH.Syntax.Lift MCP.Server.Derive.DefinitionOptions
+ MCP.Server.Transport.Http: [peekHasId] :: BodyPeek -> Bool
+ MCP.Server.Transport.Http: [peekWantsStream] :: BodyPeek -> Bool
+ MCP.Server.Transport.Http: mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> Application
+ MCP.Server.Transport.Http: wantsStreamingResponse :: BodyPeek -> Bool
+ MCP.Server.Types: Annotations :: [MessageRole] -> Maybe Double -> Maybe Text -> Annotations
+ MCP.Server.Types: ContentAnnotated :: Annotations -> Content -> Content
+ MCP.Server.Types: Icon :: Text -> Maybe Text -> [Text] -> Icon
+ MCP.Server.Types: LogAlert :: LogLevel
+ MCP.Server.Types: LogCritical :: LogLevel
+ MCP.Server.Types: LogDebug :: LogLevel
+ MCP.Server.Types: LogEmergency :: LogLevel
+ MCP.Server.Types: LogError :: LogLevel
+ MCP.Server.Types: LogInfo :: LogLevel
+ MCP.Server.Types: LogNotice :: LogLevel
+ MCP.Server.Types: LogWarning :: LogLevel
+ MCP.Server.Types: ToolAnnotations :: Maybe Text -> Maybe Bool -> Maybe Bool -> Maybe Bool -> Maybe Bool -> ToolAnnotations
+ MCP.Server.Types: ToolOutput :: o -> ToolOutput o
+ MCP.Server.Types: ToolOutputError :: Text -> ToolOutput o
+ MCP.Server.Types: ToolOutputRaw :: ToolResult -> ToolOutput o
+ MCP.Server.Types: ToolOutputWith :: [Content] -> o -> ToolOutput o
+ MCP.Server.Types: [annotationsAudience] :: Annotations -> [MessageRole]
+ MCP.Server.Types: [annotationsLastModified] :: Annotations -> Maybe Text
+ MCP.Server.Types: [annotationsPriority] :: Annotations -> Maybe Double
+ MCP.Server.Types: [iconMimeType] :: Icon -> Maybe Text
+ MCP.Server.Types: [iconSizes] :: Icon -> [Text]
+ MCP.Server.Types: [iconSrc] :: Icon -> Text
+ MCP.Server.Types: [logToClient] :: ClientContext -> LogLevel -> Value -> IO ()
+ MCP.Server.Types: [promptDefinitionIcons] :: PromptDefinition -> [Icon]
+ MCP.Server.Types: [reportProgress] :: ClientContext -> Double -> Maybe Double -> Maybe Text -> IO ()
+ MCP.Server.Types: [resourceDefinitionIcons] :: ResourceDefinition -> [Icon]
+ MCP.Server.Types: [resourceTemplateIcons] :: ResourceTemplateDefinition -> [Icon]
+ MCP.Server.Types: [toolAnnotationsTitle] :: ToolAnnotations -> Maybe Text
+ MCP.Server.Types: [toolDefinitionAnnotations] :: ToolDefinition -> Maybe ToolAnnotations
+ MCP.Server.Types: [toolDefinitionIcons] :: ToolDefinition -> [Icon]
+ MCP.Server.Types: [toolDestructiveHint] :: ToolAnnotations -> Maybe Bool
+ MCP.Server.Types: [toolIdempotentHint] :: ToolAnnotations -> Maybe Bool
+ MCP.Server.Types: [toolOpenWorldHint] :: ToolAnnotations -> Maybe Bool
+ MCP.Server.Types: [toolReadOnlyHint] :: ToolAnnotations -> Maybe Bool
+ MCP.Server.Types: data Annotations
+ MCP.Server.Types: data Icon
+ MCP.Server.Types: data LogLevel
+ MCP.Server.Types: data ToolAnnotations
+ MCP.Server.Types: data ToolOutput o
+ MCP.Server.Types: defaultAnnotations :: Annotations
+ MCP.Server.Types: defaultToolAnnotations :: ToolAnnotations
+ MCP.Server.Types: icon :: Text -> Icon
+ MCP.Server.Types: instance Data.Aeson.Types.FromJSON.FromJSON MCP.Server.Types.Annotations
+ MCP.Server.Types: instance Data.Aeson.Types.FromJSON.FromJSON MCP.Server.Types.Icon
+ MCP.Server.Types: instance Data.Aeson.Types.FromJSON.FromJSON MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance Data.Aeson.Types.FromJSON.FromJSON MCP.Server.Types.MessageRole
+ MCP.Server.Types: instance Data.Aeson.Types.ToJSON.ToJSON MCP.Server.Types.Annotations
+ MCP.Server.Types: instance Data.Aeson.Types.ToJSON.ToJSON MCP.Server.Types.Icon
+ MCP.Server.Types: instance Data.Aeson.Types.ToJSON.ToJSON MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance Data.Aeson.Types.ToJSON.ToJSON MCP.Server.Types.ToolAnnotations
+ MCP.Server.Types: instance GHC.Classes.Eq MCP.Server.Types.Annotations
+ MCP.Server.Types: instance GHC.Classes.Eq MCP.Server.Types.Icon
+ MCP.Server.Types: instance GHC.Classes.Eq MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Classes.Eq MCP.Server.Types.ToolAnnotations
+ MCP.Server.Types: instance GHC.Classes.Eq o => GHC.Classes.Eq (MCP.Server.Types.ToolOutput o)
+ MCP.Server.Types: instance GHC.Classes.Ord MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Internal.Enum.Bounded MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Internal.Enum.Enum MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Internal.Generics.Generic MCP.Server.Types.Annotations
+ MCP.Server.Types: instance GHC.Internal.Generics.Generic MCP.Server.Types.Icon
+ MCP.Server.Types: instance GHC.Internal.Generics.Generic MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Internal.Generics.Generic MCP.Server.Types.ToolAnnotations
+ MCP.Server.Types: instance GHC.Internal.Show.Show MCP.Server.Types.Annotations
+ MCP.Server.Types: instance GHC.Internal.Show.Show MCP.Server.Types.Icon
+ MCP.Server.Types: instance GHC.Internal.Show.Show MCP.Server.Types.LogLevel
+ MCP.Server.Types: instance GHC.Internal.Show.Show MCP.Server.Types.ToolAnnotations
+ MCP.Server.Types: instance GHC.Internal.Show.Show o => GHC.Internal.Show.Show (MCP.Server.Types.ToolOutput o)
+ MCP.Server.Types: instance Language.Haskell.TH.Syntax.Lift MCP.Server.Types.Icon
+ MCP.Server.Types: instance Language.Haskell.TH.Syntax.Lift MCP.Server.Types.ToolAnnotations
+ MCP.Server.Types: mkPromptDefinition :: Text -> Text -> [ArgumentDefinition] -> PromptDefinition
+ MCP.Server.Types: mkResourceDefinition :: Text -> Text -> ResourceDefinition
+ MCP.Server.Types: mkResourceTemplateDefinition :: Text -> Text -> ResourceTemplateDefinition
+ MCP.Server.Types: mkToolDefinition :: Text -> Text -> Schema -> ToolDefinition
- MCP.Server.Handlers: handleMcpMessage :: McpServerInfo -> CacheHints -> NotificationSupport -> McpServerHandlers -> ClientContext -> JsonRpcMessage -> IO (Maybe JsonRpcMessage)
+ MCP.Server.Handlers: handleMcpMessage :: McpServerInfo -> CacheHints -> NotificationSupport -> (JsonRpcNotification -> IO ()) -> McpServerHandlers -> ClientContext -> JsonRpcMessage -> IO (Maybe JsonRpcMessage)
- MCP.Server.Transport.Http: BodyPeek :: Maybe Text -> Maybe Text -> Maybe Text -> RequestId -> BodyPeek
+ MCP.Server.Transport.Http: BodyPeek :: Maybe Text -> Maybe Text -> Maybe Text -> RequestId -> Bool -> Bool -> BodyPeek
- MCP.Server.Types: ClientContext :: Maybe Text -> Maybe Value -> Maybe Text -> Maybe Value -> Maybe Value -> ClientContext
+ MCP.Server.Types: ClientContext :: Maybe Text -> Maybe Value -> Maybe Text -> Maybe Value -> Maybe Value -> (Double -> Maybe Double -> Maybe Text -> IO ()) -> (LogLevel -> Value -> IO ()) -> ClientContext
- MCP.Server.Types: PromptDefinition :: Text -> Text -> [ArgumentDefinition] -> Maybe Text -> PromptDefinition
+ MCP.Server.Types: PromptDefinition :: Text -> Text -> [ArgumentDefinition] -> Maybe Text -> [Icon] -> PromptDefinition
- MCP.Server.Types: ResourceDefinition :: Text -> Text -> Maybe Text -> Maybe Text -> Maybe Text -> ResourceDefinition
+ MCP.Server.Types: ResourceDefinition :: Text -> Text -> Maybe Text -> Maybe Text -> Maybe Text -> [Icon] -> ResourceDefinition
- MCP.Server.Types: ResourceTemplateDefinition :: Text -> Text -> Maybe Text -> Maybe Text -> Maybe Text -> ResourceTemplateDefinition
+ MCP.Server.Types: ResourceTemplateDefinition :: Text -> Text -> Maybe Text -> Maybe Text -> Maybe Text -> [Icon] -> ResourceTemplateDefinition
- MCP.Server.Types: ToolDefinition :: Text -> Text -> Schema -> Maybe Schema -> Maybe Text -> ToolDefinition
+ MCP.Server.Types: ToolDefinition :: Text -> Text -> Schema -> Maybe Schema -> Maybe Text -> Maybe ToolAnnotations -> [Icon] -> ToolDefinition

Files

CHANGELOG.md view
@@ -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
README.md view
@@ -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/)
examples/Complete/Main.hs view
@@ -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"
mcp-server.cabal view
@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.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,
src/MCP/Server.hs view
@@ -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
src/MCP/Server/Derive.hs view
@@ -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 <ConType>@ 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' \<output\>@, whose typed values the derivation+-- serializes into @structuredContent@ — guaranteed to match the schema.+--+-- > handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport)+-- > $(deriveToolHandlerWithOutput ''MyTool 'handleTool ''WeatherReport)+deriveToolHandlerWithOutput :: Name -> Name -> Name -> Q Exp+deriveToolHandlerWithOutput typeName handlerName outputName =+  deriveToolHandlerWithOutputDescription typeName handlerName outputName []++-- | 'deriveToolHandlerWithOutput' with custom descriptions. The+-- description list is shared with the output type: entries matching output+-- field names describe the @outputSchema@ properties.+deriveToolHandlerWithOutputDescription :: Name -> Name -> Name -> [(String, String)] -> Q Exp+deriveToolHandlerWithOutputDescription typeName handlerName outputName descriptions =+  deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions (Just outputName)++-- | 'deriveToolHandlerWithOutput' with per-constructor+-- '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))       } |]
src/MCP/Server/Derive/Internal.hs view
@@ -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)]
src/MCP/Server/Handlers.hs view
@@ -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/\<key\>@ 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
src/MCP/Server/Transport/Http.hs view
@@ -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
src/MCP/Server/Transport/Stdio.hs view
@@ -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
src/MCP/Server/Types.hs view
@@ -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,
test/HspecMain.hs view
@@ -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
+ test/Spec/Cancellation.hs view
@@ -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
+ test/Spec/DefinitionMetadata.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Coverage for definition metadata (ADR 0006): tool annotations, icons,+-- content annotations, and the options-based derive customization.+module Spec.DefinitionMetadata (spec) where++import Data.Aeson+import Data.Text (Text)+import MCP.Server+import MCP.Server.Derive+import Test.Hspec+import TestTypes++annotatedToolHandlers :: (ToolListHandler, ToolCallHandler)+annotatedToolHandlers = $(deriveToolHandlerWithOptions ''TestTool 'handleTestTool+  [ ("Echo", defaultDefinitionOptions+      { optDescription = Just "Echoes the input"+      , optTitle = Just "Echo"+      , optIcons = [icon "https://example.com/echo.png"]+      , optToolAnnotations = Just defaultToolAnnotations+          { toolReadOnlyHint = Just True+          , toolIdempotentHint = Just True+          }+      , optFieldDescriptions = [("text", "What to echo")]+      })+  , ("Calculate", defaultDefinitionOptions+      { optFieldDescriptions = [("x", "Calculate's first operand")]+      })+  ])++toolNamed :: Text -> [ToolDefinition] -> ToolDefinition+toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of+  (d:_) -> d+  []    -> error $ "tool not found: " ++ show n++propDescription :: Text -> ToolDefinition -> Maybe Text+propDescription name def = case schemaShape (toolDefinitionInputSchema def) of+  SchemaObject props _ -> lookup name props >>= schemaDescription+  _                    -> Nothing++spec :: Spec+spec = describe "Definition metadata" $ do++  describe "JSON shapes" $ do+    it "serializes tool annotations with only the set hints" $ do+      toJSON defaultToolAnnotations { toolReadOnlyHint = Just True } `shouldBe`+        object ["readOnlyHint" .= True]++    it "serializes icons, omitting empty optional fields" $ do+      toJSON (icon "https://example.com/i.png") `shouldBe`+        object ["src" .= ("https://example.com/i.png" :: Text)]+      toJSON (Icon "u" (Just "image/png") ["48x48"]) `shouldBe`+        object ["src" .= ("u" :: Text), "mimeType" .= ("image/png" :: Text), "sizes" .= (["48x48"] :: [Text])]++    it "merges content annotations into the inner block" $ do+      let anns = defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.8 }+      toJSON (ContentAnnotated anns (ContentText "hi")) `shouldBe`+        object [ "type" .= ("text" :: Text), "text" .= ("hi" :: Text)+               , "annotations" .= object ["audience" .= (["user"] :: [Text]), "priority" .= (0.8 :: Double)]+               ]++    it "round-trips annotated content through FromJSON" $ do+      let anns = defaultAnnotations { annotationsAudience = [RoleAssistant] }+          c = ContentAnnotated anns (ContentText "hello")+      decode (encode c) `shouldBe` Just c++    it "round-trips resource links carrying icons" $ do+      let def = (mkResourceDefinition "resource://x" "x")+            { resourceDefinitionIcons = [Icon "https://example.com/x.png" (Just "image/png") ["48x48"]] }+          c = ContentResourceLink def+      decode (encode c) `shouldBe` Just c++  describe "Options-based derivation" $ do+    it "carries description, title, icons and annotations on the definition" $ do+      defs <- fst annotatedToolHandlers anonCtx+      let echoDef = toolNamed "echo" defs+      toolDefinitionDescription echoDef `shouldBe` "Echoes the input"+      toolDefinitionTitle echoDef `shouldBe` Just "Echo"+      toolDefinitionIcons echoDef `shouldBe` [icon "https://example.com/echo.png"]+      toolDefinitionAnnotations echoDef `shouldBe` Just defaultToolAnnotations+        { toolReadOnlyHint = Just True+        , toolIdempotentHint = Just True+        }++    it "leaves uncustomized constructors bare (constructor-name description)" $ do+      defs <- fst annotatedToolHandlers anonCtx+      let toggleDef = toolNamed "toggle" defs+      toolDefinitionDescription toggleDef `shouldBe` "Toggle"+      toolDefinitionAnnotations toggleDef `shouldBe` Nothing+      toolDefinitionIcons toggleDef `shouldBe` []++    it "scopes field descriptions to their constructor" $ do+      defs <- fst annotatedToolHandlers anonCtx+      -- 'text' described only on Echo; 'x' described only on Calculate+      propDescription "text" (toolNamed "echo" defs) `shouldBe` Just "What to echo"+      propDescription "x" (toolNamed "calculate" defs) `shouldBe` Just "Calculate's first operand"+      -- Echo's options must not leak onto Calculate's same-named args+      propDescription "operation" (toolNamed "calculate" defs) `shouldBe` Just "operation"++    it "still dispatches calls unchanged" $ do+      result <- snd annotatedToolHandlers anonCtx "echo" mempty+      case result of+        Left (MissingRequiredParams msg) -> show msg `shouldContain` "text"+        other -> expectationFailure $ "expected missing-params error, got: " ++ show other
+ test/Spec/DerivedOutput.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Coverage for derived structured output (ADR 0005): the outputSchema+-- generated from a result record, and the ToolOutput result forms.+module Spec.DerivedOutput (spec) where++import Data.Aeson+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import MCP.Server+import MCP.Server.Derive+import Test.Hspec+import TestHelpers+import TestTypes++weatherHandlers :: (ToolListHandler, ToolCallHandler)+weatherHandlers = $(deriveToolHandlerWithOutputDescription ''WeatherTool 'handleWeatherTool ''WeatherReport+  [ ("GetWeather", "Current weather"), ("wrTemperature", "Degrees Celsius") ])++callWeather :: Text -> [(Text, Value)] -> IO (Either Error 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
test/Spec/GoldenWire.hs view
@@ -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 (@\<name\>.request.json@) and the reference server's+-- exact response (@\<name\>.response.json@), enumerated by+-- @test/golden/manifest.json@. This spec replays every request through+-- 'handleMcpMessage' and compares the response against the fixture. ----- The 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
test/Spec/ModernEra.hs view
@@ -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" $
+ test/Spec/Progress.hs view
@@ -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` []
test/Spec/Subscriptions.hs view
@@ -121,6 +121,7 @@           (McpServerInfo "T" "1" "")           defaultCacheHints           support+          (\_ -> pure ())           toolsServer           anonymousContext           (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params))
test/Spec/TemplatesCompletions.hs view
@@ -53,6 +53,7 @@     (McpServerInfo "T" "1" "")     defaultCacheHints     noNotificationSupport+    (\_ -> pure ())     handlers     anonymousContext     (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params))
test/Spec/UnicodeHandling.hs view
@@ -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
test/TestTypes.hs view
@@ -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 }
+ test/golden/README.md view
@@ -0,0 +1,69 @@+# MCP wire-format conformance corpus++Each case in this directory is a pair of files:++- `<name>.request.json` — a single JSON-RPC request, exactly as it would+  arrive on the wire (one line).+- `<name>.response.json` — the reference server's exact response.++`manifest.json` enumerates the cases and states, per case, which+reference-server variant answers it (`handlers`) and whether the serving+transport can deliver change notifications (`notifications`). Responses are+compared as **parsed JSON** (structural equality), not raw bytes, so object+key order never matters — with one deliberate exception: JSON embedded+*inside a string* (the structured-output text block) is compared as part of+the string, so those bytes are canonical: compact, object keys sorted.++The corpus is deliberately **API-agnostic**: nothing in it refers to this+library's types or Haskell at all. Any MCP server implementation that+reproduces the reference server below can replay the requests and diff the+responses — the cases then pin protocol behavior (error codes, era+envelopes, capability advertisement) rather than any particular API.++## Eras++- `legacy/` — requests carry no modern `_meta`; they are answered under the+  revision negotiated by `initialize` (2024-11-05 … 2025-11-25 share this+  wire format for the operations covered here). These fixtures were+  generated from mcp-server v0.2.0 and are the anchor for "newer protocol+  work leaves legacy responses unchanged" — **never regenerate them** from a+  branch that intends to preserve legacy output.+- `modern/` — requests declare a revision (2026-07-28) in params `_meta`;+  responses carry the modern envelope: `resultType`, server identity in+  result `_meta`, and `ttlMs`/`cacheScope` on the cacheable methods.++## The reference server++Identity: name `Golden Server`, version `1.0.0`, instructions+`Golden fixture server`. Cache hints: `ttlMs` 0, scope `private`.++The `base` handler set:++| Feature | Definition | Behavior |+|---|---|---|+| Tool `echo` | input schema: object, required `text` (string, described "The text") | returns one text content block `echo: <text>` |+| Tool `boom` | not listed | any call returns `isError: true` with text `kaboom` |+| Prompt `greet` | one required argument `name` ("Who to greet") | description `A greeting`, one user message `Hello, <name>!` |+| Resource `resource://info` | name `info`, description `Some info`, `text/plain` | text contents `The golden info` |++The `extended` handler set adds (used only for methods that postdate the+v0.2.0 anchor, so the anchored capability fixtures stay untouched):++| Feature | Definition | Behavior |+|---|---|---|+| Resource template `resource://item/{itemId}` | name `item`, description `An item`, `text/plain` | — |+| Completions | any ref/argument | values = `["alpha", "beta"]` filtered by prefix of the partial value |+| Tool `echo_structured` | input schema: object, required `input` (string, "The text"); output schema: object, required `echoedText` (string, "The echoed text") and `echoedLength` (integer, "Its length"); description `Echo with structured output` | returns `structuredContent` `{"echoedText": <input>, "echoedLength": <length>}` plus one text content block containing the same JSON |+| Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: <probe>` annotated with audience `["user"]`, priority `0.5` |++Cases with `"notifications": true` are answered as if the transport can+deliver change notifications (stdio with a configured notifier: legacy push+and modern `subscriptions/listen`), which flips the advertised+`listChanged`/`subscribe` capability flags.++## Adding a case++Write the `.request.json` by hand, add a manifest entry, and run the test+suite with `GOLDEN_ACCEPT=1`: the missing `.response.json` is written from+the current implementation's output. Existing response fixtures are never+overwritten — delete one first to regenerate it deliberately.
− test/golden/legacy/completion-complete.json 
@@ -1,1 +0,0 @@-{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}}
+ test/golden/legacy/completion-complete.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":12,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"}}}
+ test/golden/legacy/completion-complete.response.json view
@@ -0,0 +1,1 @@+{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}}
− test/golden/legacy/initialize-notifying.json 
@@ -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"}}}
+ test/golden/legacy/initialize-notifying.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":13,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}}
+ test/golden/legacy/initialize-notifying.response.json view
@@ -0,0 +1,1 @@+{"id":13,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true},"tools":{"listChanged":true}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}}
− test/golden/legacy/initialize.json 
@@ -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"}}}
+ test/golden/legacy/initialize.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"}}}
+ test/golden/legacy/initialize.response.json view
@@ -0,0 +1,1 @@+{"id":1,"jsonrpc":"2.0","result":{"capabilities":{"prompts":{},"resources":{},"tools":{}},"protocolVersion":"2025-06-18","serverInfo":{"instructions":"Golden fixture server","name":"Golden Server","version":"1.0.0"}}}
− test/golden/legacy/ping.json 
@@ -1,1 +0,0 @@-{"id":2,"jsonrpc":"2.0","result":{}}
+ test/golden/legacy/ping.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":2,"method":"ping"}
+ test/golden/legacy/ping.response.json view
@@ -0,0 +1,1 @@+{"id":2,"jsonrpc":"2.0","result":{}}
− test/golden/legacy/prompts-get.json 
@@ -1,1 +0,0 @@-{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}}
+ test/golden/legacy/prompts-get.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":8,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"}}}
+ test/golden/legacy/prompts-get.response.json view
@@ -0,0 +1,1 @@+{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}}
− test/golden/legacy/prompts-list.json 
@@ -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"}]}}
+ test/golden/legacy/prompts-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":7,"method":"prompts/list"}
+ test/golden/legacy/prompts-list.response.json view
@@ -0,0 +1,1 @@+{"id":7,"jsonrpc":"2.0","result":{"prompts":[{"arguments":[{"description":"Who to greet","name":"name","required":true}],"description":"Greet someone","name":"greet"}]}}
− test/golden/legacy/resources-list.json 
@@ -1,1 +0,0 @@-{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}}
+ test/golden/legacy/resources-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":9,"method":"resources/list"}
+ test/golden/legacy/resources-list.response.json view
@@ -0,0 +1,1 @@+{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}}
− test/golden/legacy/resources-read.json 
@@ -1,1 +0,0 @@-{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}}
+ test/golden/legacy/resources-read.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":10,"method":"resources/read","params":{"uri":"resource://info"}}
+ test/golden/legacy/resources-read.response.json view
@@ -0,0 +1,1 @@+{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}}
− test/golden/legacy/resources-templates-list.json 
@@ -1,1 +0,0 @@-{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}}
+ test/golden/legacy/resources-templates-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":11,"method":"resources/templates/list"}
+ test/golden/legacy/resources-templates-list.response.json view
@@ -0,0 +1,1 @@+{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}}
+ test/golden/legacy/tools-call-annotated.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":16,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"}}}
+ test/golden/legacy/tools-call-annotated.response.json view
@@ -0,0 +1,1 @@+{"id":16,"jsonrpc":"2.0","result":{"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}]}}
− test/golden/legacy/tools-call-boom.json 
@@ -1,1 +0,0 @@-{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}}
+ test/golden/legacy/tools-call-boom.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":6,"method":"tools/call","params":{"name":"boom","arguments":{}}}
+ test/golden/legacy/tools-call-boom.response.json view
@@ -0,0 +1,1 @@+{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}}
− test/golden/legacy/tools-call-echo.json 
@@ -1,1 +0,0 @@-{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}}
+ test/golden/legacy/tools-call-echo.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"}}}
+ test/golden/legacy/tools-call-echo.response.json view
@@ -0,0 +1,1 @@+{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}}
+ test/golden/legacy/tools-call-structured.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":15,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"}}}
+ test/golden/legacy/tools-call-structured.response.json view
@@ -0,0 +1,1 @@+{"id":15,"jsonrpc":"2.0","result":{"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"structuredContent":{"echoedLength":6,"echoedText":"golden"}}}
− test/golden/legacy/tools-call-unknown.json 
@@ -1,1 +0,0 @@-{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"}
+ test/golden/legacy/tools-call-unknown.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"nope","arguments":{}}}
+ test/golden/legacy/tools-call-unknown.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"}
+ test/golden/legacy/tools-list-extended.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":14,"method":"tools/list"}
+ test/golden/legacy/tools-list-extended.response.json view
@@ -0,0 +1,1 @@+{"id":14,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"},{"description":"Echo with structured output","inputSchema":{"properties":{"input":{"description":"The text","type":"string"}},"required":["input"],"type":"object"},"name":"echo_structured","outputSchema":{"properties":{"echoedLength":{"description":"Its length","type":"integer"},"echoedText":{"description":"The echoed text","type":"string"}},"required":["echoedText","echoedLength"],"type":"object"}},{"annotations":{"idempotentHint":true,"readOnlyHint":true},"description":"A read-only probe","icons":[{"src":"https://example.com/probe.png"}],"inputSchema":{"properties":{"probe":{"description":"What to probe","type":"string"}},"required":["probe"],"type":"object"},"name":"annotated_probe","title":"Probe"}]}}
− test/golden/legacy/tools-list.json 
@@ -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"}]}}
+ test/golden/legacy/tools-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":3,"method":"tools/list"}
+ test/golden/legacy/tools-list.response.json view
@@ -0,0 +1,1 @@+{"id":3,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}]}}
+ test/golden/manifest.json view
@@ -0,0 +1,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+    }+  ]+}
− test/golden/modern/completion-complete.json 
@@ -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"}}
+ test/golden/modern/completion-complete.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":30,"method":"completion/complete","params":{"ref":{"type":"ref/prompt","name":"greet"},"argument":{"name":"name","value":"al"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/completion-complete.response.json view
@@ -0,0 +1,1 @@+{"id":30,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"completion":{"values":["alpha"]},"resultType":"complete"}}
− test/golden/modern/initialize.json 
@@ -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"}
+ test/golden/modern/initialize.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":27,"method":"initialize","params":{"protocolVersion":"2026-07-28","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/initialize.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32601,"message":"Method not found: initialize (not part of protocol revision 2026-07-28)"},"id":27,"jsonrpc":"2.0"}
− test/golden/modern/ping.json 
@@ -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"}
+ test/golden/modern/ping.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":28,"method":"ping","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/ping.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32601,"message":"Method not found: ping (not part of protocol revision 2026-07-28)"},"id":28,"jsonrpc":"2.0"}
− test/golden/modern/prompts-get.json 
@@ -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"}}
+ test/golden/modern/prompts-get.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":24,"method":"prompts/get","params":{"name":"greet","arguments":{"name":"World"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/prompts-get.response.json view
@@ -0,0 +1,1 @@+{"id":24,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}],"resultType":"complete"}}
− test/golden/modern/resources-read.json 
@@ -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}}
+ test/golden/modern/resources-read.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":25,"method":"resources/read","params":{"uri":"resource://info","_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/resources-read.response.json view
@@ -0,0 +1,1 @@+{"id":25,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}],"resultType":"complete","ttlMs":0}}
− test/golden/modern/resources-templates-list.json 
@@ -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}}
+ test/golden/modern/resources-templates-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":29,"method":"resources/templates/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/resources-templates-list.response.json view
@@ -0,0 +1,1 @@+{"id":29,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}],"resultType":"complete","ttlMs":0}}
− test/golden/modern/server-discover-notifying.json 
@@ -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}}
+ test/golden/modern/server-discover-notifying.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":31,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/server-discover-notifying.response.json view
@@ -0,0 +1,1 @@+{"id":31,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{"listChanged":true},"resources":{"listChanged":true,"subscribe":true},"tools":{"listChanged":true}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}}
− test/golden/modern/server-discover.json 
@@ -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}}
+ test/golden/modern/server-discover.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":21,"method":"server/discover","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/server-discover.response.json view
@@ -0,0 +1,1 @@+{"id":21,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","capabilities":{"prompts":{},"resources":{},"tools":{}},"instructions":"Golden fixture server","resultType":"complete","supportedVersions":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"],"ttlMs":0}}
+ test/golden/modern/tools-call-annotated.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":33,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/tools-call-annotated.response.json view
@@ -0,0 +1,1 @@+{"id":33,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}],"resultType":"complete"}}
− test/golden/modern/tools-call-echo.json 
@@ -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"}}
+ test/golden/modern/tools-call-echo.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":23,"method":"tools/call","params":{"name":"echo","arguments":{"text":"hi"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/tools-call-echo.response.json view
@@ -0,0 +1,1 @@+{"id":23,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"echo: hi","type":"text"}],"resultType":"complete"}}
+ test/golden/modern/tools-call-structured.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":32,"method":"tools/call","params":{"name":"echo_structured","arguments":{"input":"golden"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/tools-call-structured.response.json view
@@ -0,0 +1,1 @@+{"id":32,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"text":"{\"echoedLength\":6,\"echoedText\":\"golden\"}","type":"text"}],"resultType":"complete","structuredContent":{"echoedLength":6,"echoedText":"golden"}}}
− test/golden/modern/tools-list.json 
@@ -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}}
+ test/golden/modern/tools-list.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}
+ test/golden/modern/tools-list.response.json view
@@ -0,0 +1,1 @@+{"id":22,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"cacheScope":"private","resultType":"complete","tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"}],"ttlMs":0}}
− test/golden/modern/unsupported-version.json 
@@ -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"}
+ test/golden/modern/unsupported-version.request.json view
@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2099-01-01"}}}
+ test/golden/modern/unsupported-version.response.json view
@@ -0,0 +1,1 @@+{"error":{"code":-32022,"data":{"requested":"2099-01-01","supported":["2026-07-28","2025-11-25","2025-06-18","2025-03-26","2024-11-05"]},"message":"Unsupported protocol version"},"id":26,"jsonrpc":"2.0"}