mcp-server 0.1.0.21 → 0.2.0.0

raw patch · 56 files changed

+3494/−670 lines, 56 filesdep +base64-bytestringdep +directorydep +scientificdep ~containersdep ~waiPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, directory, scientific, stm

Dependency ranges changed: containers, wai

API changes (from Hackage documentation)

Files

• CHANGELOG.md +133/−2
• README.md +126/−15
• examples/Complete/Main.hs +35/−8
• examples/Complete/Types.hs +20/−2
• examples/HttpSimple/Main.hs +2/−4
• examples/Simple/Main.hs +2/−4
• mcp-server.cabal +20/−2
• src/MCP/Server.hs +23/−26
• src/MCP/Server/Derive.hs +368/−212
• src/MCP/Server/Derive/Internal.hs +176/−4
• src/MCP/Server/Handlers.hs +274/−60
• src/MCP/Server/JsonRpc.hs +14/−7
• src/MCP/Server/Notifications.hs +188/−0
• src/MCP/Server/Protocol.hs +86/−26
• src/MCP/Server/Transport/Http.hs +318/−108
• src/MCP/Server/Transport/Stdio.hs +195/−32
• src/MCP/Server/Types.hs +384/−65
• test/HspecMain.hs +10/−0
• test/Spec/AdvancedDerivation.hs +13/−18
• test/Spec/BasicDerivation.hs +13/−26
• test/Spec/GoldenWire.hs +172/−0
• test/Spec/JSONConversion.hs +1/−1
• test/Spec/ModernEra.hs +225/−0
• test/Spec/ProtocolVersionNegotiation.hs +4/−6
• test/Spec/SchemaValidation.hs +11/−13
• test/Spec/Subscriptions.hs +157/−0
• test/Spec/TemplatesCompletions.hs +177/−0
• test/Spec/ToolCallParsing.hs +20/−9
• test/Spec/TypedArgs.hs +135/−0
• test/Spec/UnicodeHandling.hs +21/−18
• test/TestHelpers.hs +89/−0
• test/TestTypes.hs +58/−2
• test/golden/legacy/completion-complete.json +1/−0
• test/golden/legacy/initialize-notifying.json +1/−0
• test/golden/legacy/initialize.json +1/−0
• test/golden/legacy/ping.json +1/−0
• test/golden/legacy/prompts-get.json +1/−0
• test/golden/legacy/prompts-list.json +1/−0
• test/golden/legacy/resources-list.json +1/−0
• test/golden/legacy/resources-read.json +1/−0
• test/golden/legacy/resources-templates-list.json +1/−0
• test/golden/legacy/tools-call-boom.json +1/−0
• test/golden/legacy/tools-call-echo.json +1/−0
• test/golden/legacy/tools-call-unknown.json +1/−0
• test/golden/legacy/tools-list.json +1/−0
• test/golden/modern/completion-complete.json +1/−0
• test/golden/modern/initialize.json +1/−0
• test/golden/modern/ping.json +1/−0
• test/golden/modern/prompts-get.json +1/−0
• test/golden/modern/resources-read.json +1/−0
• test/golden/modern/resources-templates-list.json +1/−0
• test/golden/modern/server-discover-notifying.json +1/−0
• test/golden/modern/server-discover.json +1/−0
• test/golden/modern/tools-call-echo.json +1/−0
• test/golden/modern/tools-list.json +1/−0
• test/golden/modern/unsupported-version.json +1/−0

@@ -1,7 +1,138 @@ # Revision history for mcp-server -## 0.1.0.21 - ???+## 0.2.0.0 - 2026-07-31 +A major overhaul of the handler API. The headline changes: the handler+boundary is no longer stringly typed, and the server is dual-era — it speaks+both the legacy initialize-handshake revisions and the stateless+`2026-07-28` revision.++### Dual-era protocol support (2026-07-28)++* Requests that declare a protocol revision in their params `_meta`+  (`io.modelcontextprotocol/protocolVersion`) are served statelessly with+  the modern result envelope: `resultType: "complete"`, the server identity+  in result `_meta`, and — on `tools/list`, `prompts/list`,+  `resources/list`, `resources/read` and `server/discover` — the required+  `ttlMs`/`cacheScope` fields (configurable via `CacheHints` on the+  transport configs; default: no caching, private). Requests without modern+  `_meta` are served byte-identically to before under the revision+  negotiated by `initialize`.+* New `server/discover` method (mandatory in 2026-07-28, and the+  backwards-compatibility probe): supported revisions of both eras,+  handler-gated capabilities, server identity and instructions.+* Declaring an unsupported revision returns+  `UnsupportedProtocolVersionError` (`-32022`) listing the supported set.+* A legacy client proposing `2026-07-28` via `initialize` negotiates down+  to `2025-11-25`: an initializing client is legacy by definition.+* Handlers can read the declared revision, client info and client+  capabilities from the `ClientContext`+  (`clientProtocolVersion`/`clientInfo`/`clientCapabilities`); the new+  `anonymousContext` builds an empty context.+* HTTP: modern requests get the 2026-07-28 request-metadata validation —+  the `MCP-Protocol-Version` header must match the body's declared+  revision, `Mcp-Method` must match the body method, and `Mcp-Name` must+  match `params.name`/`params.uri` for `tools/call`/`resources/read`/+  `prompts/get` (with `=?base64?…?=` sentinel decoding); violations return+  `400` with `HeaderMismatch` (`-32020`). Unknown methods return HTTP 404+  and unsupported revisions HTTP 400, so era-probing clients can+  distinguish them. Legacy requests keep the relaxed pre-2026 rules.++### Change notifications and subscriptions/listen++* New `MCP.Server.Notifications`: create an `McpNotifier` with+  `newMcpNotifier`, hand its `NotificationSource` to a transport+  (`stdioNotifications`/`httpNotifications`), and call+  `notifyToolsListChanged`/`notifyPromptsListChanged`/+  `notifyResourcesListChanged`/`notifyResourceUpdated` when things change.+* `subscriptions/listen` (2026-07-28) is served on both transports: the+  mandatory acknowledgment comes first with the honored filter, every+  message is tagged with the subscription id, only opted-into types are+  delivered, and streams end gracefully (closure responses at stdio EOF;+  closing the SSE stream cancels over HTTP, `notifications/cancelled` over+  stdio). HTTP streams send periodic keep-alive comments and+  `X-Accel-Buffering: no`.+* Legacy stdio clients receive spontaneous untagged notifications after+  `initialize`. Capabilities are era- and transport-aware: `listChanged` is+  advertised only where delivery is possible (stdio legacy push, or+  modern `subscriptions/listen`), and `subscribe` only to modern clients.+* `defaultHttpConfig` is now re-exported from `MCP.Server`.++### Resource templates and completions++* Record constructors of a resource type now derive as resource /templates/+  (`UserProfile { userId :: Text }` →+  `resource://user_profile/{userId}`): the derived read handler matches+  template URIs, percent-decodes the path segments, and parses them into+  the constructor's (typed) fields. `deriveResourceTemplates` derives the+  `resources/templates/list` handler advertising them; the method carries+  the modern cacheability envelope.+* New `completions` handler slot serving `completion/complete` for prompt+  arguments and resource-template parameters (`CompletionRef`,+  `CompletionResult`, capped at 100 values per the spec). The+  `completions` capability is advertised automatically.+* `McpServerHandlers` gains `resourceTemplates` and `completions` fields;+  the new `noHandlers` value lets you construct handler sets by record+  update so future fields don't break your code.++### Typed tool arguments and results (BREAKING)++* Tool arguments arrive as full JSON values (`Map Text Value`). The Template+  Haskell derivation decodes records recursively and now supports **list+  fields**, **enumeration fields** (all-nullary data types, wired as string+  enums), and **nested record fields** in addition to the primitives.+  Primitive parsing is lenient: native JSON types or their string+  representations are both accepted (many clients send numbers/booleans as+  strings). Prompt arguments remain string-valued per the MCP specification.+* `inputSchema` is generated as a real JSON Schema (`Schema`/`SchemaType`+  ADT with `enum`, `items` and nested `object`s), replacing the flat+  `InputSchemaDefinition*` types that silently typed every non-primitive+  field as a string.+* Tool handlers produce a `ToolResult`: multiple content blocks,+  `structuredContent`, `_meta`, and `isError`. Tool *execution* failures+  should be reported via `isError` (see `toolError`) so the model can see+  them — per spec — instead of surfacing as JSON-RPC protocol errors.+  The `ToToolResult` class keeps simple handlers simple: returning+  `Content` or `Text` still works unchanged.+* Prompt handlers produce a `PromptResult` (optional description plus a+  multi-message conversation with user/assistant roles) via the analogous+  `ToPromptResult` class.+* `Content` gains `audio` and `resource_link` variants; embedded resources+  now carry their full contents as the spec requires.+* `ToolDefinition` gains `outputSchema`; `tools/call` responses carry+  `structuredContent`.+* Handler types are fixed to `IO` — the monad parameter was unusable+  through the public API (both transports required `IO`).++### Transport fixes++* stdio: a blank line on stdin no longer terminates the server, EOF shuts+  down cleanly instead of crashing, and malformed input is answered with+  proper JSON-RPC error responses (`-32700`/`-32600`, `id: null`).+* stdio: raw request bodies are no longer logged to stderr by default+  (tool arguments may carry sensitive data) — only message summaries.+  `runMcpServerStdioWithConfig` with `stdioVerbose = True` restores full+  body logging.+* JSON-RPC: messages are classified by shape (method/id presence) instead+  of parse-fallthrough, so a request with a malformed `id` is answered+  with an error rather than silently dropped as a notification. Request+  ids must be integral.+* HTTP: new `httpAllowedOrigins` policy on `HttpConfig` (Origin+  validation / DNS-rebinding protection, a spec MUST); accepted+  notifications return `202` with no body; malformed bodies get JSON-RPC+  error responses; the `Access-Control-Allow-Origin` header is set+  consistently on every response and echoes the validated origin (with+  `Vary: Origin`) when a policy is configured.+* HTTP (BREAKING): the non-spec GET "discovery" endpoint is removed — the+  MCP endpoint now answers GET with `405 Method Not Allowed`, matching the+  spec (no revision defines a GET discovery response, and `2026-07-28`+  requires 405 here).+* Integer tool arguments bound the scientific-notation exponent (1024, the+  same bound aeson uses) so a tiny payload like `1e1000000000` cannot force+  allocation of a gigabyte-sized `Integer`.++## 0.1.0.21 - 2026-07-31+ * **BREAKING**: every handler (prompt/resource/tool; list and get/read/call)   now receives a `ClientContext` as its first argument, so a server can behave   differently depending on who is calling. On stdio the context is anonymous;@@ -25,7 +156,7 @@ * `http-simple-example` is now built with `-threaded`, which Warp requires;   previously every request crashed with a `TimerManager` error. -## 0.1.0.20 - ???+## 0.1.0.20 - 2026-07-31  * Fix protocol version negotiation: echo back any compatible revision the client   proposes (`2024-11-05`, `2025-03-26`, `2025-06-18`, `2025-11-25`) instead of

@@ -4,7 +4,7 @@  ## Features -- **Complete MCP Implementation**: Negotiates MCP protocol revisions `2024-11-05` through `2025-11-25` (the shared wire format for tool/resource/prompt operations)+- **Complete MCP Implementation**: Dual-era server — legacy revisions `2024-11-05` through `2025-11-25` via the `initialize` handshake, and the stateless `2026-07-28` revision via per-request `_meta` (including `server/discover`, `resultType`, and cacheability fields) - **Type-Safe API**: Leverage Haskell's type system for robust MCP servers - **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces - **Template Haskell Support**: Automatic handler derivation from data types@@ -14,7 +14,9 @@  - ✅ **Prompts**: User-controlled prompt templates with arguments - ✅ **Resources**: Application-controlled readable resources+- ✅ **Resource Templates**: Parameterized resources via URI templates - ✅ **Tools**: Model-controlled callable functions+- ✅ **Completions**: Argument autocompletion for prompts and templates - ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation - ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses @@ -82,19 +84,51 @@ -- Becomes: "get_value", "set_value", "search_items" ``` -#### Automatic Type Conversion+#### Typed Tool Arguments -The derivation system automatically converts Text arguments to appropriate Haskell types:+Tool arguments are decoded from full JSON values, and the generated+`inputSchema` mirrors the field types:  ```haskell-data MyTool = Calculate { number :: Int, factor :: Double, enabled :: Bool }--- Text "42" -> Int 42--- Text "3.14" -> Double 3.14--- Text "true" -> Bool True+data Color = Red | Green | Blue          -- all-nullary type: string enum+data Filters = Filters                   -- record: nested JSON object+  { tags     :: [Text]                   -- list: JSON array+  , maxCount :: Maybe Int                -- Maybe: optional field+  }++data MyTool = Search+  { query   :: Text+  , color   :: Color                     -- "red" | "green" | "blue"+  , filters :: Filters                   -- { "tags": [...], "maxCount": ... }+  , limit   :: Maybe Int+  } ``` -Supported conversions: `Int`, `Integer`, `Double`, `Float`, `Bool`, and `Text` (no conversion).+Primitive fields (`Int`, `Integer`, `Double`, `Float`, `Bool`, `Text`) are+parsed leniently: the native JSON type and its string representation are+both accepted (`42` or `"42"`), since many clients send numbers and+booleans as strings. +Prompt arguments are string-valued per the MCP specification, so prompt+records are limited to primitive and enumeration fields.++#### Tool Results++Simple handlers can return plain `Content` (or `Text`). Return a full+`ToolResult` for multiple content blocks, structured content, or to report+execution failures with `isError` — which the spec prefers over protocol+errors, so the model can see what went wrong and react:++```haskell+handleTool :: ClientContext -> MyTool -> IO ToolResult+handleTool _ (Search q _ _ _)+  | T.null q  = pure $ toolError "query must not be empty"+  | otherwise = pure $ toolResult [ContentText ("Results for " <> q)]+```++Prompt handlers can likewise return a `PromptResult` with a description and+a multi-message conversation (user and assistant roles).+ #### Nested Parameter Types  You can nest parameter types with automatic unwrapping:@@ -122,6 +156,44 @@ -- Generates: "resource://menu", "resource://specials" ``` +#### Resource Templates++Record constructors become parameterized resource *templates* (RFC 6570 URI+templates), with one percent-decoded path segment per field:++```haskell+data MyResource+    = Menu                                            -- static: resource://menu+    | ProductDetail { sku :: Text }                   -- resource://product_detail/{sku}+    | OrderItem { orderId :: Int, itemName :: Text }  -- resource://order_item/{orderId}/{itemName}+```++The read handler derived by `deriveResourceHandler` matches template URIs+(e.g. `resource://product_detail/ABC123`) and decodes the segments into the+constructor's fields — typed fields like `Int` are parsed, and a failing+segment yields an invalid-params error. Advertise the templates via+`resources/templates/list` with:++```haskell+resourceTemplates = Just $(deriveResourceTemplates ''MyResource)+```++#### Argument Completion++Provide a `completions` handler to serve `completion/complete` for prompt+arguments and resource-template parameters:++```haskell+handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult)+handleComplete _ (CompletionRefPrompt "recipe") "idea" partial _ =+    pure $ Right $ completionResult $+        filter (T.isPrefixOf partial) ["pancakes", "pasta", "pizza"]+handleComplete _ _ _ _ _ = pure $ Right $ completionResult []+```++The `completions` capability is advertised automatically when the handler is+present.+ #### Unsupported Patterns  We do not support positional (unnamed) parameters:@@ -165,9 +237,10 @@ import MCP.Server  -- Manual handler implementation. Every handler receives the per-request--- 'ClientContext' as its first argument.+-- 'ClientContext' as its first argument. Prompt arguments are string-valued+-- (Map Text Text); tool arguments are full JSON values (Map Text Value). promptListHandler :: ClientContext -> IO [PromptDefinition]-promptGetHandler :: ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+promptGetHandler :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) -- ... implement your custom logic  main :: IO ()@@ -180,6 +253,35 @@       } ``` +## Change Notifications++Servers whose tool/prompt/resource lists change at runtime can push change+notifications. Create a notifier, hand its source to the transport, and call+the notifier when things change:++```haskell+main :: IO ()+main = do+    (notifier, source) <- newMcpNotifier+    _ <- forkIO $ appLogic notifier   -- calls notifyToolsListChanged etc.+    runMcpServerStdioWithConfig+        defaultStdioConfig { stdioNotifications = Just source }+        serverInfo handlers+```++Delivery is transport- and era-aware, and the `listChanged`/`subscribe`+capabilities are advertised automatically where delivery is actually+possible:++- **Modern clients (2026-07-28)** open a `subscriptions/listen` stream (a+  long-lived SSE response over HTTP) and receive only the notification types+  they opted into, tagged with their subscription id — including+  `notifications/resources/updated` for watched URIs.+- **Legacy stdio clients** receive spontaneous untagged notifications after+  `initialize`.+- **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!)  The library supports the MCP Streamable HTTP transport. Compile your@@ -194,12 +296,15 @@ -- Custom configuration main = runMcpServerHttpWithConfig customConfig serverInfo handlers   where-    customConfig = HttpConfig+    customConfig = defaultHttpConfig       { httpPort = 8080       , httpHost = "0.0.0.0"       , httpEndpoint = "/api/mcp"       , httpVerbose = True     -- Enable detailed logging-      , httpAuthorize = Nothing -- No authentication (see below)+      , httpAllowedOrigins = Just ["https://app.example.com"]+          -- Origin validation (DNS-rebinding protection): requests with an+          -- Origin header outside this list are rejected with 403. Nothing+          -- disables the check (only for servers unreachable from browsers).       } ``` @@ -221,10 +326,16 @@  **Features:** - CORS enabled for web clients-- GET `/mcp` for server discovery-- POST `/mcp` for JSON-RPC messages-- Protocol-version negotiation across supported revisions (`2024-11-05`–`2025-11-25`)+- POST `/mcp` for JSON-RPC messages (GET returns 405 — this library does not+  offer server-initiated SSE streams)+- 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) - Optional pluggable bearer-token authentication via `httpAuthorize`+- Origin validation via `httpAllowedOrigins`+- Cacheability hints for modern list/read results via `httpCacheHints`  ## Examples 

@@ -3,6 +3,9 @@  module Main where +import           Data.Map  (Map)+import           Data.Text (Text)+import qualified Data.Text as T import           MCP.Server import           MCP.Server.Derive import           System.IO (hSetEncoding, stderr, stdout, utf8)@@ -23,19 +26,40 @@     pure $ ResourceText uri "text/plain" "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf" handleResource _ uri HeadlineBannerAd =     pure $ ResourceText uri "text/plain" "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎"+handleResource _ uri (ProductDetail sku) =+    pure $ ResourceText uri "text/plain" $ "Details for product " <> sku <> ": in stock, $9.99" -handleTool :: ClientContext -> MyTool -> IO Content+-- Tool handlers return a full ToolResult: execution failures are reported+-- with isError so the model can see them (returning plain Content works too+-- for simple tools — see the other examples).+handleTool :: ClientContext -> MyTool -> IO ToolResult handleTool _ (SearchForProduct q category) =     case category of-        Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"-        Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"-handleTool _ (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items"-handleTool _ Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"+        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"]+handleTool _ (AddToCart sku quantities)+    | any (<= 0) quantities = pure $ toolError "Quantities must be positive"+    | otherwise = pure $ toolResult+        [ContentText $ "Added " <> T.pack (show (sum quantities)) <> " of item " <> sku <> " to your cart"]+handleTool _ (Checkout speed (Address street city zipCode)) =+    pure $ toolResult+        [ ContentText $ "Checkout completed! Order #12345 will ship "+            <> T.pack (show speed) <> " to " <> street <> ", " <> city+            <> maybe "" (" " <>) zipCode+        ] handleTool _ (ComplexTool field1 field2 field3 field4 field5) =-    pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <>+    pure $ toolResult+        [ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <>                         maybe "" (", " <>) field3 <> ", " <> field4 <>-                        maybe "" (", " <>) field5+                        maybe "" (", " <>) field5] +-- Argument autocompletion for the Recipe prompt's idea argument+handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult)+handleComplete _ (CompletionRefPrompt "recipe") "idea" partial _ =+    pure $ Right $ completionResult $+        filter (T.isPrefixOf (T.toLower partial)) ["pancakes", "pasta", "pizza"]+handleComplete _ _ _ _ _ = pure $ Right $ completionResult []+ main :: IO () main = do     -- Set UTF-8 encoding to handle Unicode characters properly@@ -44,6 +68,7 @@     -- Derive the handlers using Template Haskell     let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt)         resources = $(deriveResourceHandler ''MyResource 'handleResource)+        templates = $(deriveResourceTemplates ''MyResource)         tools = $(deriveToolHandler ''MyTool 'handleTool)      in runMcpServerStdio         McpServerInfo@@ -51,8 +76,10 @@             , serverVersion = "0.3.0"             , serverInstructions = "An example MCP server that handles prompts, resources, and tools."             }-        McpServerHandlers+        noHandlers             { prompts = Just prompts             , resources = Just resources+            , resourceTemplates = Just templates             , tools = Just tools+            , completions = Just handleComplete             }

@@ -15,11 +15,29 @@     = ProductCategories     | SaleItems     | HeadlineBannerAd+    -- A record constructor becomes a resource template:+    -- resource://product_detail/{productSku}+    | ProductDetail { productSku :: Text }     deriving (Show, Eq) +-- An enumeration argument: all-nullary data types become string enums in+-- the generated schema ("standard", "express", "overnight")+data ShippingSpeed+    = Standard+    | Express+    | Overnight+    deriving (Show, Eq)++-- A nested record argument: appears as a JSON object in the schema+data Address = Address+    { street :: Text+    , city   :: Text+    , zipCode :: Maybe Text+    } deriving (Show, Eq)+ data MyTool     = SearchForProduct { q :: Text, category :: Maybe Text }-    | AddToCart { sku :: Text }-    | Checkout+    | AddToCart { sku :: Text, quantities :: [Int] }+    | Checkout { speed :: ShippingSpeed, shipTo :: Address }     | ComplexTool { field1 :: Text, field2 :: Text, field3 :: Maybe Text, field4 :: Text, field5 :: Maybe Text }     deriving (Show, Eq)

@@ -36,8 +36,6 @@             , serverVersion = "1.0.0"             , serverInstructions = "A simple HTTP key-value store with GetValue and SetValue tools"             }-        McpServerHandlers-            { prompts = Nothing     -- No prompts in this example-            , resources = Nothing   -- No resources in this example-            , tools = Just tools    -- Only tools in this example+        noHandlers+            { tools = Just tools    -- Only tools in this example             }

@@ -36,8 +36,6 @@             , serverVersion = "1.0.0"             , serverInstructions = "A simple key-value store with GetValue and SetValue tools"             }-        McpServerHandlers-            { prompts = Nothing     -- No prompts in this example-            , resources = Nothing   -- No resources in this example-            , tools = Just tools    -- Only tools in this example+        noHandlers+            { tools = Just tools    -- Only tools in this example             }

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.21+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -49,9 +49,12 @@               || == 9.8.4               || == 9.10.3               || == 9.12.2+              || == 9.14.1  -- Extra source files to be distributed with the package, such as examples, or a tutorial module.--- extra-source-files: SPEC.md+extra-source-files:+  test/golden/legacy/*.json+  test/golden/modern/*.json -- Source repository information source-repository head   type: git@@ -69,6 +72,7 @@     MCP.Server.Derive     MCP.Server.Handlers     MCP.Server.JsonRpc+    MCP.Server.Notifications     MCP.Server.Protocol     MCP.Server.Transport.Http     MCP.Server.Transport.Stdio@@ -85,10 +89,13 @@   build-depends:     aeson >=2 && <3,     base >=4.18 && <4.23,+    base64-bytestring >=1.0 && <1.3,     bytestring >=0.10 && <0.13,     containers >=0.6 && <0.9,     http-types >=0.12 && <1,     network-uri >=2.6 && <2.8,+    scientific >=0.3 && <0.4,+    stm >=2.5 && <2.6,     template-haskell >=2.16 && <2.25,     text >=1.2 && <3,     wai >=3.2 && <4,@@ -131,6 +138,7 @@   -- Other library packages from which modules are imported.   build-depends:     base,+    containers,     mcp-server,     text, @@ -170,12 +178,18 @@   other-modules:     Spec.AdvancedDerivation     Spec.BasicDerivation+    Spec.GoldenWire     Spec.JSONConversion+    Spec.ModernEra     Spec.ProtocolVersionNegotiation     Spec.SchemaValidation+    Spec.Subscriptions+    Spec.TemplatesCompletions     Spec.ToolCallParsing+    Spec.TypedArgs     Spec.UnicodeHandling     TestData+    TestHelpers     TestTypes    -- LANGUAGE extensions used by modules in this package.@@ -192,7 +206,11 @@     aeson,     base,     bytestring,+    containers,+    directory,     hspec,     mcp-server,     network-uri,+    stm,     text,+    wai,

@@ -4,48 +4,45 @@ module MCP.Server   ( -- * Server Runtime     runMcpServerStdio+  , runMcpServerStdioWithConfig   , runMcpServerHttp   , runMcpServerHttpWithConfig      -- * Transport Configuration+  , StdioConfig(..)+  , defaultStdioConfig   , HttpConfig(..)+  , defaultHttpConfig -    -- * Utility Functions-  , jsonValueToText+    -- * Change Notifications+  , McpNotifier(..)+  , NotificationSource+  , newMcpNotifier      -- * Re-exports   , module MCP.Server.Types   ) where -import           Data.Aeson-import           Data.Text              (Text)-import qualified Data.Text              as T--import           MCP.Server.Transport.Stdio (transportRunStdio)+import           MCP.Server.Notifications (McpNotifier (..), NotificationSource,+                                           newMcpNotifier)+import           MCP.Server.Transport.Stdio (StdioConfig (..), defaultStdioConfig,+                                             transportRunStdio,+                                             transportRunStdioWithConfig) import           MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig) import           MCP.Server.Types --- | Convert JSON Value to Text representation suitable for handlers-jsonValueToText :: Value -> Text-jsonValueToText (String t) = t-jsonValueToText (Number n) =-    -- Check if it's a whole number, if so format as integer-    if fromInteger (round n) == n-        then T.pack $ show (round n :: Integer)-        else T.pack $ show n-jsonValueToText (Bool True) = "true"-jsonValueToText (Bool False) = "false"-jsonValueToText Null = ""-jsonValueToText v = T.pack $ show v- -- | Run an MCP server using STDIO transport-runMcpServerStdio :: McpServerInfo -> McpServerHandlers IO -> IO ()-runMcpServerStdio serverInfo handlers = transportRunStdio serverInfo handlers+runMcpServerStdio :: McpServerInfo -> McpServerHandlers -> IO ()+runMcpServerStdio = transportRunStdio +-- | Run an MCP server using STDIO transport with custom configuration+runMcpServerStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO ()+runMcpServerStdioWithConfig = transportRunStdioWithConfig+ -- | Run an MCP server using HTTP transport with default configuration-runMcpServerHttp :: McpServerInfo -> McpServerHandlers IO -> IO ()-runMcpServerHttp serverInfo handlers = transportRunHttp defaultHttpConfig serverInfo handlers+runMcpServerHttp :: McpServerInfo -> McpServerHandlers -> IO ()+runMcpServerHttp = transportRunHttp defaultHttpConfig  -- | Run an MCP server using HTTP transport with custom configuration-runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()-runMcpServerHttpWithConfig config serverInfo handlers = transportRunHttp config serverInfo handlers+runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO ()+runMcpServerHttpWithConfig = transportRunHttp

@@ -2,17 +2,28 @@ {-# LANGUAGE TemplateHaskell   #-}  -- | Template Haskell utilities for deriving MCP handlers from data types.+--+-- Tool arguments are decoded from full JSON values: records may contain+-- primitive fields ('Data.Text.Text', 'Int', 'Integer', 'Double', 'Float',+-- 'Bool'), optional fields ('Maybe'), lists, enumerations (data types whose+-- constructors are all nullary), and nested records — the generated+-- @inputSchema@ mirrors the same structure. Prompt arguments are+-- string-valued per the MCP specification, so prompt records are limited to+-- primitive and enumeration fields. module MCP.Server.Derive   ( -- * Template Haskell Derivation     derivePromptHandler   , derivePromptHandlerWithDescription   , deriveResourceHandler   , deriveResourceHandlerWithDescription+  , deriveResourceTemplates+  , deriveResourceTemplatesWithDescription   , deriveToolHandler   , deriveToolHandlerWithDescription   ) where -import qualified Data.Map            as Map+import           Data.Aeson          (Value (..))+import           Data.List           (intercalate) import           Data.Maybe          (fromMaybe) import qualified Data.Text           as T import           Language.Haskell.TH@@ -52,20 +63,23 @@ descriptionFor descriptions key fallback =   fromMaybe fallback (lookup key descriptions) --- Map a Haskell type to its JSON schema type string-jsonTypeFor :: Type -> String-jsonTypeFor (ConT n)-  | nameBase n == "Int"     = "integer"-  | nameBase n == "Integer" = "integer"-  | nameBase n == "Double"  = "number"-  | nameBase n == "Float"   = "number"-  | nameBase n == "Bool"    = "boolean"-jsonTypeFor _ = "string"- -- Helper function to convert Clause to Match clauseToMatch :: Clause -> Match clauseToMatch (Clause ps b ds) = Match (case ps of [p] -> p; _ -> TupP ps) b ds +-- The constructors of a named data (or newtype) declaration, if it is one+reifyCons :: Name -> Q (Maybe [Con])+reifyCons n = do+  info <- reify n+  pure $ case info of+    TyConI (DataD _ _ _ _ cs _)    -> Just cs+    TyConI (NewtypeD _ _ _ _ c _)  -> Just [c]+    _                              -> Nothing++isNullary :: Con -> Bool+isNullary (NormalC _ []) = True+isNullary _              = False+ -- Get fields from a constructor: [] for nullary, record fields for RecC, -- extracted fields for single-param NormalC getConFields :: Con -> Q [(Name, Bang, Type)]@@ -89,7 +103,203 @@ requiredFieldNames fields =   [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ] +-- Extract field information from a (possibly wrapped) parameter record type+extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)]+extractFieldsFromParamType paramType = do+  case paramType of+    ConT typeName -> do+      cons <- reifyCons typeName+      case cons of+        Just [RecC _ fields] -> return fields+        Just [NormalC _ [(_bang, innerType)]] -> extractFieldsFromParamType innerType+        _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"+    _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType++-- Names used to communicate between the generated lambda and its cases+ctxName, argNameN, argsName, uriName :: Name+ctxName  = mkName "ctx"+argNameN = mkName "name"+argsName = mkName "args"+uriName  = mkName "uri"+ -------------------------------------------------------------------------------+-- Value parsers (tool arguments)+-------------------------------------------------------------------------------++-- Build a parser expression of type @Value -> Either Text a@ for a field type+mkValueParser :: Type -> Q Exp+mkValueParser ty = case ty of+  ConT n | nameBase n == "Int"     -> [| valueInt |]+         | nameBase n == "Integer" -> [| valueInteger |]+         | nameBase n == "Double"  -> [| valueDouble |]+         | nameBase n == "Float"   -> [| valueFloat |]+         | nameBase n == "Bool"    -> [| valueBool |]+         | nameBase n == "Text"    -> [| valueText |]+  AppT ListT inner -> [| valueArray $(mkValueParser inner) |]+  ConT n -> do+    cons <- reifyCons n+    case cons of+      Just cs | not (null cs), all isNullary cs -> mkEnumValueParser n cs+      Just [RecC icon ifields] -> mkObjectParser n icon ifields+      Just [NormalC icon [(_bang, inner)]] -> [| fmap $(conE icon) . $(mkValueParser inner) |]+      _ -> fail $ "Unsupported tool argument type: " ++ show n+  _ -> fail $ "Unsupported tool argument type: " ++ show ty++-- Parser for an enumeration: a JSON string matching a snake_cased constructor+mkEnumValueParser :: Name -> [Con] -> Q Exp+mkEnumValueParser tyName cons = do+  textParser <- mkEnumTextParser tyName cons+  [| \v -> case v of+       String s -> $(return textParser) s+       _        -> Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) <> " from: " <> renderValue v) |]++-- Parser of type @Text -> Either Text a@ for an enumeration+mkEnumTextParser :: Name -> [Con] -> Q Exp+mkEnumTextParser tyName cons = do+  let expected = intercalate ", " [snakeName (conName c) | c <- cons]+  sVar <- newName "s"+  matches <- mapM (enumMatch . conName) cons+  fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName)+                       <> " from: " <> $(varE sVar)+                       <> " (expected one of: " <> $(litE $ stringL expected) <> ")") |]+  let defaultMatch = Match WildP (NormalB fallback) []+  return $ LamE [VarP sVar] $+    CaseE (AppE (VarE 'T.unpack) (VarE sVar)) (matches ++ [defaultMatch])+  where+    enumMatch cn = do+      body <- [| Right $(conE cn) |]+      return $ Match (LitP $ StringL $ snakeName cn) (NormalB body) []++-- Parser for a nested record: a JSON object decoded field by field+mkObjectParser :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp+mkObjectParser tyName icon ifields = do+  vVar <- newName "v"+  oVar <- newName "o"+  chain <- foldl (\acc f -> [| $acc <*> $(fieldExtractor oVar f) |])+                 [| pure $(conE icon) |]+                 ifields+  fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName)+                       <> " object from: " <> renderValue $(varE vVar)) |]+  objP <- conP 'Object [varP oVar]+  return $ LamE [VarP vVar] $+    CaseE (VarE vVar)+      [ Match objP (NormalB chain) []+      , Match WildP (NormalB fallback) []+      ]+  where+    fieldExtractor oVar (fieldName, _, fieldType) = do+      let (isOptional, innerType) = unwrapMaybe fieldType+      let fname = litE $ stringL $ nameBase fieldName+      if isOptional+        then [| optionalField $fname $(mkValueParser innerType) $(varE oVar) |]+        else [| requiredField $fname $(mkValueParser innerType) $(varE oVar) |]++-------------------------------------------------------------------------------+-- Text parsers (prompt arguments)+-------------------------------------------------------------------------------++-- Build a parser expression of type @Text -> Either Text a@ for a prompt field+mkTextParser :: Type -> Q Exp+mkTextParser ty = case ty of+  ConT n | nameBase n == "Int"     -> [| parseInt |]+         | nameBase n == "Integer" -> [| parseInteger |]+         | nameBase n == "Double"  -> [| parseDouble |]+         | nameBase n == "Float"   -> [| parseFloat |]+         | nameBase n == "Bool"    -> [| parseBool |]+         | nameBase n == "Text"    -> [| parseText |]+  ConT n -> do+    cons <- reifyCons n+    case cons of+      Just cs | not (null cs), all isNullary cs -> mkEnumTextParser n cs+      _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show n+  _ -> fail $ "Unsupported prompt argument type (prompt arguments are strings): " ++ show ty++-------------------------------------------------------------------------------+-- Argument decoding for a constructor+-------------------------------------------------------------------------------++data ArgStyle = ToolArgs | PromptArgs++-- Build a decoder expression of type @Either Error <ConType>@ reading from+-- the in-scope arguments map bound to 'argsName'.+mkConDecoder :: ArgStyle -> Con -> Q Exp+mkConDecoder _ (NormalC cn []) = [| Right $(conE cn) |]+mkConDecoder style (RecC cn fields) = mkFieldsDecoder style (conE cn) fields+mkConDecoder style (NormalC cn [(_bang, paramType)]) =+  wrapParam paramType+  where+    wrapParam ty = case ty of+      ConT typeName -> do+        cons <- reifyCons typeName+        case cons of+          Just [RecC icon ifields] -> do+            inner <- mkFieldsDecoder style (conE icon) ifields+            [| $(conE cn) <$> $(return inner) |]+          Just [NormalC icon [(_b, innerTy)]] -> do+            innerCon <- mkConDecoder style (NormalC icon [(_b, innerTy)])+            [| $(conE cn) <$> $(return innerCon) |]+          _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"+      _ -> fail $ "Parameter type must be a concrete type, got: " ++ show ty+mkConDecoder _ con = fail $ "Unsupported constructor type: " ++ show (conName con)++-- Applicative chain over the constructor's fields, reading from 'argsName'+mkFieldsDecoder :: ArgStyle -> Q Exp -> [(Name, Bang, Type)] -> Q Exp+mkFieldsDecoder style con fields =+  foldl (\acc f -> [| $acc <*> $(argExtractor f) |]) [| pure $con |] fields+  where+    argExtractor (fieldName, _, fieldType) = do+      let (isOptional, innerType) = unwrapMaybe fieldType+      let fname = litE $ stringL $ nameBase fieldName+      case style of+        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) |]++-------------------------------------------------------------------------------+-- Schema generation+-------------------------------------------------------------------------------++-- Build a 'SchemaType' expression for a field type+mkSchemaShape :: [(String, String)] -> Type -> Q Exp+mkSchemaShape descriptions ty = case ty of+  ConT n | nameBase n == "Int"     -> [| SchemaInteger |]+         | nameBase n == "Integer" -> [| SchemaInteger |]+         | nameBase n == "Double"  -> [| SchemaNumber |]+         | nameBase n == "Float"   -> [| SchemaNumber |]+         | nameBase n == "Bool"    -> [| SchemaBoolean |]+         | nameBase n == "Text"    -> [| SchemaString Nothing |]+  AppT ListT inner ->+    [| SchemaArray (Schema Nothing $(mkSchemaShape descriptions inner)) |]+  ConT n -> do+    cons <- reifyCons n+    case cons of+      Just cs | not (null cs), all isNullary cs -> do+        let vals = listE [litE $ stringL $ snakeName (conName c) | c <- cs]+        [| SchemaString (Just $vals) |]+      Just [RecC _ ifields] -> mkObjectShape descriptions ifields+      Just [NormalC _ [(_bang, inner)]] -> mkSchemaShape descriptions inner+      _ -> fail $ "Unsupported tool argument type: " ++ show n+  _ -> fail $ "Unsupported tool argument type: " ++ show ty++-- Build a 'SchemaType' object expression from record fields+mkObjectShape :: [(String, String)] -> [(Name, Bang, Type)] -> Q Exp+mkObjectShape descriptions fields = do+  props <- mapM prop fields+  let reqd = listE [litE $ stringL fn | fn <- requiredFieldNames fields]+  [| SchemaObject $(return $ ListE props) $reqd |]+  where+    prop (fieldName, _, fieldType) = do+      let fieldStr = nameBase fieldName+      let description = descriptionFor descriptions fieldStr fieldStr+      let (_, innerType) = unwrapMaybe fieldType+      [| ( $(litE $ stringL fieldStr)+         , Schema (Just $(litE $ stringL description)) $(mkSchemaShape descriptions innerType)+         ) |]++------------------------------------------------------------------------------- -- Prompt derivation ------------------------------------------------------------------------------- @@ -99,9 +309,9 @@ -- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp derivePromptHandlerWithDescription typeName handlerName descriptions = do-  info <- reify typeName-  case info of-    TyConI (DataD _ _ _ _ constructors _) -> do+  cons <- reifyCons typeName+  case cons of+    Just constructors -> do       -- Generate prompt definitions       promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors @@ -109,15 +319,15 @@       listHandlerExp <- [| \_ctx -> pure $(return $ ListE promptDefs) |]        -- Generate get handler with cases-      cases <- traverse (mkDispatchCase handlerName) constructors-      defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |]+      cases <- traverse (mkDispatchCase PromptArgs handlerName) constructors+      defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> $(varE argNameN) |]       let defaultMatch = Match WildP (NormalB defaultCase) []-      let getHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $-            CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))+      let getHandlerExp = LamE [VarP ctxName, VarP argNameN, VarP argsName] $+            CaseE (AppE (VarE 'T.unpack) (VarE argNameN))               (map clauseToMatch cases ++ [defaultMatch])        return $ TupE [Just listHandlerExp, Just getHandlerExp]-    _ -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type"+    Nothing -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type"  -- | Derive prompt handlers from a data type. -- Usage:@@ -132,11 +342,8 @@   let name = conName con   let sname = snakeName name   let description = descriptionFor descriptions (nameBase name) ("Handle " ++ nameBase name)-  args <- case con of-    NormalC _ []                   -> pure []-    RecC _ fields                  -> traverse (mkArgDef descriptions) fields-    NormalC _ [(_bang, paramType)] -> extractFieldsFromType descriptions paramType-    _                              -> fail "Unsupported constructor type"+  fields <- getConFields con+  args <- traverse (mkArgDef descriptions) fields   [| PromptDefinition       { promptDefinitionName = $(litE $ stringL sname)       , promptDefinitionDescription = $(litE $ stringL description)@@ -144,22 +351,6 @@       , promptDefinitionTitle = Nothing       } |] --- Extract field definitions from a parameter type recursively-extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp]-extractFieldsFromType descriptions paramType = do-  case paramType of-    ConT typeName -> do-      info <- reify typeName-      case info of-        TyConI (DataD _ _ _ _ [RecC _ fields] _) ->-          -- Parameter type is a record with fields-          traverse (mkArgDef descriptions) fields-        TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) ->-          -- Parameter type has a single parameter - recurse-          extractFieldsFromType descriptions innerType-        _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"-    _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType- mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp mkArgDef descriptions (fieldName, _, fieldType) = do   let isOptional = fst (unwrapMaybe fieldType)@@ -175,160 +366,61 @@ -- Dispatch case generation (shared by prompt and tool) ------------------------------------------------------------------------------- -mkDispatchCase :: Name -> Con -> Q Clause-mkDispatchCase handlerName con = do-  let name = conName con-  let sname = snakeName name-  body <- case con of-    NormalC _ [] ->-      [| do-          content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE name)-          pure $ Right content |]-    RecC _ fields ->-      mkRecordCase name handlerName fields-    NormalC _ [(_bang, paramType)] ->-      mkSeparateParamsCase name handlerName paramType-    _ -> fail "Unsupported constructor type"+mkDispatchCase :: ArgStyle -> Name -> Con -> Q Clause+mkDispatchCase style handlerName con = do+  let sname = snakeName (conName con)+  decoder <- mkConDecoder style con+  body <- case style of+    ToolArgs ->+      [| case $(return decoder) of+           Left err -> pure (Left err)+           Right v  -> do+             r <- $(varE handlerName) $(varE ctxName) v+             pure (Right (toToolResult r)) |]+    PromptArgs ->+      [| case $(return decoder) of+           Left err -> pure (Left err)+           Right v  -> do+             r <- $(varE handlerName) $(varE ctxName) v+             pure (Right (toPromptResult r)) |]   clause [litP $ stringL sname] (normalB (return body)) []  ---------------------------------------------------------------------------------- Field validation----------------------------------------------------------------------------------mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp-mkSeparateParamsCase outerConName handlerName paramType = do-  fields <- extractFieldsFromParamType paramType-  let argMapName = mkName "argMap"-  let mkBaseExp fieldVars = do-        paramConstructorApp <- buildParameterConstructor paramType fieldVars-        let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp-        [| do-            content <- $(varE handlerName) $(varE (mkName "ctx")) $(return outerConstructorApp)-            pure $ Right content |]-  inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0-  [| let $(varP argMapName) = Map.fromList args in $(return inner) |]--mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp-mkRecordCase recConName handlerName fields = do-  case fields of-    [] -> [| do-        content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE recConName)-        pure $ Right content |]-    _ -> do-      let argMapName = mkName "argMap"-      let mkBaseExp fieldVars = do-            let constructorApp = foldl AppE (ConE recConName) (map VarE fieldVars)-            [| do-                content <- $(varE handlerName) $(varE (mkName "ctx")) $(return constructorApp)-                pure $ Right content |]-      inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0-      [| let $(varP argMapName) = Map.fromList args in $(return inner) |]---- Build nested case expressions for field validation, supporting any number of fields.--- The mkBaseExp callback receives field variable names and builds the final expression.-buildFieldValidation :: Name -> Name -> ([Name] -> Q Exp) -> [(Name, Bang, Type)] -> Int -> Q Exp-buildFieldValidation _argMap _handlerName mkBaseExp [] depth = do-  let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]]-  mkBaseExp fieldVars--buildFieldValidation argMap handlerName mkBaseExp ((fieldName, _, fieldType):remainingFields) depth = do-  let fieldStr = nameBase fieldName-  let (isOptional, innerType) = unwrapMaybe fieldType-  let fieldVar = mkName ("field" ++ show depth)--  continuation <- buildFieldValidation argMap handlerName mkBaseExp remainingFields (depth + 1)--  let parseFunc = mkParseFunc innerType--  let fieldPrefix = litE $ stringL $ "field '" <> fieldStr <> "': "--  if isOptional-    then do-      [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of-            Nothing -> do-              let $(varP fieldVar) = Nothing-              $(return continuation)-            Just raw -> case $(parseFunc) raw of-              Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err)-              Right parsed -> do-                let $(varP fieldVar) = Just parsed-                $(return continuation) |]-    else do-      [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of-            Just raw -> case $(parseFunc) raw of-              Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err)-              Right $(varP fieldVar) -> $(return continuation)-            Nothing -> pure $ Left $ MissingRequiredParams $(litE $ stringL $ "field '" <> fieldStr <> "' is missing") |]---- Extract field information from parameter type-extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)]-extractFieldsFromParamType paramType = do-  case paramType of-    ConT typeName -> do-      info <- reify typeName-      case info of-        TyConI (DataD _ _ _ _ [RecC _ fields] _) ->-          return fields-        TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) ->-          extractFieldsFromParamType innerType-        _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"-    _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType---- Build the parameter constructor application recursively-buildParameterConstructor :: Type -> [Name] -> Q Exp-buildParameterConstructor paramType fieldVars = do-  case paramType of-    ConT typeName -> do-      info <- reify typeName-      case info of-        TyConI (DataD _ _ _ _ [RecC cn _] _) ->-          -- Record constructor - apply all field variables-          return $ foldl AppE (ConE cn) (map VarE fieldVars)-        TyConI (DataD _ _ _ _ [NormalC cn [(_bang, innerType)]] _) -> do-          -- Single parameter constructor - recurse and wrap-          innerConstructor <- buildParameterConstructor innerType fieldVars-          return $ AppE (ConE cn) innerConstructor-        _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"-    _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType---- Select the appropriate parse helper for a given type-mkParseFunc :: Type -> Q Exp-mkParseFunc innerType = case innerType of-  ConT n | nameBase n == "Int"     -> [| parseInt |]-  ConT n | nameBase n == "Integer" -> [| parseInteger |]-  ConT n | nameBase n == "Double"  -> [| parseDouble |]-  ConT n | nameBase n == "Float"   -> [| parseFloat |]-  ConT n | nameBase n == "Bool"    -> [| parseBool |]-  _                                -> [| parseText |]--------------------------------------------------------------------------------- -- Resource derivation -------------------------------------------------------------------------------  -- | Derive resource handlers from a data type with custom descriptions.+--+-- Nullary constructors become static resources+-- (@Menu -> resource:\/\/menu@). Record constructors become resource+-- /templates/ (@UserProfile { userId :: Text } ->+-- resource:\/\/user_profile\/{userId}@): they are excluded from+-- @resources\/list@ (advertise them with 'deriveResourceTemplates'), and the+-- read handler matches their URIs by splitting the path into percent-decoded+-- segments, one per field, in declaration order.+-- -- Usage: -- -- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp deriveResourceHandlerWithDescription typeName handlerName descriptions = do-  info <- reify typeName-  case info of-    TyConI (DataD _ _ _ _ constructors _) -> do-      -- Generate resource definitions-      resourceDefs <- traverse (mkResourceDefWithDescription descriptions) constructors+  cons <- reifyCons typeName+  case cons of+    Just constructors -> do+      -- Static resource definitions: nullary constructors only+      resourceDefs <- traverse (mkResourceDefWithDescription descriptions)+                               (filter isNullary constructors)       listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |] -      -- Generate read handler with cases-      cases <- traverse (mkResourceCase handlerName) constructors-      defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |]-      let defaultMatch = Match (VarP (mkName "unknown")) (NormalB defaultCase) []--      let readHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "uri")] $-            CaseE (AppE (VarE 'show) (VarE (mkName "uri")))-              (map clauseToMatch cases ++ [defaultMatch])+      -- Read handler: a chain of alternatives over every constructor,+      -- falling through to ResourceNotFound+      let fallbackQ = [| pure $ Left $ ResourceNotFound $+                           "Resource not found: " <> T.pack (show $(varE uriName)) |]+      readBody <- foldr (mkResourceAlt handlerName) fallbackQ constructors+      let readHandlerExp = LamE [VarP ctxName, VarP uriName] readBody        return $ TupE [Just listHandlerExp, Just readHandlerExp]-    _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type"+    Nothing -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type"  -- | Derive resource handlers from a data type. -- Usage:@@ -338,6 +430,50 @@ deriveResourceHandler typeName handlerName =   deriveResourceHandlerWithDescription typeName handlerName [] +-- | Derive a 'ResourceTemplateListHandler' advertising the record+-- constructors of a resource type as URI templates, with custom+-- descriptions. Usage:+--+-- > $(deriveResourceTemplatesWithDescription ''MyResource [("Constructor", "Description")])+deriveResourceTemplatesWithDescription :: Name -> [(String, String)] -> Q Exp+deriveResourceTemplatesWithDescription typeName descriptions = do+  cons <- reifyCons typeName+  case cons of+    Just constructors -> do+      templateDefs <- traverse (mkTemplateDefWithDescription descriptions)+                               [c | c@(RecC _ _) <- constructors]+      [| \_ctx -> pure $(return $ ListE templateDefs) |]+    Nothing -> fail $ "deriveResourceTemplatesWithDescription: " ++ show typeName ++ " is not a data type"++-- | Derive a 'ResourceTemplateListHandler' from a resource type's record+-- constructors. Usage:+--+-- > $(deriveResourceTemplates ''MyResource)+deriveResourceTemplates :: Name -> Q Exp+deriveResourceTemplates typeName =+  deriveResourceTemplatesWithDescription typeName []++-- The URI-template string for a record constructor:+-- resource://user_profile/{userId}/{...}+templateURI :: Name -> [(Name, Bang, Type)] -> String+templateURI name fields =+  "resource://" <> snakeName name+    <> concat ["/{" <> nameBase fn <> "}" | (fn, _, _) <- fields]++mkTemplateDefWithDescription :: [(String, String)] -> Con -> Q Exp+mkTemplateDefWithDescription _ (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)+  [| ResourceTemplateDefinition+      { resourceTemplateURITemplate = $(litE $ stringL $ templateURI name fields)+      , resourceTemplateName = $(litE $ stringL $ snakeName name)+      , resourceTemplateDescription = Just $(litE $ stringL description)+      , resourceTemplateMimeType = Just "text/plain"+      , resourceTemplateTitle = Nothing+      } |]+mkTemplateDefWithDescription _ _ = fail "Resource templates require record constructors"+ mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp mkResourceDefWithDescription descriptions (NormalC name []) = do   let resourceName = T.pack . snakeName $ name@@ -353,19 +489,53 @@           Just desc -> [| Just $(litE $ stringL desc) |]           Nothing   -> [| Nothing |])       , resourceDefinitionMimeType = Just "text/plain"-      , resourceDefinitionTitle = Nothing  -- 2025-06-18: New title field+      , resourceDefinitionTitle = Nothing       } |] mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" +-- One alternative of the read handler: try this constructor, else fall+-- through to the rest of the chain.+mkResourceAlt :: Name -> Con -> Q Exp -> Q Exp+mkResourceAlt handlerName con restQ = case con of+  NormalC name [] -> do+    let resourceURI = "resource://" <> snakeName name+    [| if show $(varE uriName) == $(litE $ stringL resourceURI)+         then Right <$> $(varE handlerName) $(varE ctxName) $(varE uriName) $(conE name)+         else $restQ |]+  RecC name [] ->+    fail $ "Resource template constructors need at least one field: " ++ nameBase name+  RecC name fields -> do+    let prefix = "resource://" <> snakeName name <> "/"+        segsName = mkName "segs"+    decoder <- mkSegmentsDecoder segsName name fields+    handled <- [| case $(return decoder) of+                    Left err -> pure (Left err)+                    Right v  -> Right <$> $(varE handlerName) $(varE ctxName) $(varE uriName) v |]+    rest <- restQ+    matchExp <- [| matchTemplateSegments $(litE $ stringL prefix)+                     $(litE $ integerL $ fromIntegral $ length fields)+                     (show $(varE uriName)) |]+    justP <- conP 'Just [varP segsName]+    nothingP <- conP 'Nothing []+    return $ CaseE matchExp+      [ Match justP (NormalB handled) []+      , Match nothingP (NormalB rest) []+      ]+  _ -> fail "Unsupported constructor type for resources" -mkResourceCase :: Name -> Con -> Q Clause-mkResourceCase handlerName (NormalC name []) = do-  let resourceName = T.pack . snakeName $ name-  let resourceURI = "resource://" <> T.unpack resourceName-  clause [litP $ stringL resourceURI]-    (normalB [| Right <$> $(varE handlerName) $(varE (mkName "ctx")) $(varE (mkName "uri")) $(conE name) |])-    []-mkResourceCase _ _ = fail "Unsupported constructor type for resources"+-- Applicative decode of the matched template segments into the constructor+mkSegmentsDecoder :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp+mkSegmentsDecoder segsName con fields =+  foldl step [| pure $(conE con) |] (zip [0 :: Integer ..] fields)+  where+    step acc (i, (fieldName, _, fieldType)) = do+      let (isOptional, innerType) = unwrapMaybe fieldType+      if isOptional+        then fail $ "Maybe fields are not supported in resource templates: " ++ nameBase fieldName+        else [| $acc <*> templateField $(litE $ stringL $ nameBase fieldName)+                        $(mkTextParser innerType)+                        $(varE segsName)+                        $(litE $ integerL i) |]  ------------------------------------------------------------------------------- -- Tool derivation@@ -377,24 +547,24 @@ -- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp deriveToolHandlerWithDescription typeName handlerName descriptions = do-  info <- reify typeName-  case info of-    TyConI (DataD _ _ _ _ constructors _) -> do+  cons <- reifyCons typeName+  case cons of+    Just constructors -> do       -- Generate tool definitions       toolDefs <- traverse (mkToolDefWithDescription descriptions) constructors        listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |]        -- Generate call handler with cases-      cases <- traverse (mkDispatchCase handlerName) constructors-      defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |]+      cases <- traverse (mkDispatchCase ToolArgs handlerName) constructors+      defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> $(varE argNameN) |]       let defaultMatch = Match WildP (NormalB defaultCase) []-      let callHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $-            CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))+      let callHandlerExp = LamE [VarP ctxName, VarP argNameN, VarP argsName] $+            CaseE (AppE (VarE 'T.unpack) (VarE argNameN))               (map clauseToMatch cases ++ [defaultMatch])        return $ TupE [Just listHandlerExp, Just callHandlerExp]-    _ -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type"+    Nothing -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type"  -- | Derive tool handlers from a data type. -- Usage:@@ -410,25 +580,11 @@   let sname = snakeName name   let description = descriptionFor descriptions (nameBase name) (nameBase name)   fields <- getConFields con-  props <- traverse (mkProperty descriptions) fields-  let required = requiredFieldNames fields+  shapeExp <- mkObjectShape descriptions fields   [| ToolDefinition       { toolDefinitionName = $(litE $ stringL sname)       , toolDefinitionDescription = $(litE $ stringL description)-      , toolDefinitionInputSchema = InputSchemaDefinitionObject-          { properties = $(return $ ListE props)-          , required = $(return $ ListE $ map (LitE . StringL) required)-          }+      , toolDefinitionInputSchema = Schema Nothing $(return shapeExp)+      , toolDefinitionOutputSchema = Nothing       , toolDefinitionTitle = Nothing       } |]--mkProperty :: [(String, String)] -> (Name, Bang, Type) -> Q Exp-mkProperty descriptions (fieldName, _, fieldType) = do-  let fieldStr = nameBase fieldName-  let description = descriptionFor descriptions fieldStr fieldStr-  let (_, innerType) = unwrapMaybe fieldType-  let jsonType = jsonTypeFor innerType-  [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty-      { propertyType = $(litE $ stringL jsonType)-      , propertyDescription = $(litE $ stringL description)-      }) |]

@@ -1,18 +1,62 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Runtime support for the code generated by "MCP.Server.Derive".+--+-- Two families of parsers exist because the MCP specification types the two+-- argument channels differently: prompt arguments are always strings, while+-- tool arguments are full JSON values. The Value-based parsers are lenient:+-- they accept the native JSON type and fall back to parsing the string+-- representation, since many clients send numbers and booleans as strings. module MCP.Server.Derive.Internal-  ( parseText+  ( -- * Text-based parsers (prompt arguments)+    parseText   , parseInt   , parseInteger   , parseDouble   , parseFloat   , parseBool+    -- * Value-based parsers (tool arguments)+  , valueText+  , valueInt+  , valueInteger+  , valueDouble+  , valueFloat+  , valueBool+  , valueArray+  , renderValue+    -- * Argument/field extraction+  , requiredArg+  , optionalArg+  , requiredTextArg+  , optionalTextArg+  , requiredField+  , optionalField+    -- * Resource template matching+  , matchTemplateSegments+  , templateField   ) where -import           Data.Text (Text)-import qualified Data.Text as T-import           Text.Read (readMaybe)+import           Data.Aeson           (Value (..), encode)+import qualified Data.Aeson.Key       as Key+import qualified Data.Aeson.KeyMap    as KM+import qualified Data.ByteString.Lazy as BSL+import           Data.Foldable        (toList)+import           Data.Map             (Map)+import qualified Data.Map             as Map+import           Data.Scientific      (base10Exponent, floatingOrInteger,+                                       toBoundedInteger, toRealFloat)+import           Data.Text            (Text)+import qualified Data.Text            as T+import qualified Data.Text.Encoding   as TE+import           Network.URI          (unEscapeString)+import           Text.Read            (readMaybe) +import           MCP.Server.Types     (Error (..))++-- ---------------------------------------------------------------------------+-- Text-based parsers (prompt arguments are strings per the MCP spec)+-- ---------------------------------------------------------------------------+ parseText :: Text -> Either Text Text parseText = Right @@ -41,3 +85,131 @@   "true"  -> Right True   "false" -> Right False   _       -> Left $ "Failed to parse Bool from: " <> t++-- ---------------------------------------------------------------------------+-- Value-based parsers (tool arguments are full JSON values)+-- ---------------------------------------------------------------------------++-- | A short rendering of a JSON value for error messages.+renderValue :: Value -> Text+renderValue (String t) = t+renderValue v          = TE.decodeUtf8 $ BSL.toStrict $ encode v++valueText :: Value -> Either Text Text+valueText (String t) = Right t+valueText v          = Left $ "Failed to parse Text from: " <> renderValue v++valueInt :: Value -> Either Text Int+valueInt (Number n) = case toBoundedInteger n of+  Just i  -> Right i+  Nothing -> Left $ "Failed to parse Int from: " <> renderValue (Number n)+valueInt (String t) = parseInt t+valueInt v          = Left $ "Failed to parse Int from: " <> renderValue v++valueInteger :: Value -> Either Text Integer+valueInteger (Number n)+  -- Bound the exponent before materializing the Integer: aeson keeps huge+  -- exponents compact, so a tiny payload like 1e1000000000 would otherwise+  -- allocate a billion-digit Integer (same bound aeson itself uses for its+  -- FromJSON Integer instance).+  | base10Exponent n > 1024 =+      Left "Failed to parse Integer: exponent too large"+  | otherwise = case floatingOrInteger n :: Either Double Integer of+      Right i -> Right i+      Left _  -> Left $ "Failed to parse Integer from: " <> renderValue (Number n)+valueInteger (String t) = parseInteger t+valueInteger v          = Left $ "Failed to parse Integer from: " <> renderValue v++valueDouble :: Value -> Either Text Double+valueDouble (Number n) = Right (toRealFloat n)+valueDouble (String t) = parseDouble t+valueDouble v          = Left $ "Failed to parse Double from: " <> renderValue v++valueFloat :: Value -> Either Text Float+valueFloat (Number n) = Right (toRealFloat n)+valueFloat (String t) = parseFloat t+valueFloat v          = Left $ "Failed to parse Float from: " <> renderValue v++valueBool :: Value -> Either Text Bool+valueBool (Bool b)   = Right b+valueBool (String t) = parseBool t+valueBool v          = Left $ "Failed to parse Bool from: " <> renderValue v++valueArray :: (Value -> Either Text a) -> Value -> Either Text [a]+valueArray p (Array xs) = traverse p (toList xs)+valueArray _ v          = Left $ "Failed to parse array from: " <> renderValue v++-- ---------------------------------------------------------------------------+-- Argument extraction from the top-level arguments map+-- ---------------------------------------------------------------------------++prefixed :: Text -> Either Text a -> Either Error a+prefixed name = either (Left . InvalidParams . (("field '" <> name <> "': ") <>)) Right++-- | A required tool argument: missing yields 'MissingRequiredParams', a parse+-- failure yields 'InvalidParams' with the field name prefixed.+requiredArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error a+requiredArg name p args = case Map.lookup name args of+  Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing"+  Just v  -> prefixed name (p v)++-- | An optional tool argument: absent (or JSON null) becomes 'Nothing'.+optionalArg :: Text -> (Value -> Either Text a) -> Map Text Value -> Either Error (Maybe a)+optionalArg name p args = case Map.lookup name args of+  Nothing   -> Right Nothing+  Just Null -> Right Nothing+  Just v    -> Just <$> prefixed name (p v)++-- | A required prompt argument (string-valued).+requiredTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error a+requiredTextArg name p args = case Map.lookup name args of+  Nothing -> Left $ MissingRequiredParams $ "field '" <> name <> "' is missing"+  Just t  -> prefixed name (p t)++-- | An optional prompt argument (string-valued).+optionalTextArg :: Text -> (Text -> Either Text a) -> Map Text Text -> Either Error (Maybe a)+optionalTextArg name p args = case Map.lookup name args of+  Nothing -> Right Nothing+  Just t  -> Just <$> prefixed name (p t)++-- ---------------------------------------------------------------------------+-- Field extraction from nested JSON objects+-- ---------------------------------------------------------------------------++-- | A required field of a nested object argument.+requiredField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text a+requiredField name p o = case KM.lookup (Key.fromText name) o of+  Nothing -> Left $ "field '" <> name <> "' is missing"+  Just v  -> either (Left . (("field '" <> name <> "': ") <>)) Right (p v)++-- | An optional field of a nested object argument: absent or null is 'Nothing'.+optionalField :: Text -> (Value -> Either Text a) -> KM.KeyMap Value -> Either Text (Maybe a)+optionalField name p o = case KM.lookup (Key.fromText name) o of+  Nothing   -> Right Nothing+  Just Null -> Right Nothing+  Just v    -> either (Left . (("field '" <> name <> "': ") <>)) (Right . Just) (p v)++-- ---------------------------------------------------------------------------+-- Resource template matching+-- ---------------------------------------------------------------------------++-- | Match a URI against a template of the form @\<prefix\>{a}\/{b}\/…@: the+-- rendered URI must start with the prefix and continue with exactly @n@+-- non-empty, slash-separated segments, which are returned percent-decoded.+-- Any query or fragment on the URI is ignored — templates declare only path+-- variables (a literal @?@ or @#@ inside a segment value arrives+-- percent-encoded and is unaffected).+matchTemplateSegments :: Text -> Int -> String -> Maybe [Text]+matchTemplateSegments prefix n uriStr = do+  let base = T.takeWhile (\c -> c /= '?' && c /= '#') (T.pack uriStr)+  rest <- T.stripPrefix prefix base+  let segs = T.splitOn "/" rest+  if length segs == n && all (not . T.null) segs+    then Just (map (T.pack . unEscapeString . T.unpack) segs)+    else Nothing++-- | Decode one matched template segment into a field value.+templateField :: Text -> (Text -> Either Text a) -> [Text] -> Int -> Either Error a+templateField name p segs i = case drop i segs of+  (s:_) -> either (Left . InvalidParams . (("template field '" <> name <> "': ") <>)) Right (p s)+  []    -> Left $ InvalidParams $ "missing segment for template field '" <> name <> "'"

@@ -9,25 +9,32 @@     -- * Individual Request Handlers   , handleInitialize   , handlePing+  , handleServerDiscover   , handlePromptsList   , handlePromptsGet   , handleResourcesList   , handleResourcesRead+  , handleResourcesTemplatesList   , handleToolsList   , handleToolsCall+  , handleCompletionComplete      -- * Protocol Support   , validateProtocolVersion   , getMessageSummary+  , metaProtocolVersion+  , unsupportedVersionError      -- * Error Conversion   , errorCodeFromMcpError   , errorMessageFromMcpError   ) where -import           Control.Monad.IO.Class (MonadIO, liftIO) import           Data.Aeson+import qualified Data.Aeson.Key         as Key+import qualified Data.Aeson.KeyMap      as KM import qualified Data.Map               as Map+import           Data.Maybe             (fromMaybe, isJust) import           Data.Text              (Text) import qualified Data.Text              as T import           System.IO              (hPutStrLn, stderr)@@ -62,51 +69,157 @@ -- Per MCP spec: "If the server supports the requested protocol version, -- it MUST respond with the same version. Otherwise, the server MUST respond -- with another protocol version it supports."+--+-- Only /legacy/ revisions are eligible here: a client that negotiates via+-- @initialize@ is legacy by definition, so proposing @2026-07-28@ (or+-- anything unknown) negotiates down to the newest legacy revision rather+-- than promising stateless semantics inside a handshake. validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion   | clientVersion `elem` supportedVersions = Right clientVersion  -- Supported: echo the client's own version   | otherwise = Right protocolVersion  -- Unknown: negotiate down to the server's default version --- | Handle an MCP message and return a response if needed-handleMcpMessage :: (MonadIO m)-                 => McpServerInfo-                 -> McpServerHandlers m+-- | Look up an @io.modelcontextprotocol/\<key\>@ entry in a request's+-- params @_meta@ object.+metaLookup :: Text -> Maybe Value -> Maybe Value+metaLookup key params = do+  Object o <- params+  Object m <- KM.lookup "_meta" o+  KM.lookup (Key.fromText ("io.modelcontextprotocol/" <> key)) m++-- | The protocol revision a request declares in its params @_meta@+-- (modern, 2026-07-28+ clients). 'Nothing' for legacy requests.+metaProtocolVersion :: Maybe Value -> Maybe Text+metaProtocolVersion params = case metaLookup "protocolVersion" params of+  Just (String v) -> Just v+  _               -> Nothing++-- | The @UnsupportedProtocolVersionError@ (-32022) for a declared version+-- this library does not implement, listing what it does.+unsupportedVersionError :: Text -> JsonRpcError+unsupportedVersionError requested = JsonRpcError+  { errorCode = -32022+  , errorMessage = "Unsupported protocol version"+  , errorData = Just $ object+      [ "supported" .= allVersions+      , "requested" .= requested+      ]+  }++-- | Methods whose modern results carry the required cacheability fields.+cacheableMethods :: [Text]+cacheableMethods =+  [ "server/discover"+  , "tools/list"+  , "prompts/list"+  , "resources/list"+  , "resources/read"+  , "resources/templates/list"+  ]++-- | Stamp the modern-revision result envelope onto a successful response:+-- @resultType: \"complete\"@, the server's identity in result @_meta@, and+-- (for cacheable methods) @ttlMs@ and @cacheScope@. Error responses and+-- legacy responses pass through untouched.+decorateModern :: McpServerInfo -> CacheHints -> Text -> JsonRpcResponse -> JsonRpcResponse+decorateModern serverInfo hints method resp = case responseResult resp of+  Just (Object o) -> resp { responseResult = Just $ Object $ decorate o }+  _               -> resp+  where+    decorate = insertCache . KM.insert "resultType" (String "complete") . insertMeta+    insertMeta o = KM.insert "_meta" (Object meta) o+      where meta = case KM.lookup "_meta" o of+              Just (Object m) -> KM.insert serverInfoKey serverInfoVal m+              _               -> KM.singleton serverInfoKey serverInfoVal+    serverInfoKey = "io.modelcontextprotocol/serverInfo"+    serverInfoVal = object+      [ "name" .= serverName serverInfo+      , "version" .= serverVersion serverInfo+      ]+    insertCache o+      | method `elem` cacheableMethods =+          KM.insert "ttlMs" (toJSON (cacheTtlMs hints)) $+          KM.insert "cacheScope"+            (String (if cacheScopePublic hints then "public" else "private")) o+      | otherwise = o++-- | Handle an MCP message and return a response if needed.+--+-- The server is dual-era: a request that declares a protocol revision in+-- its params @_meta@ (2026-07-28+) is served statelessly with the modern+-- result envelope; a request that does not is served exactly as before+-- under the revision negotiated by @initialize@.+handleMcpMessage :: McpServerInfo+                 -> CacheHints+                 -> NotificationSupport+                 -> McpServerHandlers                  -> ClientContext                  -> JsonRpcMessage-                 -> m (Maybe JsonRpcMessage)-handleMcpMessage serverInfo handlers ctx (JsonRpcMessageRequest req) = do-  response <- case requestMethod req of-    "initialize" -> handleInitialize serverInfo handlers req-    "ping" -> handlePing req-    "prompts/list" -> handlePromptsList handlers ctx req-    "prompts/get" -> handlePromptsGet handlers ctx req-    "resources/list" -> handleResourcesList handlers ctx req-    "resources/read" -> handleResourcesRead handlers ctx req-    "tools/list" -> handleToolsList handlers ctx req-    "tools/call" -> handleToolsCall handlers ctx req-    method -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Method not found: " <> method-      , errorData = Nothing-      }-  return $ Just $ JsonRpcMessageResponse response+                 -> IO (Maybe JsonRpcMessage)+handleMcpMessage serverInfo hints notifSupport handlers ctx0 (JsonRpcMessageRequest req) = do+  let params = requestParams req+      declaredVersion = metaProtocolVersion params+  case declaredVersion of+    Just v | v `notElem` modernVersions ->+      return $ Just $ JsonRpcMessageResponse $+        makeErrorResponse (requestId req) (unsupportedVersionError v)+    _ -> do+      -- server/discover is itself a modern-revision method (and the+      -- backwards-compatibility probe), so it always gets the modern+      -- envelope even if a probing client omitted _meta.+      let modern = isJust declaredVersion || requestMethod req == "server/discover"+          ctx = ctx0+            { clientProtocolVersion = declaredVersion+            , clientInfo = metaLookup "clientInfo" params+            , clientCapabilities = metaLookup "clientCapabilities" params+            }+      response <- case requestMethod req of+        -- Era purity: the modern revision has neither initialize (nothing to+        -- negotiate statelessly) nor ping (removed) — a request declaring a+        -- modern revision must be served "according to this revision", so+        -- these are unknown methods there.+        m | isJust declaredVersion, m `elem` ["initialize", "ping"] ->+              return $ makeErrorResponse (requestId req) $ JsonRpcError+                { errorCode = -32601+                , errorMessage = "Method not found: " <> m+                    <> " (not part of protocol revision " <> fromMaybe "" declaredVersion <> ")"+                , errorData = Nothing+                }+        "initialize" -> handleInitialize serverInfo notifSupport handlers req+        "ping" -> handlePing req+        "server/discover" -> handleServerDiscover serverInfo notifSupport handlers req+        "prompts/list" -> handlePromptsList handlers ctx req+        "prompts/get" -> handlePromptsGet handlers ctx req+        "resources/list" -> handleResourcesList handlers ctx req+        "resources/read" -> handleResourcesRead handlers ctx req+        "resources/templates/list" -> handleResourcesTemplatesList handlers ctx req+        "tools/list" -> handleToolsList handlers ctx req+        "tools/call" -> handleToolsCall handlers ctx req+        "completion/complete" -> handleCompletionComplete handlers ctx req+        method -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32601+          , errorMessage = "Method not found: " <> method+          , errorData = Nothing+          }+      let response' = if modern+            then decorateModern serverInfo hints (requestMethod req) response+            else response+      return $ Just $ JsonRpcMessageResponse response' -handleMcpMessage _ _ _ (JsonRpcMessageNotification notif) = do+handleMcpMessage _ _ _ _ _ (JsonRpcMessageNotification notif) = do   case notificationMethod notif of-    "notifications/initialized" -> do-      liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation"-      return ()-    _ -> do-      liftIO $ hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)-      return ()+    "notifications/initialized" ->+      hPutStrLn stderr "Received initialized notification - server is ready for operation"+    _ ->+      hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)   return Nothing -handleMcpMessage _ _ _ (JsonRpcMessageResponse _) =+handleMcpMessage _ _ _ _ _ (JsonRpcMessageResponse _) =   return Nothing  -- | Handle initialize request-handleInitialize :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleInitialize serverInfo handlers req = do+handleInitialize :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse+handleInitialize serverInfo notifSupport handlers req = do   case requestParams req of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32602@@ -130,29 +243,66 @@               , errorData = Nothing               }             Right negotiatedVersion -> do-              liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion-              -- Only advertise a capability that actually has a handler.-              -- Advertising e.g. "prompts" while prompts/list returns an error-              -- makes strict clients (e.g. Crush) drop the whole server.-              let capabilities = ServerCapabilities-                    { capabilityPrompts   = PromptCapabilities { promptListChanged = Nothing } <$ prompts handlers-                    , capabilityResources = ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing } <$ resources handlers-                    , capabilityTools     = ToolCapabilities { toolListChanged = Nothing } <$ tools handlers-                    , capabilityLogging   = Nothing  -- Not supported yet-                    }+              hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion               let response = InitializeResponse                     { initRespProtocolVersion = negotiatedVersion-                    , initRespCapabilities = capabilities+                    -- Legacy clients can only receive pushed notifications+                    -- where the transport supports it (stdio); the modern+                    -- subscribe mechanism is not part of their revision.+                    , initRespCapabilities =+                        handlerCapabilities (supportsLegacyPush notifSupport) False handlers                     , initRespServerInfo = serverInfo                     }               return $ makeSuccessResponse (requestId req) (toJSON response) +-- | Only advertise a capability that actually has a handler.+-- Advertising e.g. "prompts" while prompts/list returns an error+-- makes strict clients (e.g. Crush) drop the whole server.+--+-- The flags say whether change notifications (@listChanged@) and resource+-- update subscriptions (@subscribe@) are deliverable to the requesting+-- client — which depends on transport and era, so callers decide.+handlerCapabilities :: Bool -> Bool -> McpServerHandlers -> ServerCapabilities+handlerCapabilities listChanged subscribe handlers = ServerCapabilities+  { capabilityPrompts   = PromptCapabilities { promptListChanged = flag listChanged } <$ prompts handlers+  , capabilityResources =+      if isJust (resources handlers) || isJust (resourceTemplates handlers)+        then Just ResourceCapabilities+              { resourceSubscribe = flag subscribe+              , resourceListChanged = flag listChanged+              }+        else Nothing+  , capabilityTools     = ToolCapabilities { toolListChanged = flag listChanged } <$ tools handlers+  , capabilityCompletions = CompletionCapabilities <$ completions handlers+  , capabilityLogging   = Nothing  -- Not supported yet+  }+  where+    flag b = if b then Just True else Nothing+ -- | Handle ping request-handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse+handlePing :: JsonRpcRequest -> IO JsonRpcResponse handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse) +-- | Handle server/discover (2026-07-28+): the server's supported protocol+-- revisions, capabilities and identity, available before any other request.+-- Also serves as the stdio backwards-compatibility probe. The modern result+-- envelope (resultType, serverInfo _meta, cacheability) is stamped on by+-- 'decorateModern'.+handleServerDiscover :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse+handleServerDiscover serverInfo notifSupport handlers req = do+  -- Modern clients receive notifications via subscriptions/listen, so both+  -- listChanged and subscribe hinge on that being served.+  let listen = supportsListen notifSupport+      result = object $+        [ "supportedVersions" .= allVersions+        , "capabilities" .= handlerCapabilities listen listen handlers+        ] ++ (if T.null (serverInstructions serverInfo)+                then []+                else ["instructions" .= serverInstructions serverInfo])+  return $ makeSuccessResponse (requestId req) result+ -- | Handle prompts/list request-handlePromptsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handlePromptsList handlers ctx req =   case prompts handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -168,7 +318,7 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle prompts/get request-handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsGet :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handlePromptsGet handlers ctx req =   case prompts handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -191,7 +341,9 @@               , errorData = Nothing               }             Success getReq -> do-              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq)+              -- Prompt arguments are string-valued per the MCP spec; flatten+              -- any non-string values a lenient client may have sent.+              let args = maybe Map.empty (fmap jsonValueToText) (promptsGetArguments getReq)               result <- getHandler ctx (promptsGetName getReq) args               case result of                 Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -199,18 +351,24 @@                   , errorMessage = errorMessageFromMcpError err                   , errorData = Nothing                   }-                Right content -> do+                Right promptRes -> do                   let response = PromptsGetResponse-                        { promptsGetDescription = Nothing-                        , promptsGetMessages = [PromptMessage RoleUser content]-                        , promptsGetMeta = Nothing  -- Can be extended for additional metadata+                        { promptsGetDescription = promptResultDescription promptRes+                        , promptsGetMessages = promptResultMessages promptRes+                        , promptsGetMeta = Nothing                         }                   return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle resources/list request-handleResourcesList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleResourcesList handlers ctx req =   case resources handlers of+    -- A templates-only configuration advertises the resources capability,+    -- so resources/list must answer (with an empty list) rather than error:+    -- strict clients drop servers whose advertised capabilities error.+    Nothing | isJust (resourceTemplates handlers) ->+      return $ makeSuccessResponse (requestId req)+        (toJSON (ResourcesListResponse { resourcesListResources = [] }))     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601       , errorMessage = "Resources not supported"@@ -224,7 +382,7 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle resources/read request-handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesRead :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleResourcesRead handlers ctx req =   case resources handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -260,8 +418,62 @@                         }                   return $ makeSuccessResponse (requestId req) (toJSON response) +-- | Handle resources/templates/list request+handleResourcesTemplatesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse+handleResourcesTemplatesList handlers ctx req =+  case resourceTemplates handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Resource templates not supported"+      , errorData = Nothing+      }+    Just listHandler -> do+      templates <- listHandler ctx+      let response = ResourcesTemplatesListResponse+            { resourcesTemplatesList = templates+            }+      return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle completion/complete request+handleCompletionComplete :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse+handleCompletionComplete handlers ctx req =+  case completions handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Completions not supported"+      , errorData = Nothing+      }+    Just completeHandler ->+      case requestParams req of+        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32602+          , errorMessage = "Missing parameters"+          , errorData = Nothing+          }+        Just params ->+          case fromJSON params of+            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+              { errorCode = -32602+              , errorMessage = "Invalid parameters: " <> T.pack err+              , errorData = Nothing+              }+            Success completeReq -> do+              result <- completeHandler ctx+                (completeRef completeReq)+                (completeArgumentName completeReq)+                (completeArgumentValue completeReq)+                (completeContextArgs completeReq)+              case result of+                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+                  { errorCode = errorCodeFromMcpError err+                  , errorMessage = errorMessageFromMcpError err+                  , errorData = Nothing+                  }+                Right completion ->+                  return $ makeSuccessResponse (requestId req) (toJSON (CompleteResponse completion))+ -- | Handle tools/list request-handleToolsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleToolsList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleToolsList handlers ctx req =   case tools handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -277,7 +489,7 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle tools/call request-handleToolsCall :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleToolsCall :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse handleToolsCall handlers ctx req =   case tools handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -300,7 +512,8 @@               , errorData = Nothing               }             Success callReq -> do-              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq)+              -- Tool arguments are passed through as full JSON values.+              let args = fromMaybe Map.empty (toolsCallArguments callReq)               result <- callHandler ctx (toolsCallName callReq) args               case result of                 Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError@@ -308,11 +521,12 @@                   , errorMessage = errorMessageFromMcpError err                   , errorData = Nothing                   }-                Right content -> do+                Right toolRes -> do                   let response = ToolsCallResponse-                        { toolsCallContent = [content]-                        , toolsCallIsError = Nothing-                        , toolsCallMeta = Nothing  -- Can be extended for structured output+                        { toolsCallContent = toolResultContent toolRes+                        , toolsCallIsError = if toolResultIsError toolRes then Just True else Nothing+                        , toolsCallStructuredContent = toolResultStructured toolRes+                        , toolsCallMeta = toolResultMeta toolRes                         }                   return $ makeSuccessResponse (requestId req) (toJSON response) 

@@ -20,9 +20,10 @@  import Data.Text (Text) import Data.Aeson+import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (parseEither)+import Data.Scientific (toBoundedInteger) import GHC.Generics (Generic)-import Control.Applicative ((<|>))  -- | JSON-RPC request ID data RequestId@@ -38,7 +39,9 @@  instance FromJSON RequestId where   parseJSON (String t) = return $ RequestIdText t-  parseJSON (Number n) = return $ RequestIdNumber (round n)+  parseJSON (Number n) = case toBoundedInteger n of+    Just i  -> return $ RequestIdNumber i+    Nothing -> fail "Request id must be an integral number"   parseJSON Null = return RequestIdNull   parseJSON _ = fail "Invalid request ID" @@ -137,12 +140,16 @@   toJSON (JsonRpcMessageResponse resp) = toJSON resp   toJSON (JsonRpcMessageNotification notif) = toJSON notif +-- | Classify by shape instead of parse-fallthrough: a request with a+-- malformed field must fail as a request, not silently succeed as a+-- notification (which has fewer required fields). instance FromJSON JsonRpcMessage where-  parseJSON v = parseRequest v <|> parseResponse v <|> parseNotification v-    where-      parseRequest = fmap JsonRpcMessageRequest . parseJSON-      parseResponse = fmap JsonRpcMessageResponse . parseJSON-      parseNotification = fmap JsonRpcMessageNotification . parseJSON+  parseJSON = withObject "JsonRpcMessage" $ \o ->+    case (KM.member "method" o, KM.member "id" o) of+      (True, True)   -> JsonRpcMessageRequest <$> parseJSON (Object o)+      (True, False)  -> JsonRpcMessageNotification <$> parseJSON (Object o)+      (False, True)  -> JsonRpcMessageResponse <$> parseJSON (Object o)+      (False, False) -> fail "Not a JSON-RPC message: no method and no id"  -- | Create a successful JSON-RPC response makeSuccessResponse :: RequestId -> Value -> JsonRpcResponse

@@ -0,0 +1,188 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Server-initiated change notifications.+--+-- Create a notifier with 'newMcpNotifier', hand the 'NotificationSource' to+-- a transport via its configuration ('MCP.Server.Transport.Stdio.StdioConfig'+-- \/ 'MCP.Server.Transport.Http.HttpConfig'), keep the 'McpNotifier', and+-- call its actions whenever your tool\/prompt\/resource lists (or a specific+-- resource) change:+--+-- > (notifier, source) <- newMcpNotifier+-- > let config = defaultStdioConfig { stdioNotifications = Just source }+-- > _ <- forkIO $ appLogic notifier+-- > runMcpServerStdioWithConfig config serverInfo handlers+--+-- Delivery is transport- and era-specific: modern (2026-07-28) clients open+-- a @subscriptions\/listen@ stream and receive only the notification types+-- they opted into, tagged with their subscription id; legacy stdio clients+-- receive untagged notifications spontaneously after @initialize@. Legacy+-- HTTP has no delivery channel (this library dropped the deprecated GET SSE+-- stream), so the @listChanged@ capabilities are not advertised there.+module MCP.Server.Notifications+  ( -- * Notifier+    McpNotifier(..)+  , NotificationSource+  , newMcpNotifier+  , ChangeEvent(..)+  , subscribeEvents++    -- * Subscription wire format (used by transports)+  , NotificationFilter(..)+  , parseNotificationFilter+  , filterAccepts+  , filterIsEmpty+  , acknowledgedNotification+  , eventNotification+  , legacyEventNotification+  , closureResponse+  ) where++import           Control.Concurrent.STM (STM, TChan, atomically,+                                         dupTChan, newBroadcastTChanIO,+                                         writeTChan)+import           Data.Aeson+import qualified Data.Aeson.KeyMap      as KM+import           Data.Aeson.Types       (Pair)+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Network.URI            (URI)++import           MCP.Server.JsonRpc+import           MCP.Server.Types       (McpServerInfo (..))++-- | A change an application can announce.+data ChangeEvent+  = ToolsListChangedEvent+  | PromptsListChangedEvent+  | ResourcesListChangedEvent+  | ResourceUpdatedEvent Text  -- ^ the resource URI, rendered+  deriving (Show, Eq)++-- | The application-facing handle: call these when things change.+data McpNotifier = McpNotifier+  { notifyToolsListChanged     :: IO ()+  , notifyPromptsListChanged   :: IO ()+  , notifyResourcesListChanged :: IO ()+  , notifyResourceUpdated      :: URI -> IO ()+  }++-- | The transport-facing end of a notifier: subscribe with+-- 'subscribeEvents'. Backed by a broadcast 'TChan', so events published+-- while nobody listens are dropped rather than retained.+newtype NotificationSource = NotificationSource (TChan ChangeEvent)++-- | Create a notifier and its source.+newMcpNotifier :: IO (McpNotifier, NotificationSource)+newMcpNotifier = do+  chan <- newBroadcastTChanIO+  let publish = atomically . writeTChan chan+  pure+    ( McpNotifier+        { notifyToolsListChanged     = publish ToolsListChangedEvent+        , notifyPromptsListChanged   = publish PromptsListChangedEvent+        , notifyResourcesListChanged = publish ResourcesListChangedEvent+        , notifyResourceUpdated      = publish . ResourceUpdatedEvent . T.pack . show+        }+    , NotificationSource chan+    )++-- | A private read end delivering every event published after the call.+subscribeEvents :: NotificationSource -> STM (TChan ChangeEvent)+subscribeEvents (NotificationSource chan) = dupTChan chan++-- | Which notification types a @subscriptions\/listen@ request opted into.+data NotificationFilter = NotificationFilter+  { filterTools        :: Bool+  , filterPrompts      :: Bool+  , filterResources    :: Bool+  , filterResourceSubs :: [Text]  -- ^ URIs watched for updates+  } deriving (Show, Eq)++-- | Parse the @notifications@ filter out of a @subscriptions\/listen@+-- request's params. Absent fields mean "not subscribed".+parseNotificationFilter :: Maybe Value -> NotificationFilter+parseNotificationFilter params = NotificationFilter+  { filterTools        = boolField "toolsListChanged"+  , filterPrompts      = boolField "promptsListChanged"+  , filterResources    = boolField "resourcesListChanged"+  , filterResourceSubs = subsField+  }+  where+    notifications = do+      Object o <- params+      KM.lookup "notifications" o+    boolField key = case notifications of+      Just (Object n) | Just (Bool b) <- KM.lookup key n -> b+      _ -> False+    subsField = case notifications of+      Just (Object n) | Just (Array xs) <- KM.lookup "resourceSubscriptions" n ->+        [u | String u <- foldr (:) [] xs]+      _ -> []++-- | Whether a subscription with this filter receives the event.+filterAccepts :: NotificationFilter -> ChangeEvent -> Bool+filterAccepts f ToolsListChangedEvent      = filterTools f+filterAccepts f PromptsListChangedEvent    = filterPrompts f+filterAccepts f ResourcesListChangedEvent  = filterResources f+filterAccepts f (ResourceUpdatedEvent uri) = uri `elem` filterResourceSubs f++-- | True when the filter subscribes to nothing at all.+filterIsEmpty :: NotificationFilter -> Bool+filterIsEmpty f =+  not (filterTools f || filterPrompts f || filterResources f)+    && null (filterResourceSubs f)++-- | The @_meta@ object tagging a message with its subscription id (the+-- JSON-RPC id of the @subscriptions\/listen@ request).+subscriptionMeta :: RequestId -> Pair+subscriptionMeta subId =+  "_meta" .= object ["io.modelcontextprotocol/subscriptionId" .= subId]++-- | The mandatory first message of a subscription stream: the honored+-- filter (this library honors every requested type).+acknowledgedNotification :: RequestId -> NotificationFilter -> JsonRpcNotification+acknowledgedNotification subId f =+  makeNotification "notifications/subscriptions/acknowledged" $ Just $ object+    [ subscriptionMeta subId+    , "notifications" .= object (concat+        [ ["toolsListChanged" .= True | filterTools f]+        , ["promptsListChanged" .= True | filterPrompts f]+        , ["resourcesListChanged" .= True | filterResources f]+        , ["resourceSubscriptions" .= filterResourceSubs f | not (null (filterResourceSubs f))]+        ])+    ]++-- | The method and extra params of an event's notification.+eventBody :: ChangeEvent -> (Text, [Pair])+eventBody ToolsListChangedEvent      = ("notifications/tools/list_changed", [])+eventBody PromptsListChangedEvent    = ("notifications/prompts/list_changed", [])+eventBody ResourcesListChangedEvent  = ("notifications/resources/list_changed", [])+eventBody (ResourceUpdatedEvent uri) = ("notifications/resources/updated", ["uri" .= uri])++-- | A change event as a subscription-tagged notification (modern era).+eventNotification :: RequestId -> ChangeEvent -> JsonRpcNotification+eventNotification subId event =+  let (method, extra) = eventBody event+  in makeNotification method $ Just $ object (subscriptionMeta subId : extra)++-- | A change event as an untagged notification (legacy stdio delivery).+legacyEventNotification :: ChangeEvent -> JsonRpcNotification+legacyEventNotification event =+  let (method, extra) = eventBody event+  in makeNotification method $ if null extra then Nothing else Just (object extra)++-- | The graceful-closure response a server sends when it ends a+-- subscription on its own initiative (e.g. shutdown). Like every modern+-- result it carries the server identity alongside the subscription id.+closureResponse :: McpServerInfo -> RequestId -> JsonRpcResponse+closureResponse serverInfo subId = makeSuccessResponse subId $ object+  [ "resultType" .= ("complete" :: Text)+  , "_meta" .= object+      [ "io.modelcontextprotocol/subscriptionId" .= subId+      , "io.modelcontextprotocol/serverInfo" .= object+          [ "name" .= serverName serverInfo+          , "version" .= serverVersion serverInfo+          ]+      ]+  ]

@@ -22,7 +22,12 @@   , ResourcesListResponse(..)   , ResourcesReadRequest(..)   , ResourcesReadResponse(..)+  , ResourcesTemplatesListResponse(..) +    -- * Completion Protocol+  , CompleteRequest(..)+  , CompleteResponse(..)+     -- * Tools Protocol   , ToolsListRequest(..)   , ToolsListResponse(..)@@ -35,20 +40,27 @@     -- * Protocol Functions   , protocolVersion   , supportedVersions+  , modernVersions+  , allVersions   ) where  import           Data.Aeson+import           Data.Aeson.Types (Parser) import           Data.Map         (Map) import           Data.Text        (Text)+import qualified Data.Text        as T import           GHC.Generics     (Generic) import           MCP.Server.Types --- | The protocol revision the server advertises by default. Used as the--- fallback when a client proposes a version this library does not recognise.+-- | The newest /legacy/ (initialize-handshake) revision the server+-- advertises by default. Used as the fallback when an initializing client+-- proposes a version this library does not recognise — deliberately capped+-- at the newest legacy revision: a client that sends @initialize@ is legacy+-- by definition and must not be promised the stateless 2026-07-28 semantics. protocolVersion :: Text protocolVersion = "2025-11-25" --- | Date-versioned MCP revisions whose wire format for the basic+-- | Legacy (initialize-handshake) revisions whose wire format for the basic -- tool/resource/prompt operations this library implements is identical. -- The server echoes back any of these a client proposes (see -- 'MCP.Server.Handlers.validateProtocolVersion'), satisfying the spec@@ -63,7 +75,21 @@   , "2024-11-05"   ] +-- | Modern (stateless, per-request @_meta@) revisions this library+-- implements. Requests declaring one of these are served with modern+-- semantics: @resultType@, cacheability fields, and @serverInfo@ in result+-- @_meta@.+modernVersions :: [Text]+modernVersions =+  [ "2026-07-28"+  ] +-- | Every revision this library implements, newest first — what+-- @server\/discover@ and 'UnsupportedProtocolVersionError' report.+allVersions :: [Text]+allVersions = modernVersions ++ supportedVersions++ -- | Initialize request data InitializeRequest = InitializeRequest   { initProtocolVersion :: Text@@ -116,26 +142,6 @@ instance ToJSON PongResponse where   toJSON PongResponse = object [] --- | Message role for prompts-data MessageRole = RoleUser | RoleAssistant-  deriving (Show, Eq, Generic)--instance ToJSON MessageRole where-  toJSON RoleUser      = "user"-  toJSON RoleAssistant = "assistant"---- | Prompt message-data PromptMessage = PromptMessage-  { promptMessageRole    :: MessageRole-  , promptMessageContent :: Content-  } deriving (Show, Eq, Generic)--instance ToJSON PromptMessage where-  toJSON msg = object-    [ "role" .= promptMessageRole msg-    , "content" .= promptMessageContent msg-    ]- -- | Prompts list request data PromptsListRequest = PromptsListRequest   deriving (Show, Eq, Generic)@@ -216,6 +222,58 @@     [ "contents" .= resourcesReadContents resp     ] +-- | Resource templates list response+data ResourcesTemplatesListResponse = ResourcesTemplatesListResponse+  { resourcesTemplatesList :: [ResourceTemplateDefinition]+  } deriving (Show, Eq, Generic)++instance ToJSON ResourcesTemplatesListResponse where+  toJSON resp = object+    [ "resourceTemplates" .= resourcesTemplatesList resp+    ]++-- | Completion request (completion/complete)+data CompleteRequest = CompleteRequest+  { completeRef             :: CompletionRef+  , completeArgumentName    :: Text+  , completeArgumentValue   :: Text+  , completeContextArgs     :: Map Text Text+  } deriving (Show, Eq, Generic)++instance FromJSON CompleteRequest where+  parseJSON = withObject "CompleteRequest" $ \o -> do+    refObj <- o .: "ref"+    ref <- withObject "CompletionRef"+      (\r -> do+        refType <- r .: "type" :: Parser Text+        case refType of+          "ref/prompt"   -> CompletionRefPrompt <$> r .: "name"+          "ref/resource" -> CompletionRefResource <$> r .: "uri"+          _              -> fail $ "Unknown completion ref type: " ++ T.unpack refType)+      refObj+    argument <- o .: "argument"+    (name, value) <- withObject "argument"+      (\a -> (,) <$> a .: "name" <*> a .: "value")+      argument+    ctx <- o .:? "context"+    ctxArgs <- case ctx of+      Nothing -> pure mempty+      Just c  -> withObject "context" (\co -> co .:? "arguments" .!= mempty) c+    pure $ CompleteRequest ref name value ctxArgs++-- | Completion response+data CompleteResponse = CompleteResponse+  { completeResult :: CompletionResult+  } deriving (Show, Eq, Generic)++instance ToJSON CompleteResponse where+  toJSON (CompleteResponse res) = object+    [ "completion" .= object+        ([ "values" .= take 100 (completionValues res) ]+          ++ maybe [] (\t -> ["total" .= t]) (completionTotal res)+          ++ maybe [] (\h -> ["hasMore" .= h]) (completionHasMore res))+    ]+ -- | Tools list request data ToolsListRequest = ToolsListRequest   deriving (Show, Eq, Generic)@@ -246,15 +304,17 @@  -- | Tools call response (2025-06-18 enhanced) data ToolsCallResponse = ToolsCallResponse-  { toolsCallContent :: [Content]-  , toolsCallIsError :: Maybe Bool-  , toolsCallMeta :: Maybe Value  -- New _meta field for structured output+  { toolsCallContent           :: [Content]+  , toolsCallIsError           :: Maybe Bool+  , toolsCallStructuredContent :: Maybe Value  -- ^ structuredContent (2025-06-18+)+  , toolsCallMeta              :: Maybe Value   } deriving (Show, Eq, Generic)  instance ToJSON ToolsCallResponse where   toJSON resp = object $     [ "content" .= toolsCallContent resp     ] ++ maybe [] (\e -> ["isError" .= e]) (toolsCallIsError resp)+      ++ maybe [] (\s -> ["structuredContent" .= s]) (toolsCallStructuredContent resp)       ++ maybe [] (\m -> ["_meta" .= m]) (toolsCallMeta resp)  -- | List changed notification

@@ -6,12 +6,25 @@     HttpConfig(..)   , transportRunHttp   , defaultHttpConfig++    -- * Request validation (exposed for testing)+  , BodyPeek(..)+  , peekBody+  , peekIsModern+  , validateRequestHeaders+  , decodeSentinel   ) where -import           Control.Monad            (when)+import           Control.Concurrent.STM   (atomically, check, orElse,+                                           readTChan, readTVar, registerDelay)+import           Control.Monad            (forever, when) import           Data.Aeson import qualified Data.Aeson.KeyMap        as KM+import           Data.Aeson.Types         (parseEither)+import qualified Data.ByteString.Base64   as B64+import qualified Data.ByteString.Builder  as B import qualified Data.ByteString.Lazy     as BSL+import           Data.Maybe               (isJust) import           Data.String              (IsString (fromString)) import           Data.Text                (Text) import qualified Data.Text                as T@@ -24,7 +37,9 @@  import           MCP.Server.Handlers import           MCP.Server.JsonRpc-import           MCP.Server.Protocol (protocolVersion, supportedVersions)+import           MCP.Server.Notifications+import           MCP.Server.Protocol (allVersions, modernVersions,+                                      supportedVersions) import           MCP.Server.Types  -- | HTTP transport configuration following the MCP Streamable HTTP specification@@ -45,6 +60,25 @@       --   handler 'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects       --   the request with @401@. Validation and principal assignment are left       --   entirely to the caller.+  , httpAllowedOrigins :: Maybe [Text]+      -- ^ Origin-validation policy (DNS-rebinding protection; the MCP+      --   Streamable HTTP spec requires servers to validate the @Origin@+      --   header). @'Just' origins@ rejects any request whose @Origin@ header+      --   is present but not in the list with @403@, and echoes the allowed+      --   origin in CORS headers instead of @*@. Requests without an @Origin@+      --   header (non-browser clients) are always allowed. 'Nothing' disables+      --   the check — only appropriate when the server is not reachable from+      --   a browser (e.g. bound to localhost for CLI clients).+  , httpCacheHints :: CacheHints+      -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read+      --   results.+  , httpNotifications :: Maybe NotificationSource+      -- ^ When configured, @subscriptions\/listen@ (2026-07-28) is served as+      --   a long-lived SSE stream delivering the change notifications the+      --   client opted into, and the @listChanged@\/@subscribe@ capabilities+      --   are advertised to modern clients. Legacy HTTP clients have no+      --   delivery channel (the deprecated GET SSE stream is not offered),+      --   so legacy @initialize@ does not advertise them.   }  -- | Default HTTP configuration (authentication disabled).@@ -55,15 +89,22 @@   , httpEndpoint = "/mcp"   , httpVerbose = False   , httpAuthorize = Nothing+  , httpAllowedOrigins = Nothing+  , httpCacheHints = defaultCacheHints+  , httpNotifications = Nothing   }  -- | Helper for conditional logging logVerbose :: HttpConfig -> String -> IO () logVerbose config msg = when (httpVerbose config) $ hPutStrLn stderr msg +-- | Whether a notification source is configured.+httpHasNotifications :: HttpConfig -> Bool+httpHasNotifications = isJust . httpNotifications + -- | Transport-specific implementation for HTTP-transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()+transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunHttp config serverInfo handlers = do   let settings = Warp.setHost (fromString $ httpHost config) $                  Warp.setPort (httpPort config) $@@ -73,34 +114,65 @@   Warp.runSettings settings (mcpApplication config serverInfo handlers)  -- | WAI Application for MCP over HTTP-mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Application-mcpApplication config serverInfo handlers req respond = do+mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> Wai.Application+mcpApplication config serverInfo handlers req respond0 = do   -- Log the request   logVerbose config $ "HTTP " ++ show (Wai.requestMethod req) ++ " " ++ T.unpack (TE.decodeUtf8 $ Wai.rawPathInfo req) -  -- Authenticate and obtain the caller's principal (if any) before anything-  -- else. CORS preflight requests are exempt: browsers never attach-  -- credentials to an OPTIONS preflight, and the preflight response is what-  -- tells the browser it may send the Authorization header at all.-  decision <- case httpAuthorize config of-    _ | Wai.requestMethod req == "OPTIONS"-               -> pure (Just Nothing)      -- CORS preflight: no credentials-    Nothing    -> pure (Just Nothing)      -- auth disabled: allowed, no principal-    Just check -> fmap (fmap Just) (check (bearerToken req))-  case decision of-    Nothing -> do-      logVerbose config "Request rejected by authorization callback"-      respond $ Wai.responseLBS-        status401-        [("Content-Type", "application/json"), ("WWW-Authenticate", "Bearer")]-        (encode $ object ["error" .= ("Unauthorized" :: Text)])-    Just principal -> do-      let ctx = ClientContext { clientToken = bearerToken req, clientPrincipal = principal }-      -- Check if this is our MCP endpoint-      if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config)-        then handleMcpRequest config serverInfo handlers ctx req respond-        else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found"+  let origin = lookup hOrigin (Wai.requestHeaders req)+      -- Every response carries exactly one Access-Control-Allow-Origin header:+      -- the validated request origin when a policy is configured, "*"+      -- otherwise. When the value depends on the request origin, Vary: Origin+      -- keeps shared caches from serving one origin's response to another.+      corsHeaders = case (httpAllowedOrigins config, origin) of+        (Just _, Just o) -> [("Access-Control-Allow-Origin", o), ("Vary", "Origin")]+        _                -> [("Access-Control-Allow-Origin", "*")]+      addCors hs = corsHeaders+                 ++ filter ((/= "Access-Control-Allow-Origin") . fst) hs+      respond = respond0 . Wai.mapResponseHeaders addCors +  -- Origin validation first (DNS-rebinding protection, a MUST in the spec).+  if not (originAllowed config req)+    then do+      logVerbose config $ "Request rejected: disallowed Origin " ++ show origin+      respond0 $ Wai.responseLBS+        status403+        [("Content-Type", "application/json")]+        (encode $ object ["error" .= ("Origin not allowed" :: Text)])+    else do+      -- Authenticate and obtain the caller's principal (if any) before anything+      -- else. CORS preflight requests are exempt: browsers never attach+      -- credentials to an OPTIONS preflight, and the preflight response is what+      -- tells the browser it may send the Authorization header at all.+      decision <- case httpAuthorize config of+        _ | Wai.requestMethod req == "OPTIONS"+                   -> pure (Just Nothing)      -- CORS preflight: no credentials+        Nothing    -> pure (Just Nothing)      -- auth disabled: allowed, no principal+        Just authorize -> fmap (fmap Just) (authorize (bearerToken req))+      case decision of+        Nothing -> do+          logVerbose config "Request rejected by authorization callback"+          respond $ Wai.responseLBS+            status401+            [("Content-Type", "application/json"), ("WWW-Authenticate", "Bearer")]+            (encode $ object ["error" .= ("Unauthorized" :: Text)])+        Just principal -> do+          let ctx = anonymousContext { clientToken = bearerToken req, clientPrincipal = principal }+          -- Check if this is our MCP endpoint+          if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config)+            then handleMcpRequest config serverInfo handlers ctx req respond+            else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found"++-- | Whether the request passes the configured Origin policy: with no policy+-- everything passes; with a policy, a present Origin header must be in the+-- allow-list (absent Origin means a non-browser client and always passes).+originAllowed :: HttpConfig -> Wai.Request -> Bool+originAllowed config req = case httpAllowedOrigins config of+  Nothing      -> True+  Just allowed -> case lookup hOrigin (Wai.requestHeaders req) of+    Nothing -> True+    Just o  -> TE.decodeUtf8With lenientDecode o `elem` allowed+ -- | The bearer token presented by a request, if any: the value following -- @Authorization: Bearer @. The scheme is matched case-insensitively per -- RFC 7235, and invalid UTF-8 in the header is replaced rather than thrown.@@ -113,121 +185,259 @@     else Nothing  -- | Handle MCP requests according to Streamable HTTP specification-handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived handleMcpRequest config serverInfo handlers ctx req respond = do-  -- Read the POST body up front so we can identify the `initialize` request:-  -- it negotiates the protocol version in its *body*, so (per the Streamable-  -- HTTP spec, which scopes the MCP-Protocol-Version header to "subsequent-  -- requests") it is exempt from the header check. For any other request a-  -- *missing* header is accepted, while a *present but unsupported* one is-  -- rejected with 400.+  -- Read the POST body up front: the request era and header validation both+  -- depend on it. A body declaring a modern protocol revision in _meta gets+  -- the 2026-07-28 header validation (header/body match, Mcp-Method,+  -- Mcp-Name); a legacy body keeps the relaxed pre-2026 rules, where+  -- `initialize` is exempt (it negotiates in the body), a missing+  -- MCP-Protocol-Version header is accepted, and a present-but-unsupported+  -- one is rejected with 400.   body <- if Wai.requestMethod req == "POST" then Wai.strictRequestBody req else pure ""-  if extractMethod body /= Just "initialize" && not (versionHeaderSupported req)-    then do-      logVerbose config "Request rejected: unsupported MCP-Protocol-Version header"-      respond $ Wai.responseLBS-        status400-        [("Content-Type", "application/json")]-        (encode $ object ["error" .= ("Unsupported protocol version. Supported versions: " <> T.intercalate ", " supportedVersions)])-    else-        case Wai.requestMethod req of-          -- GET requests for endpoint discovery-          "GET" -> do-            let discoveryResponse = object-                  [ "name" .= serverName serverInfo-                  , "version" .= serverVersion serverInfo-                  , "description" .= serverInstructions serverInfo-                  , "protocolVersion" .= protocolVersion-                  , "capabilities" .= object-                      [ "tools" .= object []-                      , "prompts" .= object []-                      , "resources" .= object []-                      ]-                  ]-            logVerbose config $ "Sending server discovery response: " ++ show discoveryResponse-            respond $ Wai.responseLBS-              status200-              [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]-              (encode discoveryResponse)+  let peek = peekBody body+      modern = peekIsModern peek+  case Wai.requestMethod req of+    -- POST requests for JSON-RPC messages+    "POST" ->+      case validateRequestHeaders req peek of+        Just err -> do+          logVerbose config $ "Request rejected: " ++ T.unpack (errorMessage err)+          respond $ Wai.responseLBS+            status400+            [("Content-Type", "application/json")]+            (encode $ makeErrorResponse (peekId peek) err)+        Nothing+          -- subscriptions/listen is transport-level: the response is a+          -- long-lived SSE stream, not a single JSON object+          | peekMethod peek == Just "subscriptions/listen"+          , Just src <- httpNotifications config+          -> handleSubscriptionsListen config src body respond+          | otherwise -> do+              logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)+              handleJsonRpcRequest config serverInfo handlers ctx modern body respond -          -- POST requests for JSON-RPC messages-          "POST" -> do-            logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)-            handleJsonRpcRequest config serverInfo handlers ctx body respond+    -- OPTIONS for CORS preflight+    "OPTIONS" -> respond $ Wai.responseLBS+      status200+      [ ("Access-Control-Allow-Methods", "POST, OPTIONS")+      , ("Access-Control-Allow-Headers", "Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name")+      ]+      "" -          -- OPTIONS for CORS preflight-          "OPTIONS" -> respond $ Wai.responseLBS-            status200-            [ ("Access-Control-Allow-Origin", "*")-            , ("Access-Control-Allow-Methods", "GET, POST, OPTIONS")-            , ("Access-Control-Allow-Headers", "Content-Type, Authorization, MCP-Protocol-Version")-            ]-            ""+    -- Everything else, including GET: the MCP endpoint only speaks+    -- JSON-RPC over POST (this library does not offer server-initiated+    -- SSE streams, and revision 2026-07-28 requires 405 for GET).+    _ -> respond $ Wai.responseLBS+      status405+      [("Content-Type", "text/plain"), ("Allow", "POST, OPTIONS")]+      "Method Not Allowed" -          -- Unsupported methods-          _ -> respond $ Wai.responseLBS-            status405-            [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")]-            "Method Not Allowed"+-- | The parts of a JSON-RPC body that header validation needs.+data BodyPeek = BodyPeek+  { peekMethod      :: Maybe Text+  , peekMetaVersion :: Maybe Text+  , peekName        :: Maybe Text  -- ^ params.name or params.uri+  , peekId          :: RequestId+  } --- | True unless the request carries a *present but unsupported*--- MCP-Protocol-Version header. A missing header is treated as acceptable, since--- the spec allows the server to assume a default protocol version in that case.-versionHeaderSupported :: Wai.Request -> Bool-versionHeaderSupported req =-  case lookup "MCP-Protocol-Version" (Wai.requestHeaders req) of-    Nothing -> True-    Just hv -> TE.decodeUtf8 hv `elem` supportedVersions+-- | Whether the body declares a modern (2026-07-28+) request.+peekIsModern :: BodyPeek -> Bool+peekIsModern peek =+  peekMetaVersion peek /= Nothing || peekMethod peek == Just "server/discover" --- | Peek at a JSON-RPC message body to read its @method@ (if present).-extractMethod :: BSL.ByteString -> Maybe Text-extractMethod body = case decode body of-  Just (Object o) -> case KM.lookup "method" o of-    Just (String m) -> Just m-    _               -> Nothing-  _ -> Nothing+peekBody :: BSL.ByteString -> BodyPeek+peekBody body = case decode body of+  Just (Object o) -> BodyPeek+    { peekMethod = case KM.lookup "method" o of+        Just (String m) -> Just m+        _               -> Nothing+    , peekMetaVersion = metaProtocolVersion (KM.lookup "params" o)+    , peekName = case KM.lookup "params" o of+        Just (Object p) -> case (KM.lookup "name" p, KM.lookup "uri" p) of+          (Just (String n), _) -> Just n+          (_, Just (String u)) -> Just u+          _                    -> Nothing+        _ -> Nothing+    , peekId = case KM.lookup "id" o of+        Just v  -> either (const RequestIdNull) id (parseEither parseJSON v)+        Nothing -> RequestIdNull+    }+  _ -> BodyPeek Nothing Nothing Nothing RequestIdNull +-- | Validate the request-metadata headers against the body. 'Nothing' means+-- the request may proceed; @'Just' err@ is answered with 400 and the given+-- JSON-RPC error.+--+-- Modern requests (body declares a protocol revision in @_meta@) follow the+-- 2026-07-28 rules: the MCP-Protocol-Version header must match the body's+-- declared revision, Mcp-Method must match the body method, and Mcp-Name+-- must match @params.name@/@params.uri@ for the three named methods+-- (@HeaderMismatch@, -32020); an undeclared revision yields+-- @UnsupportedProtocolVersionError@ (-32022).+--+-- Legacy requests keep the relaxed pre-2026 rules: only a+-- present-but-unsupported MCP-Protocol-Version header is rejected, and+-- @initialize@ is exempt entirely.+validateRequestHeaders :: Wai.Request -> BodyPeek -> Maybe JsonRpcError+validateRequestHeaders req peek = case peekMetaVersion peek of+  Just v+    | v `notElem` modernVersions -> Just (unsupportedVersionError v)+    | headerText "MCP-Protocol-Version" /= Just v ->+        Just $ headerMismatch $ "MCP-Protocol-Version header "+          <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "MCP-Protocol-Version")+          <> " and does not match body value '" <> v <> "'"+    | headerText "Mcp-Method" /= peekMethod peek ->+        Just $ headerMismatch $ "Mcp-Method header "+          <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "Mcp-Method")+          <> " and does not match body method"+    | needsName+    , (decodeSentinel <$> headerText "Mcp-Name") /= peekName peek ->+        Just $ headerMismatch $ "Mcp-Name header "+          <> maybe "is missing" (\h -> "value '" <> h <> "'") (headerText "Mcp-Name")+          <> " and does not match the body name/uri"+    | otherwise -> Nothing+  Nothing+    | peekMethod peek /= Just "initialize"+    , Just hv <- headerText "MCP-Protocol-Version"+    , hv `notElem` supportedVersions ++ modernVersions ->+        Just $ JsonRpcError+          { errorCode = -32600+          , errorMessage = "Unsupported protocol version. Supported versions: "+              <> T.intercalate ", " allVersions+          , errorData = Nothing+          }+    | otherwise -> Nothing+  where+    headerText name =+      TE.decodeUtf8With lenientDecode <$> lookup name (Wai.requestHeaders req)+    needsName = peekMethod peek `elem` map Just ["tools/call", "resources/read", "prompts/get"]+    headerMismatch msg = JsonRpcError+      { errorCode = -32020+      , errorMessage = "Header mismatch: " <> msg+      , errorData = Nothing+      }++-- | Decode the @=?base64?...?=@ sentinel encoding the 2026-07-28 transport+-- uses for header values that cannot be represented in plain ASCII. Values+-- not wrapped in the sentinel (or with invalid base64) pass through as-is.+decodeSentinel :: Text -> Text+decodeSentinel t+  | Just inner <- T.stripPrefix "=?base64?" t >>= T.stripSuffix "?=" =+      case B64.decode (TE.encodeUtf8 inner) of+        Right bs -> TE.decodeUtf8With lenientDecode bs+        Left _   -> t+  | otherwise = t++-- | Serve a subscriptions/listen request (2026-07-28): a long-lived SSE+-- stream that first acknowledges the subscription and then delivers exactly+-- the notification types the client opted into, tagged with the+-- subscription id. Closing the stream is the client's cancellation signal;+-- periodic SSE comments keep intermediaries from timing the stream out.+handleSubscriptionsListen :: HttpConfig -> NotificationSource -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleSubscriptionsListen config src body respond =+  case eitherDecode body :: Either String JsonRpcRequest of+    Left err -> do+      hPutStrLn stderr $ "subscriptions/listen parse error: " ++ err+      respond $ Wai.responseLBS+        status400+        [("Content-Type", "application/json")]+        (encode $ makeErrorResponse RequestIdNull $ JsonRpcError+          { errorCode = -32600+          , errorMessage = "Invalid Request"+          , errorData = Nothing+          })+    Right req -> do+      let subId = requestId req+          notifFilter = parseNotificationFilter (requestParams req)+      logVerbose config $ "Opening subscription stream " ++ show subId+      respond $ Wai.responseStream+        status200+        [ ("Content-Type", "text/event-stream")+        , ("Cache-Control", "no-cache")+        , ("X-Accel-Buffering", "no")+        ]+        $ \write flush -> do+          chan <- atomically $ subscribeEvents src+          let sendJson v = do+                write $ B.lazyByteString $ "data: " <> encode v <> "\n\n"+                flush+          sendJson $ toJSON $ acknowledgedNotification subId notifFilter+          forever $ do+            keepAlive <- registerDelay 25000000  -- 25s+            next <- atomically $+              (Just <$> readTChan chan)+                `orElse` (readTVar keepAlive >>= check >> pure Nothing)+            case next of+              Just event+                | filterAccepts notifFilter event ->+                    sendJson $ toJSON $ eventNotification subId event+                | otherwise -> pure ()+              Nothing -> do+                write $ B.byteString ": keep-alive\n\n"+                flush+ -- | Handle JSON-RPC request from HTTP body-handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleJsonRpcRequest config serverInfo handlers ctx body respond = do+handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleJsonRpcRequest config serverInfo handlers ctx modern body respond = do   case eitherDecode body of     Left err -> do       hPutStrLn stderr $ "JSON parse error: " ++ err       respond $ Wai.responseLBS         status400         [("Content-Type", "application/json")]-        (encode $ object ["error" .= ("Invalid JSON" :: Text)])+        (encode $ makeErrorResponse RequestIdNull $ JsonRpcError+          { errorCode = -32700+          , errorMessage = "Parse error"+          , errorData = Nothing+          }) -    Right jsonValue -> handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond+    Right jsonValue -> handleSingleJsonRpc config serverInfo handlers ctx modern jsonValue respond  -- | Handle a single JSON-RPC message-handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond = do+handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleSingleJsonRpc config serverInfo handlers ctx modern jsonValue respond = do   case parseJsonRpcMessage jsonValue of     Left err -> do       hPutStrLn stderr $ "JSON-RPC parse error: " ++ err       respond $ Wai.responseLBS         status400         [("Content-Type", "application/json")]-        (encode $ object ["error" .= ("Invalid JSON-RPC" :: Text)])+        (encode $ makeErrorResponse RequestIdNull $ JsonRpcError+          { errorCode = -32600+          , errorMessage = "Invalid Request"+          , errorData = Nothing+          })      Right message -> do       logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message)-      maybeResponse <- handleMcpMessage serverInfo handlers ctx message+      let notifSupport = NotificationSupport+            { supportsLegacyPush = False  -- no legacy HTTP delivery channel+            , supportsListen = httpHasNotifications config+            }+      maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config) notifSupport handlers ctx message        case maybeResponse of         Just responseMsg -> do           let responseJson = encode $ encodeJsonRpcMessage responseMsg           logVerbose config $ "Sending HTTP response for: " ++ show (getMessageSummary message)           respond $ Wai.responseLBS-            status200-            [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]+            (statusForResponse modern responseMsg)+            [("Content-Type", "application/json")]             responseJson          Nothing -> do           logVerbose config $ "No response needed for: " ++ show (getMessageSummary message)-          -- For notifications, return 200 with empty JSON object (per MCP spec)-          respond $ Wai.responseLBS-            status200-            [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]-            "{}"+          -- Accepted notification: 202 with no body, per the Streamable HTTP spec+          respond $ Wai.responseLBS status202 [] ""++-- | The HTTP status for a JSON-RPC response. Modern (2026-07-28) requests+-- map protocol-level failures onto HTTP statuses — 404 for an unknown RPC+-- method, 400 for an unsupported protocol version — so era-probing clients+-- can distinguish them; legacy requests always get 200 as before.+statusForResponse :: Bool -> JsonRpcMessage -> Status+statusForResponse True (JsonRpcMessageResponse r) = case responseError r of+  Just e | errorCode e == -32601 -> status404+         | errorCode e == -32022 -> status400+  _ -> status200+statusForResponse _ _ = status200

@@ -4,51 +4,214 @@ module MCP.Server.Transport.Stdio   ( -- * STDIO Transport     transportRunStdio+  , transportRunStdioWithConfig+  , StdioConfig(..)+  , defaultStdioConfig   ) where -import           Control.Monad          (when)-import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Concurrent     (ThreadId, forkIO, killThread)+import           Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar,+                                          withMVar)+import           Control.Concurrent.STM (atomically, readTChan)+import           Control.Monad          (forever, unless, when) import           Data.Aeson+import qualified Data.Aeson.KeyMap      as KM+import           Data.Aeson.Types       (parseEither) import qualified Data.ByteString.Lazy   as BSL+import           Data.IORef             (newIORef, readIORef, writeIORef) import qualified Data.Text              as T import qualified Data.Text.Encoding     as TE import qualified Data.Text.IO           as TIO-import           System.IO              (hFlush, stderr, stdout)+import           System.IO              (hFlush, hIsEOF, hSetEncoding, stderr,+                                         stdin, stdout, utf8)  import           MCP.Server.Handlers import           MCP.Server.JsonRpc+import           MCP.Server.Notifications+import           MCP.Server.Protocol    (modernVersions) import           MCP.Server.Types +-- | STDIO transport configuration+data StdioConfig = StdioConfig+  { stdioVerbose :: Bool+    -- ^ When 'True', raw request bodies are logged to stderr. The default+    -- ('False') logs only message summaries (method and id): tool arguments+    -- may carry sensitive data that does not belong in logs.+  , stdioCacheHints :: CacheHints+    -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read+    -- results.+  , stdioNotifications :: Maybe NotificationSource+    -- ^ When configured, change notifications are delivered: modern clients+    -- via @subscriptions\/listen@, legacy clients as spontaneous+    -- notifications after @initialize@ — and the corresponding+    -- @listChanged@\/@subscribe@ capabilities are advertised.+  } --- | Transport-specific implementation for STDIO-import           System.IO              (hSetEncoding, utf8)+-- | Default STDIO configuration: summaries only, no raw bodies, no caching,+-- no notifications.+defaultStdioConfig :: StdioConfig+defaultStdioConfig = StdioConfig+  { stdioVerbose = False+  , stdioCacheHints = defaultCacheHints+  , stdioNotifications = Nothing+  } -transportRunStdio :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> m ()-transportRunStdio serverInfo handlers = do+-- | Run the STDIO transport with the default configuration.+transportRunStdio :: McpServerInfo -> McpServerHandlers -> IO ()+transportRunStdio = transportRunStdioWithConfig defaultStdioConfig++-- | Run the STDIO transport with the given configuration.+transportRunStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO ()+transportRunStdioWithConfig config serverInfo handlers = do   -- Ensure UTF-8 encoding for all handles-  liftIO $ do-    hSetEncoding stderr utf8-    hSetEncoding stdout utf8-  loop-  where+  hSetEncoding stderr utf8+  hSetEncoding stdout utf8++  -- Subscription threads 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)])+  -- 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+        TIO.putStrLn $ TE.decodeUtf8 $ BSL.toStrict bytes+        hFlush stdout+      sendMessage msg = sendRaw $ encode $ encodeJsonRpcMessage msg+      sendResponse resp = sendRaw $ encode $ toJSON (resp :: JsonRpcResponse)+      sendNotification notif = sendRaw $ encode $ toJSON (notif :: JsonRpcNotification)++      notifSupport = case stdioNotifications config of+        Nothing -> noNotificationSupport+        Just _  -> NotificationSupport { supportsLegacyPush = True, supportsListen = True }++  -- Legacy delivery: push untagged notifications to a client that completed+  -- the initialize handshake (which is when the capability was advertised).+  case stdioNotifications config of+    Nothing  -> pure ()+    Just src -> do+      chan <- atomically $ subscribeEvents src+      _ <- forkIO $ forever $ do+        event <- atomically $ readTChan chan+        ready <- readIORef legacyReady+        when ready $ sendNotification $ legacyEventNotification event+      pure ()++  let+    -- Open a subscriptions/listen stream: acknowledge, then deliver+    -- matching events tagged with the subscription id until cancelled.+    -- A listen reusing an already-open subscription id replaces the old+    -- stream (otherwise the shadowed writer would leak until EOF).+    openSubscription src req = do+      let subId = requestId req+          notifFilter = parseNotificationFilter (requestParams req)+      _ <- cancelSubscription subId+      chan <- atomically $ subscribeEvents src+      sendNotification $ acknowledgedNotification subId notifFilter+      tid <- forkIO $ forever $ do+        event <- atomically $ readTChan chan+        when (filterAccepts notifFilter event) $+          sendNotification $ eventNotification subId event+      modifyMVar_ subsVar (pure . ((subId, tid) :))+      logLine $ "Opened subscription " <> T.pack (show subId)++    cancelSubscription cancelledId = do+      subs <- readMVar subsVar+      case lookup cancelledId subs of+        Nothing  -> pure False+        Just tid -> do+          killThread tid+          modifyMVar_ subsVar (pure . filter ((/= cancelledId) . fst))+          logLine $ "Cancelled subscription " <> T.pack (show cancelledId)+          pure True++    -- Server-side teardown at EOF: graceful closure for every open stream+    closeAllSubscriptions = do+      subs <- readMVar subsVar+      mapM_ (\(subId, tid) -> do+                killThread tid+                sendResponse $ closureResponse serverInfo subId)+            subs++    handleParsed message = case message of+      -- subscriptions/listen is transport-level: the stream outlives the+      -- request. Only intercept when a source is configured and the+      -- declared revision (if any) is one we implement — otherwise fall+      -- through for the ordinary -32601 / -32022 answer.+      JsonRpcMessageRequest req+        | requestMethod req == "subscriptions/listen"+        , Just src <- stdioNotifications config+        , maybe True (`elem` modernVersions) (metaProtocolVersion (requestParams req))+        -> openSubscription src req++      -- notifications/cancelled referencing an open subscription tears it+      -- down (no response, per the cancellation rules)+      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)++      _ -> do+        -- The client's initialized notification is the legacy ready signal:+        -- the lifecycle forbids server notifications before it arrives, and+        -- it only arrives after the client accepted a successful handshake+        -- response (so failed initializes never enable pushes).+        case message of+          JsonRpcMessageNotification n+            | notificationMethod n == "notifications/initialized" ->+                writeIORef legacyReady True+          _ -> pure ()+        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))+     loop = do-      input <- liftIO TIO.getLine-      when (not $ T.null $ T.strip input) $ do-        -- Use TIO.hPutStrLn for UTF-8 output-        liftIO $ TIO.hPutStrLn stderr $ "Received request: " <> input-        case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of-          Left err -> liftIO $ TIO.hPutStrLn stderr $ "Parse error: " <> T.pack err-          Right jsonValue -> do-            case parseJsonRpcMessage jsonValue of-              Left err -> liftIO $ TIO.hPutStrLn stderr $ "JSON-RPC parse error: " <> T.pack err-              Right message -> do-                liftIO $ TIO.hPutStrLn stderr $ "Processing message: " <> T.pack (show (getMessageSummary message))-                response <- handleMcpMessage serverInfo handlers (ClientContext Nothing Nothing) message-                case response of-                  Just responseMsg -> do-                    liftIO $ TIO.hPutStrLn stderr $ "Sending response for: " <> T.pack (show (getMessageSummary message))-                    let responseText = TE.decodeUtf8 $ BSL.toStrict $ encode $ encodeJsonRpcMessage responseMsg-                    liftIO $ TIO.putStrLn responseText-                    liftIO $ hFlush stdout-                  Nothing -> liftIO $ TIO.hPutStrLn stderr $ "No response needed for: " <> T.pack (show (getMessageSummary message))-        loop+      eof <- hIsEOF stdin+      if eof+        then do+          closeAllSubscriptions+          logLine "stdin closed - shutting down"+        else do+          input <- TIO.getLine+          unless (T.null $ T.strip input) $ do+            logVerbose $ "Received request: " <> input+            case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of+              Left err -> do+                logLine $ "Parse error: " <> T.pack err+                sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError+                  { errorCode = -32700+                  , errorMessage = "Parse error"+                  , errorData = Nothing+                  }+              Right jsonValue ->+                case parseJsonRpcMessage jsonValue of+                  Left err -> do+                    logLine $ "JSON-RPC parse error: " <> T.pack err+                    sendResponse $ makeErrorResponse RequestIdNull $ JsonRpcError+                      { errorCode = -32600+                      , errorMessage = "Invalid Request"+                      , errorData = Nothing+                      }+                  Right message -> do+                    logLine $ "Processing message: " <> T.pack (show (getMessageSummary message))+                    handleParsed message+          loop++  loop++-- | The request id referenced by a notifications/cancelled notification.+cancelledRequestId :: Maybe Value -> Maybe RequestId+cancelledRequestId params = do+  Object o <- params+  v <- KM.lookup "requestId" o+  either (const Nothing) Just (parseEither parseJSON v)

@@ -5,41 +5,70 @@   ( -- * Content Types     Content(..)   , ContentImageData(..)-  , ContentResourceData(..)+  , ContentAudioData(..)   , ResourceContent(..) -    -- * URI Utilities  +    -- * Handler Result Types+  , ToolResult(..)+  , toolResult+  , toolError+  , ToToolResult(..)+  , PromptResult(..)+  , ToPromptResult(..)+  , PromptMessage(..)+  , MessageRole(..)++    -- * URI Utilities   , parseURI   , URI      -- * Error Types   , Error(..) +    -- * Schema Types+  , Schema(..)+  , SchemaType(..)+  , schema+  , describedSchema+     -- * Definition Types   , PromptDefinition(..)   , ResourceDefinition(..)+  , ResourceTemplateDefinition(..)   , ToolDefinition(..)   , ArgumentDefinition(..)-  , InputSchemaDefinition(..)-  , InputSchemaDefinitionProperty(..) +    -- * Completion Types+  , CompletionRef(..)+  , CompletionResult(..)+  , completionResult+     -- * Server Types   , McpServerInfo(..)   , McpServerHandlers(..)+  , noHandlers   , ClientContext(..)+  , anonymousContext+  , CacheHints(..)+  , defaultCacheHints+  , NotificationSupport(..)+  , noNotificationSupport   , ServerCapabilities(..)   , PromptCapabilities(..)   , ResourceCapabilities(..)   , ToolCapabilities(..)+  , CompletionCapabilities(..)   , LoggingCapabilities(..) -    -- * Request/Response Types+    -- * Handler Types   , PromptListHandler   , PromptGetHandler   , ResourceListHandler   , ResourceReadHandler+  , ResourceTemplateListHandler   , ToolListHandler   , ToolCallHandler+  , CompletionHandler      -- * Basic Types   , PromptName@@ -50,8 +79,10 @@  import           Data.Aeson import           Data.Aeson.Key   (fromText)-import           Data.Aeson.Types (Parser)-import           Data.Maybe       (catMaybes)+import qualified Data.Aeson.KeyMap as KM+import           Data.Aeson.Types (Pair, Parser)+import           Data.Map         (Map)+import           Data.Maybe       (catMaybes, listToMaybe) import           Data.Text        (Text) import qualified Data.Text        as T import           GHC.Generics     (Generic)@@ -66,7 +97,11 @@ data Content   = ContentText Text   | ContentImage ContentImageData-  | ContentResource ContentResourceData+  | ContentAudio ContentAudioData+  | ContentEmbeddedResource ResourceContent+    -- ^ A resource embedded into the result, carrying its full contents+  | ContentResourceLink ResourceDefinition+    -- ^ A reference to a resource the client can read separately   deriving (Show, Eq, Generic)  instance ToJSON Content where@@ -79,13 +114,19 @@     , "data" .= contentImageData img     , "mimeType" .= contentImageMimeType img     ]-  toJSON (ContentResource res) = object+  toJSON (ContentAudio audio) = object+    [ "type" .= ("audio" :: Text)+    , "data" .= contentAudioData audio+    , "mimeType" .= contentAudioMimeType audio+    ]+  toJSON (ContentEmbeddedResource res) = object     [ "type" .= ("resource" :: Text)-    , "resource" .= object-        [ "uri" .= contentResourceUri res-        , "mimeType" .= contentResourceMimeType res-        ]+    , "resource" .= res     ]+  toJSON (ContentResourceLink def) =+    case toJSON def of+      Object o -> Object (KM.insert "type" (String "resource_link") o)+      other    -> other  instance FromJSON Content where   parseJSON = withObject "Content" $ \o -> do@@ -96,21 +137,22 @@         imgData <- o .: "data"         mimeType <- o .: "mimeType"         return $ ContentImage $ ContentImageData imgData mimeType-      "resource" -> do-        res <- o .: "resource"-        uri <- res .: "uri"-        mimeType <- res .:? "mimeType"-        return $ ContentResource $ ContentResourceData uri mimeType+      "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  data ContentImageData = ContentImageData-  { contentImageData     :: Text+  { contentImageData     :: Text  -- ^ base64-encoded image data   , contentImageMimeType :: Text   } deriving (Show, Eq, Generic) -data ContentResourceData = ContentResourceData-  { contentResourceUri      :: URI-  , contentResourceMimeType :: Maybe Text+data ContentAudioData = ContentAudioData+  { contentAudioData     :: Text  -- ^ base64-encoded audio data+  , contentAudioMimeType :: Text   } deriving (Show, Eq, Generic)  -- | Resource content compliant with MCP specification@@ -154,6 +196,115 @@           (Nothing, Just blob) -> return $ ResourceBlob uri mimeType blob           _ -> fail "ResourceContent must have either 'text' or 'blob' field" +-- | Message role for prompts+data MessageRole = RoleUser | RoleAssistant+  deriving (Show, Eq, Generic)++instance ToJSON MessageRole where+  toJSON RoleUser      = "user"+  toJSON RoleAssistant = "assistant"++-- | Prompt message+data PromptMessage = PromptMessage+  { promptMessageRole    :: MessageRole+  , promptMessageContent :: Content+  } deriving (Show, Eq, Generic)++instance ToJSON PromptMessage where+  toJSON msg = object+    [ "role" .= promptMessageRole msg+    , "content" .= promptMessageContent msg+    ]++-- | The full result of a tool call.+--+-- Tool /execution/ failures belong in the result with 'toolResultIsError'+-- set (so the model can see what went wrong and react); JSON-RPC errors are+-- reserved for protocol-level failures such as unknown tools or malformed+-- arguments.+data ToolResult = ToolResult+  { toolResultContent    :: [Content]+  , toolResultStructured :: Maybe Value  -- ^ structuredContent (2025-06-18+)+  , toolResultIsError    :: Bool+  , toolResultMeta       :: Maybe Value+  } deriving (Show, Eq, Generic)++-- | A successful tool result with the given content blocks.+toolResult :: [Content] -> ToolResult+toolResult content = ToolResult+  { toolResultContent = content+  , toolResultStructured = Nothing+  , toolResultIsError = False+  , toolResultMeta = Nothing+  }++-- | A failed tool execution: the message is reported to the model with+-- @isError: true@ rather than as a JSON-RPC error.+toolError :: Text -> ToolResult+toolError msg = (toolResult [ContentText msg]) { toolResultIsError = True }++-- | Types a tool handler may return. Returning plain 'Content' (or 'Text')+-- keeps simple handlers simple; return a full 'ToolResult' for multiple+-- content blocks, structured content, or execution errors.+class ToToolResult a where+  toToolResult :: a -> ToolResult++instance ToToolResult ToolResult where+  toToolResult = id++instance ToToolResult Content where+  toToolResult c = toolResult [c]++-- | Concatenates content; a merged result is an error if any element is+-- ('toolResultIsError' is OR-ed), and the first present 'structuredContent'+-- and @_meta@ are kept.+instance ToToolResult a => ToToolResult [a] where+  toToolResult xs = ToolResult+    { toolResultContent = concatMap toolResultContent rs+    , toolResultStructured = firstJust (map toolResultStructured rs)+    , toolResultIsError = any toolResultIsError rs+    , toolResultMeta = firstJust (map toolResultMeta rs)+    }+    where rs = map toToolResult xs++instance ToToolResult Text where+  toToolResult = toToolResult . ContentText++firstJust :: [Maybe a] -> Maybe a+firstJust = listToMaybe . catMaybes++-- | The full result of a prompts/get request: an optional description and+-- a conversation of one or more messages.+data PromptResult = PromptResult+  { promptResultDescription :: Maybe Text+  , promptResultMessages    :: [PromptMessage]+  } deriving (Show, Eq, Generic)++-- | Types a prompt handler may return. Plain 'Content' (or 'Text') becomes a+-- single user message; return 'PromptResult' or @['PromptMessage']@ for+-- multi-message conversations or assistant roles.+class ToPromptResult a where+  toPromptResult :: a -> PromptResult++instance ToPromptResult PromptResult where+  toPromptResult = id++instance ToPromptResult PromptMessage where+  toPromptResult m = PromptResult Nothing [m]++-- | Concatenates messages and keeps the first present description.+instance ToPromptResult a => ToPromptResult [a] where+  toPromptResult xs = PromptResult+    (firstJust (map promptResultDescription rs))+    (concatMap promptResultMessages rs)+    where rs = map toPromptResult xs++instance ToPromptResult Content where+  toPromptResult c = toPromptResult (PromptMessage RoleUser c)++instance ToPromptResult Text where+  toPromptResult = toPromptResult . ContentText+ -- | MCP protocol errors data Error   = InvalidPromptName Text@@ -192,6 +343,53 @@       errorMessage (MethodNotFound msg) = "Method not found: " <> msg       errorMessage (InvalidParams msg) = "Invalid parameters: " <> msg +-- | A JSON Schema fragment: a shape plus an optional description.+data Schema = Schema+  { schemaDescription :: Maybe Text+  , schemaShape       :: SchemaType+  } deriving (Show, Eq, Generic)++-- | The shape of a JSON Schema fragment.+data SchemaType+  = SchemaString (Maybe [Text])+    -- ^ A string, optionally restricted to an enum of allowed values+  | SchemaInteger+  | SchemaNumber+  | SchemaBoolean+  | SchemaArray Schema+  | SchemaObject [(Text, Schema)] [Text]+    -- ^ Properties and the names of the required ones+  deriving (Show, Eq, Generic)++-- | A schema with no description.+schema :: SchemaType -> Schema+schema = Schema Nothing++-- | A schema with a description.+describedSchema :: Text -> SchemaType -> Schema+describedSchema desc = Schema (Just desc)++instance ToJSON Schema where+  toJSON (Schema desc shape) = object $+    typeFields shape ++ maybe [] (\d -> ["description" .= d]) desc+    where+      typeFields :: SchemaType -> [Pair]+      typeFields (SchemaString enumVals) =+        [ "type" .= ("string" :: Text) ]+        ++ maybe [] (\vs -> ["enum" .= vs]) enumVals+      typeFields SchemaInteger = [ "type" .= ("integer" :: Text) ]+      typeFields SchemaNumber  = [ "type" .= ("number" :: Text) ]+      typeFields SchemaBoolean = [ "type" .= ("boolean" :: Text) ]+      typeFields (SchemaArray items) =+        [ "type" .= ("array" :: Text)+        , "items" .= items+        ]+      typeFields (SchemaObject props req) =+        [ "type" .= ("object" :: Text)+        , "properties" .= object (map (\(k, v) -> fromText k .= v) props)+        , "required" .= req+        ]+ -- | Prompt definition (2025-06-18 enhanced) data PromptDefinition = PromptDefinition   { promptDefinitionName        :: Text@@ -225,12 +423,61 @@     maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def) ++     maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) +instance FromJSON ResourceDefinition where+  parseJSON = withObject "ResourceDefinition" $ \o -> ResourceDefinition+    <$> o .: "uri"+    <*> o .: "name"+    <*> o .:? "description"+    <*> o .:? "mimeType"+    <*> o .:? "title"++-- | Resource template definition: a parameterized resource identified by an+-- RFC 6570 URI template.+data ResourceTemplateDefinition = ResourceTemplateDefinition+  { resourceTemplateURITemplate :: Text+  , resourceTemplateName        :: Text+  , resourceTemplateDescription :: Maybe Text+  , resourceTemplateMimeType    :: Maybe Text+  , resourceTemplateTitle       :: Maybe Text+  } deriving (Show, Eq, Generic)++instance ToJSON ResourceTemplateDefinition where+  toJSON def = object $+    [ "uriTemplate" .= resourceTemplateURITemplate def+    , "name" .= resourceTemplateName def+    ] +++    maybe [] (\d -> ["description" .= d]) (resourceTemplateDescription def) +++    maybe [] (\m -> ["mimeType" .= m]) (resourceTemplateMimeType def) +++    maybe [] (\t -> ["title" .= t]) (resourceTemplateTitle def)++-- | What a completion request is completing an argument for.+data CompletionRef+  = CompletionRefPrompt Text    -- ^ @ref/prompt@: a prompt, by name+  | CompletionRefResource Text  -- ^ @ref/resource@: a resource URI or URI template+  deriving (Show, Eq, Generic)++-- | Completion suggestions for an argument value.+data CompletionResult = CompletionResult+  { completionValues  :: [Text]      -- ^ Suggestions ranked by relevance (max 100 are sent)+  , completionTotal   :: Maybe Int   -- ^ Optional total number of matches+  , completionHasMore :: Maybe Bool  -- ^ Whether more results exist beyond 'completionValues'+  } deriving (Show, Eq, Generic)++-- | A completion result with just the given suggestions.+completionResult :: [Text] -> CompletionResult+completionResult vals = CompletionResult+  { completionValues = vals+  , completionTotal = Nothing+  , completionHasMore = Nothing+  }+ -- | Tool definition (2025-06-18 enhanced) data ToolDefinition = ToolDefinition-  { toolDefinitionName        :: Text-  , toolDefinitionDescription :: Text-  , toolDefinitionInputSchema :: InputSchemaDefinition-  , toolDefinitionTitle       :: Maybe Text  -- New title field for human-friendly display+  { toolDefinitionName         :: Text+  , toolDefinitionDescription  :: Text+  , toolDefinitionInputSchema  :: Schema+  , toolDefinitionOutputSchema :: Maybe Schema+  , toolDefinitionTitle        :: Maybe Text  -- New title field for human-friendly display   } deriving (Show, Eq, Generic)  instance ToJSON ToolDefinition where@@ -238,7 +485,8 @@     [ "name" .= toolDefinitionName def     , "description" .= toolDefinitionDescription def     , "inputSchema" .= toolDefinitionInputSchema def-    ] ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def)+    ] ++ maybe [] (\s -> ["outputSchema" .= s]) (toolDefinitionOutputSchema def)+      ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def)  -- | Argument definition for prompts data ArgumentDefinition = ArgumentDefinition@@ -254,30 +502,6 @@     , "required" .= argumentDefinitionRequired def     ] --- | Input schema definition for tools-data InputSchemaDefinition = InputSchemaDefinitionObject-  { properties :: [(Text, InputSchemaDefinitionProperty)]-  , required   :: [Text]-  } deriving (Show, Eq, Generic)--instance ToJSON InputSchemaDefinition where-  toJSON (InputSchemaDefinitionObject props req) = object-    [ "type" .= ("object" :: Text)-    , "properties" .= object (map (\(k, v) -> fromText k .= v) props)-    , "required" .= req-    ]--data InputSchemaDefinitionProperty = InputSchemaDefinitionProperty-  { propertyType        :: Text-  , propertyDescription :: Text-  } deriving (Show, Eq, Generic)--instance ToJSON InputSchemaDefinitionProperty where-  toJSON prop = object-    [ "type" .= propertyType prop-    , "description" .= propertyDescription prop-    ]- -- | Server information data McpServerInfo = McpServerInfo   { serverName         :: Text@@ -315,6 +539,13 @@     [ fmap ("listChanged" .=) (toolListChanged caps)     ] +data CompletionCapabilities = CompletionCapabilities+  { -- No sub-capabilities defined+  } deriving (Show, Eq, Generic)++instance ToJSON CompletionCapabilities where+  toJSON _ = object []+ data LoggingCapabilities = LoggingCapabilities   { -- No specific sub-capabilities for logging yet   } deriving (Show, Eq, Generic)@@ -324,10 +555,11 @@  -- | Server capabilities data ServerCapabilities = ServerCapabilities-  { capabilityPrompts   :: Maybe PromptCapabilities-  , capabilityResources :: Maybe ResourceCapabilities-  , capabilityTools     :: Maybe ToolCapabilities-  , capabilityLogging   :: Maybe LoggingCapabilities+  { capabilityPrompts     :: Maybe PromptCapabilities+  , capabilityResources   :: Maybe ResourceCapabilities+  , capabilityTools       :: Maybe ToolCapabilities+  , capabilityCompletions :: Maybe CompletionCapabilities+  , capabilityLogging     :: Maybe LoggingCapabilities   } deriving (Show, Eq, Generic)  instance ToJSON ServerCapabilities where@@ -335,6 +567,7 @@     [ fmap ("prompts" .=) (capabilityPrompts caps)     , fmap ("resources" .=) (capabilityResources caps)     , fmap ("tools" .=) (capabilityTools caps)+    , fmap ("completions" .=) (capabilityCompletions caps)     , fmap ("logging" .=) (capabilityLogging caps)     ] @@ -347,22 +580,108 @@                                     --   the transport's authorization callback                                     --   (e.g. a role). 'Nothing' when                                     --   authentication is disabled.+  , clientProtocolVersion :: Maybe Text+      -- ^ The protocol revision the request declared in its @_meta@+      --   (modern, 2026-07-28+ clients). 'Nothing' for legacy clients that+      --   negotiated via @initialize@.+  , clientInfo :: Maybe Value+      -- ^ The client's self-reported identity from request @_meta@+      --   (modern clients), for display/logging only.+  , clientCapabilities :: Maybe Value+      -- ^ The client's declared capabilities from request @_meta@+      --   (modern clients).   } deriving (Show, Eq) +-- | A context carrying no transport- or request-level information: what+-- handlers see for legacy stdio requests.+anonymousContext :: ClientContext+anonymousContext = ClientContext+  { clientToken = Nothing+  , clientPrincipal = Nothing+  , clientProtocolVersion = Nothing+  , clientInfo = Nothing+  , clientCapabilities = Nothing+  }++-- | Cacheability hints stamped onto modern (2026-07-28+) list/read results,+-- which require @ttlMs@ and @cacheScope@ fields.+data CacheHints = CacheHints+  { cacheTtlMs       :: Int   -- ^ Freshness hint in milliseconds.+  , cacheScopePublic :: Bool  -- ^ 'True' allows shared intermediaries to+                              --   cache the response (@\"public\"@);+                              --   'False' is @\"private\"@.+  } deriving (Show, Eq)++-- | Conservative defaults: no caching (@ttlMs = 0@), private scope.+defaultCacheHints :: CacheHints+defaultCacheHints = CacheHints+  { cacheTtlMs = 0+  , cacheScopePublic = False+  }++-- | What change-notification delivery the serving transport offers, which+-- decides the @listChanged@\/@subscribe@ capabilities each era advertises.+data NotificationSupport = NotificationSupport+  { supportsLegacyPush :: Bool+      -- ^ The transport can push unsolicited notifications to legacy+      --   (initialize-handshake) clients — true for stdio with a configured+      --   notification source; never for HTTP (this library dropped the+      --   deprecated GET SSE stream legacy delivery relied on).+  , supportsListen :: Bool+      -- ^ @subscriptions\/listen@ (2026-07-28) is served.+  } deriving (Show, Eq)++-- | No notification delivery at all: nothing extra is advertised.+noNotificationSupport :: NotificationSupport+noNotificationSupport = NotificationSupport+  { supportsLegacyPush = False+  , supportsListen = False+  }+ -- | Handler type definitions. Every handler receives the request's -- 'ClientContext' as its first argument.-type PromptListHandler m = ClientContext -> m [PromptDefinition]-type PromptGetHandler m = ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+--+-- Prompt arguments are string-valued per the MCP specification; tool+-- arguments are full JSON values.+type PromptListHandler = ClientContext -> IO [PromptDefinition]+type PromptGetHandler = ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) -type ResourceListHandler m = ClientContext -> m [ResourceDefinition]-type ResourceReadHandler m = ClientContext -> URI -> m (Either Error ResourceContent)+type ResourceListHandler = ClientContext -> IO [ResourceDefinition]+type ResourceReadHandler = ClientContext -> URI -> IO (Either Error ResourceContent)+type ResourceTemplateListHandler = ClientContext -> IO [ResourceTemplateDefinition] -type ToolListHandler m = ClientContext -> m [ToolDefinition]-type ToolCallHandler m = ClientContext -> ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+type ToolListHandler = ClientContext -> IO [ToolDefinition]+type ToolCallHandler = ClientContext -> ToolName -> Map Text Value -> IO (Either Error ToolResult) +-- | Completion handler: given what is being completed ('CompletionRef'), the+-- argument name, the partial value typed so far, and any already-resolved+-- sibling arguments, produce ranked suggestions.+type CompletionHandler = ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult)+ -- | Server handlers-data McpServerHandlers m = McpServerHandlers-  { prompts   :: Maybe (PromptListHandler m, PromptGetHandler m)-  , resources :: Maybe (ResourceListHandler m, ResourceReadHandler m)-  , tools     :: Maybe (ToolListHandler m, ToolCallHandler m)+data McpServerHandlers = McpServerHandlers+  { prompts           :: Maybe (PromptListHandler, PromptGetHandler)+  , resources         :: Maybe (ResourceListHandler, ResourceReadHandler)+  , resourceTemplates :: Maybe ResourceTemplateListHandler+      -- ^ Parameterized resources (@resources\/templates\/list@). Template+      --   URIs are read through the 'ResourceReadHandler' in 'resources' —+      --   configure both, or template reads have nothing to serve them+      --   (a templates-only configuration still answers @resources\/list@+      --   with an empty list so the advertised capability stays honest).+  , tools             :: Maybe (ToolListHandler, ToolCallHandler)+  , completions       :: Maybe CompletionHandler+      -- ^ Argument autocompletion (@completion\/complete@) for prompts and+      --   resource templates.+  }++-- | Handlers for a server that supports nothing — record-update the features+-- you provide, so adding new handler slots to the library does not break+-- your construction.+noHandlers :: McpServerHandlers+noHandlers = McpServerHandlers+  { prompts = Nothing+  , resources = Nothing+  , resourceTemplates = Nothing+  , tools = Nothing+  , completions = Nothing   }

@@ -8,8 +8,13 @@ import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation import qualified Spec.UnicodeHandling+import qualified Spec.GoldenWire+import qualified Spec.ModernEra import qualified Spec.ProtocolVersionNegotiation+import qualified Spec.Subscriptions+import qualified Spec.TemplatesCompletions import qualified Spec.ToolCallParsing+import qualified Spec.TypedArgs  main :: IO () main = hspec $ do@@ -19,5 +24,10 @@     Spec.SchemaValidation.spec     Spec.AdvancedDerivation.spec     Spec.UnicodeHandling.spec+    Spec.GoldenWire.spec+    Spec.ModernEra.spec     Spec.ProtocolVersionNegotiation.spec+    Spec.Subscriptions.spec+    Spec.TemplatesCompletions.spec     Spec.ToolCallParsing.spec+    Spec.TypedArgs.spec

@@ -9,20 +9,21 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec+import TestHelpers import TestTypes import TestData  -- Generate advanced handlers for separate parameter types-testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)+testSeparateParamsToolHandlers :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) -testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)+testRecursiveToolHandlers :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) -testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)+testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) -testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)+testRecursiveToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions)  -- Helper functions for advanced testing@@ -35,17 +36,13 @@  assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO () assertSchemaHasProperties expectedProps toolDef = do-  case toolDefinitionInputSchema toolDef of-    InputSchemaDefinitionObject props _ ->-      let propNames = map fst props-      in all (`elem` propNames) expectedProps `shouldBe` True+  let propNames = map fst (schemaProps (toolDefinitionInputSchema toolDef))+  all (`elem` propNames) expectedProps `shouldBe` True -assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO ()+assertToolCallResult :: ToolCallHandler -> Text -> [(Text, Text)] -> Text -> IO () assertToolCallResult handler toolName args expectedContent = do-  result <- handler anonCtx toolName args-  case result of-    Right (ContentText content) -> content `shouldBe` expectedContent-    other -> expectationFailure $ "Expected ContentText but got: " ++ show other+  result <- handler anonCtx toolName (stringArgs args)+  result `shouldBeTextResult` expectedContent  assertToolHasDescription :: Text -> Text -> ToolDefinition -> IO () assertToolHasDescription toolName expectedDesc toolDef = do@@ -54,11 +51,9 @@  assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO () assertPropertyHasDescription propName expectedDesc toolDef = do-  case toolDefinitionInputSchema toolDef of-    InputSchemaDefinitionObject props _ ->-      case lookup propName props of-        Just prop -> propertyDescription prop `shouldBe` expectedDesc-        Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName+  case lookupProp propName toolDef of+    Just prop -> schemaDescription prop `shouldBe` Just expectedDesc+    Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName  spec :: Spec spec = describe "Advanced Template Haskell Derivation" $ do

@@ -9,40 +9,26 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec+import TestHelpers import TestTypes import TestData  -- Generate handlers using Template Haskell-testPromptHandlers :: (PromptListHandler IO, PromptGetHandler IO)+testPromptHandlers :: (PromptListHandler, PromptGetHandler) testPromptHandlers = $(derivePromptHandler ''TestPrompt 'handleTestPrompt) -testResourceHandlers :: (ResourceListHandler IO, ResourceReadHandler IO)+testResourceHandlers :: (ResourceListHandler, ResourceReadHandler) testResourceHandlers = $(deriveResourceHandler ''TestResource 'handleTestResource) -testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)+testToolHandlers :: (ToolListHandler, ToolCallHandler) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) --- Helper functions for common test patterns-shouldReturnContentText :: IO (Either Error Content) -> Text -> IO ()-shouldReturnContentText action expected = do-  result <- action-  case result of-    Right (ContentText content) -> content `shouldBe` expected-    other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other--shouldContainText :: IO (Either Error Content) -> Text -> IO ()-shouldContainText action expectedSubstring = do-  result <- action-  case result of-    Right (ContentText content) ->-      T.isInfixOf expectedSubstring content `shouldBe` True-    other -> expectationFailure $ "Expected ContentText containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other--testPromptCall :: PromptGetHandler IO -> Text -> [(Text, Text)] -> Text -> IO ()-testPromptCall handler name args expected =-  shouldReturnContentText (handler anonCtx name args) expected+testPromptCall :: PromptGetHandler -> Text -> [(Text, Text)] -> Text -> IO ()+testPromptCall handler name args expected = do+  result <- handler anonCtx name (promptArgsMap args)+  result `shouldBePromptText` expected -testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO ()+testResourceCall :: ResourceReadHandler -> String -> Text -> IO () testResourceCall handler uriString expected = do   case parseURI uriString of     Just uri -> do@@ -53,9 +39,10 @@         Left err -> expectationFailure $ "Expected success but got error: " ++ show err     Nothing -> expectationFailure $ "Failed to parse URI: " ++ uriString -testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO ()-testToolCall handler name args expected =-  shouldReturnContentText (handler anonCtx name args) expected+testToolCall :: ToolCallHandler -> Text -> [(Text, Text)] -> Text -> IO ()+testToolCall handler name args expected = do+  result <- handler anonCtx name (stringArgs args)+  result `shouldBeTextResult` expected  spec :: Spec spec = describe "Basic Template Haskell Derivation" $ do

@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}++-- | 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/@.+--+-- 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.+--+-- 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.+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 qualified Data.Text as T+import MCP.Server+import MCP.Server.Handlers (handleMcpMessage)+import MCP.Server.JsonRpc+import System.Directory (doesFileExist)+import System.Environment (lookupEnv)+import Test.Hspec++goldenServerInfo :: McpServerInfo+goldenServerInfo = McpServerInfo+  { serverName = "Golden Server"+  , serverVersion = "1.0.0"+  , serverInstructions = "Golden fixture server"+  }++-- Deterministic manual handlers (no Template Haskell): one prompt, one+-- resource, one happy tool, one failing tool.+goldenHandlers :: McpServerHandlers+goldenHandlers = noHandlers+  { prompts = Just (promptList, promptGet)+  , resources = Just (resourceList, resourceRead)+  , tools = Just (toolList, toolCall)+  }+  where+    promptList _ = pure+      [ PromptDefinition "greet" "Greet someone"+          [ArgumentDefinition "name" "Who to greet" True] Nothing+      ]+    promptGet _ name args = case name of+      "greet" -> pure $ Right $ PromptResult (Just "A greeting")+        [PromptMessage RoleUser (ContentText ("Hello, " <> Map.findWithDefault "?" "name" args <> "!"))]+      _ -> pure $ Left $ InvalidPromptName name++    resourceList _ = pure+      [ ResourceDefinition "resource://info" "info" (Just "Some info") (Just "text/plain") Nothing ]+    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"+          (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+        Just (String t) -> pure $ Right $ toolResult [ContentText ("echo: " <> t)]+        _               -> pure $ Left $ MissingRequiredParams "field 'text' is missing"+      "boom" -> pure $ Right $ toolError "kaboom"+      _      -> pure $ Left $ UnknownTool name++-- | '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.+extendedHandlers :: McpServerHandlers+extendedHandlers = goldenHandlers+  { resourceTemplates = Just $ \_ -> pure+      [ ResourceTemplateDefinition "resource://item/{itemId}" "item"+          (Just "An item") (Just "text/plain") Nothing+      ]+  , completions = Just $ \_ _ref _arg partial _ctx -> pure $ Right $+      completionResult (filter (T.isPrefixOf partial) ["alpha", "beta"])+  }++-- | (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\"}}")++  -- 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 <> "}}")+  ]++-- 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 <> "}}")+  ]++meta :: BSL.ByteString+meta = "\"_meta\":{\"io.modelcontextprotocol/protocolVersion\":\"2026-07-28\",\"io.modelcontextprotocol/clientInfo\":{\"name\":\"golden-client\",\"version\":\"1.0\"},\"io.modelcontextprotocol/clientCapabilities\":{}}"++-- 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 <> "}}")+  ]++runCase :: NotificationSupport -> McpServerHandlers -> BSL.ByteString -> IO Value+runCase support handlers 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+  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+    accept <- lookupEnv "GOLDEN_ACCEPT"+    if not exists && accept /= Nothing+      then BSL.writeFile path (encode actual)+      else do+        fixtureBytes <- BSL.readFile path+        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)

@@ -5,7 +5,7 @@ import Data.Aeson (toJSON) import Data.Text (Text) import qualified Data.Text as T-import MCP.Server+import MCP.Server.Handlers (jsonValueToText) import Test.Hspec import Test.QuickCheck import Text.Read (readMaybe)

@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Coverage for dual-era operation: modern (2026-07-28, per-request _meta)+-- requests get server/discover, the modern result envelope and header+-- validation; legacy (initialize-handshake) requests are served byte-+-- identically to before.+module Spec.ModernEra (spec) where++import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Types (Pair)+import Data.Text (Text)+import MCP.Server+import MCP.Server.Handlers (handleMcpMessage)+import MCP.Server.JsonRpc+import MCP.Server.Transport.Http (BodyPeek (..), decodeSentinel, peekBody,+                                  peekIsModern, validateRequestHeaders)+import qualified Network.Wai as Wai+import Test.Hspec++testServerInfo :: McpServerInfo+testServerInfo = McpServerInfo+  { serverName = "Test Server"+  , serverVersion = "9.9.9"+  , serverInstructions = "Use the tools."+  }++-- A server that only provides tools; the call handler reports the protocol+-- version it saw in the ClientContext.+testHandlers :: McpServerHandlers+testHandlers = noHandlers+  { tools = Just+      ( \_ctx -> pure []+      , \ctx _name _args -> pure $ Right $ toToolResult+          ("version=" <> maybe "none" id (clientProtocolVersion ctx))+      )+  }++run :: JsonRpcMessage -> IO (Maybe JsonRpcMessage)+run = handleMcpMessage testServerInfo defaultCacheHints noNotificationSupport testHandlers anonymousContext++request :: Text -> Maybe Value -> JsonRpcMessage+request method params = JsonRpcMessageRequest $ JsonRpcRequest+  { requestJsonrpc = "2.0"+  , requestId = RequestIdNumber 1+  , requestMethod = method+  , requestParams = params+  }++-- params carrying the standard modern _meta+modernParams :: [Pair] -> Value+modernParams extra = object $ extra +++  [ "_meta" .= object+      [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)+      , "io.modelcontextprotocol/clientInfo" .= object ["name" .= ("test-client" :: Text)]+      , "io.modelcontextprotocol/clientCapabilities" .= object []+      ]+  ]++resultObject :: Maybe JsonRpcMessage -> IO Object+resultObject (Just (JsonRpcMessageResponse r)) = case responseResult r of+  Just (Object o) -> pure o+  other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty+resultObject other =+  expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty++errorOf :: Maybe JsonRpcMessage -> IO JsonRpcError+errorOf (Just (JsonRpcMessageResponse r)) = case responseError r of+  Just e -> pure e+  Nothing -> expectationFailure "Expected an error response" >> pure (JsonRpcError 0 "" Nothing)+errorOf other =+  expectationFailure ("Expected a response, got: " ++ show other) >> pure (JsonRpcError 0 "" Nothing)++spec :: Spec+spec = describe "Dual-era protocol support" $ do++  describe "server/discover" $ do+    it "reports all supported revisions, newest first" $ do+      o <- resultObject =<< run (request "server/discover" (Just (modernParams [])))+      KM.lookup "supportedVersions" o `shouldBe`+        Just (toJSON (["2026-07-28", "2025-11-25", "2025-06-18", "2025-03-26", "2024-11-05"] :: [Text]))++    it "advertises only capabilities with handlers, plus identity and instructions" $ do+      o <- resultObject =<< run (request "server/discover" (Just (modernParams [])))+      case KM.lookup "capabilities" o of+        Just (Object caps) -> do+          KM.member "tools" caps `shouldBe` True+          KM.member "prompts" caps `shouldBe` False+        other -> expectationFailure $ "capabilities not an object: " ++ show other+      KM.lookup "instructions" o `shouldBe` Just (String "Use the tools.")+      case KM.lookup "_meta" o of+        Just (Object m) ->+          KM.lookup "io.modelcontextprotocol/serverInfo" m `shouldBe`+            Just (object ["name" .= ("Test Server" :: Text), "version" .= ("9.9.9" :: Text)])+        other -> expectationFailure $ "_meta not an object: " ++ show other++    it "carries the modern result envelope even without _meta (probe)" $ do+      o <- resultObject =<< run (request "server/discover" Nothing)+      KM.lookup "resultType" o `shouldBe` Just (String "complete")+      KM.member "ttlMs" o `shouldBe` True+      KM.lookup "cacheScope" o `shouldBe` Just (String "private")++  describe "Modern requests" $ do+    it "stamps resultType and cache fields on cacheable results" $ do+      o <- resultObject =<< run (request "tools/list" (Just (modernParams [])))+      KM.lookup "resultType" o `shouldBe` Just (String "complete")+      KM.lookup "ttlMs" o `shouldBe` Just (Number 0)+      KM.lookup "cacheScope" o `shouldBe` Just (String "private")++    it "stamps resultType but not cache fields on tools/call" $ do+      o <- resultObject =<< run (request "tools/call"+        (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []])))+      KM.lookup "resultType" o `shouldBe` Just (String "complete")+      KM.member "ttlMs" o `shouldBe` False++    it "exposes the declared protocol version to handlers via ClientContext" $ do+      o <- resultObject =<< run (request "tools/call"+        (Just (modernParams ["name" .= ("t" :: Text), "arguments" .= object []])))+      KM.lookup "content" o `shouldBe`+        Just (toJSON [object ["type" .= ("text" :: Text), "text" .= ("version=2026-07-28" :: Text)]])++    it "serves initialize and ping as unknown methods when a modern revision is declared" $ do+      e1 <- errorOf =<< run (request "initialize" (Just (modernParams+        [ "protocolVersion" .= ("2026-07-28" :: Text)+        , "capabilities" .= object []+        , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)]+        ])))+      errorCode e1 `shouldBe` (-32601)+      e2 <- errorOf =<< run (request "ping" (Just (modernParams [])))+      errorCode e2 `shouldBe` (-32601)++    it "rejects undeclared revisions with UnsupportedProtocolVersionError" $ do+      e <- errorOf =<< run (request "tools/list" (Just (object+        [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2099-01-01" :: Text)] ])))+      errorCode e `shouldBe` (-32022)+      case errorData e of+        Just (Object d) -> do+          KM.lookup "requested" d `shouldBe` Just (String "2099-01-01")+          case KM.lookup "supported" d of+            Just (Array _) -> pure ()+            other -> expectationFailure $ "supported not a list: " ++ show other+        other -> expectationFailure $ "no error data: " ++ show other++  describe "Legacy requests" $ do+    it "are served without the modern envelope" $ do+      o <- resultObject =<< run (request "tools/list" Nothing)+      KM.member "resultType" o `shouldBe` False+      KM.member "ttlMs" o `shouldBe` False+      KM.member "_meta" o `shouldBe` False++    it "negotiate down to the newest legacy revision when proposing 2026-07-28 via initialize" $ do+      o <- resultObject =<< run (request "initialize" (Just (object+        [ "protocolVersion" .= ("2026-07-28" :: Text)+        , "capabilities" .= object []+        , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)]+        ])))+      KM.lookup "protocolVersion" o `shouldBe` Just (String "2025-11-25")++  describe "HTTP request metadata validation" $ do+    let modernBody name = encode $ object+          [ "jsonrpc" .= ("2.0" :: Text)+          , "id" .= (7 :: Int)+          , "method" .= ("tools/call" :: Text)+          , "params" .= modernParams ["name" .= name, "arguments" .= object []]+          ]+        reqWith hs = Wai.defaultRequest { Wai.requestHeaders = hs }++    it "peeks method, name, version and id from the body" $ do+      let peek = peekBody (modernBody ("get_weather" :: Text))+      peekMethod peek `shouldBe` Just "tools/call"+      peekName peek `shouldBe` Just "get_weather"+      peekMetaVersion peek `shouldBe` Just "2026-07-28"+      peekId peek `shouldBe` RequestIdNumber 7+      peekIsModern peek `shouldBe` True++    it "accepts a fully consistent modern request" $ do+      let peek = peekBody (modernBody ("get_weather" :: Text))+      validateRequestHeaders (reqWith+        [ ("MCP-Protocol-Version", "2026-07-28")+        , ("Mcp-Method", "tools/call")+        , ("Mcp-Name", "get_weather")+        ]) peek `shouldBe` Nothing++    it "rejects a missing Mcp-Method header with HeaderMismatch" $ do+      let peek = peekBody (modernBody ("get_weather" :: Text))+      fmap errorCode (validateRequestHeaders (reqWith+        [ ("MCP-Protocol-Version", "2026-07-28")+        , ("Mcp-Name", "get_weather")+        ]) peek) `shouldBe` Just (-32020)++    it "rejects a header/body protocol version mismatch with HeaderMismatch" $ do+      let peek = peekBody (modernBody ("get_weather" :: Text))+      fmap errorCode (validateRequestHeaders (reqWith+        [ ("MCP-Protocol-Version", "2025-11-25")+        , ("Mcp-Method", "tools/call")+        , ("Mcp-Name", "get_weather")+        ]) peek) `shouldBe` Just (-32020)++    it "accepts a base64-sentinel Mcp-Name for non-ASCII names" $ do+      let peek = peekBody (modernBody ("Hello, 世界" :: Text))+      validateRequestHeaders (reqWith+        [ ("MCP-Protocol-Version", "2026-07-28")+        , ("Mcp-Method", "tools/call")+        , ("Mcp-Name", "=?base64?SGVsbG8sIOS4lueVjA==?=")+        ]) peek `shouldBe` Nothing++    it "legacy bodies keep the relaxed rules (no headers required)" $ do+      let legacyBody = encode $ object+            [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int)+            , "method" .= ("tools/list" :: Text) ]+      validateRequestHeaders (reqWith []) (peekBody legacyBody) `shouldBe` Nothing++    it "legacy bodies with an unsupported version header are rejected" $ do+      let legacyBody = encode $ object+            [ "jsonrpc" .= ("2.0" :: Text), "id" .= (1 :: Int)+            , "method" .= ("tools/list" :: Text) ]+      fmap errorCode (validateRequestHeaders+        (reqWith [("MCP-Protocol-Version", "1999-01-01")])+        (peekBody legacyBody)) `shouldBe` Just (-32600)++  describe "Sentinel decoding" $ do+    it "passes plain values through" $+      decodeSentinel "us-west1" `shouldBe` "us-west1"+    it "decodes base64 sentinel values" $+      decodeSentinel "=?base64?SGVsbG8sIOS4lueVjA==?=" `shouldBe` "Hello, 世界"

@@ -10,7 +10,7 @@ import MCP.Server.Handlers (handleInitialize) import MCP.Server.JsonRpc (JsonRpcRequest(..), RequestId(..), JsonRpcResponse(..), JsonRpcError(..)) import MCP.Server.Protocol (protocolVersion)-import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..))+import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..), noHandlers, noNotificationSupport)  -- | Test that server performs proper version negotiation according to MCP spec. --@@ -33,10 +33,8 @@    -- A server that only provides tools: capabilities in the initialize   -- response should reflect exactly this.-  let testHandlers = McpServerHandlers-        { prompts = Nothing-        , resources = Nothing-        , tools = Just ( \_ctx -> pure []+  let testHandlers = noHandlers+        { tools = Just ( \_ctx -> pure []                        , \_ctx name _args -> pure (Left (UnknownTool name))                        )         }@@ -57,7 +55,7 @@               , requestMethod = "initialize"               , requestParams = Just params               }-        handleInitialize testServerInfo testHandlers request+        handleInitialize testServerInfo noNotificationSupport testHandlers request    -- Issue an initialize request proposing the given protocol version and   -- return the negotiated version from the server's (non-error) response.

@@ -9,14 +9,15 @@ import MCP.Server import MCP.Server.Derive import Test.Hspec+import TestHelpers import TestTypes import TestData  -- Generate handlers for testing-testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)+testToolHandlers :: (ToolListHandler, ToolCallHandler) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) -testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)+testToolHandlersWithDescriptions :: (ToolListHandler, ToolCallHandler) testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions)  -- Helper functions for schema validation@@ -27,13 +28,11 @@     [] -> error $ "Tool not found: " ++ T.unpack toolName     _ -> error $ "Multiple tools found with name: " ++ T.unpack toolName -getProperty :: Text -> ToolDefinition -> InputSchemaDefinitionProperty+getProperty :: Text -> ToolDefinition -> Schema getProperty propertyName toolDef =-  case toolDefinitionInputSchema toolDef of-    InputSchemaDefinitionObject props _ ->-      case lookup propertyName props of-        Just prop -> prop-        Nothing -> error $ "Property not found: " ++ T.unpack propertyName+  case lookupProp propertyName toolDef of+    Just prop -> prop+    Nothing -> error $ "Property not found: " ++ T.unpack propertyName  assertToolExists :: Text -> [ToolDefinition] -> IO () assertToolExists toolName toolDefs = do@@ -42,18 +41,17 @@ assertHasProperty :: Text -> Text -> ToolDefinition -> IO () assertHasProperty propertyName expectedType toolDef = do   let prop = getProperty propertyName toolDef-  propertyType prop `shouldBe` expectedType+  schemaTypeName prop `shouldBe` expectedType  assertPropertyDescription :: Text -> ToolDefinition -> Text -> IO () assertPropertyDescription propertyName toolDef expectedDesc = do   let prop = getProperty propertyName toolDef-  propertyDescription prop `shouldBe` expectedDesc+  schemaDescription prop `shouldBe` Just expectedDesc  assertRequiredFields :: [Text] -> ToolDefinition -> IO () assertRequiredFields expectedFields toolDef = do-  case toolDefinitionInputSchema toolDef of-    InputSchemaDefinitionObject _ required ->-      all (`elem` required) expectedFields `shouldBe` True+  let required = schemaRequired (toolDefinitionInputSchema toolDef)+  all (`elem` required) expectedFields `shouldBe` True  assertToolDescription :: ToolDefinition -> Text -> IO () assertToolDescription toolDef expectedDesc =

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Coverage for the change-notification machinery: the notifier, the+-- subscriptions/listen wire shapes, and era-aware capability advertisement.+module Spec.Subscriptions (spec) where++import Control.Concurrent.STM (atomically, readTChan)+import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Text (Text)+import MCP.Server+import MCP.Server.Handlers (handleMcpMessage)+import MCP.Server.JsonRpc+import MCP.Server.Notifications+import Test.Hspec++subId :: RequestId+subId = RequestIdNumber 7++fullFilterParams :: Maybe Value+fullFilterParams = Just $ object+  [ "notifications" .= object+      [ "toolsListChanged" .= True+      , "resourceSubscriptions" .= (["resource://info"] :: [Text])+      ]+  ]++paramsOf :: JsonRpcNotification -> Object+paramsOf n = case notificationParams n of+  Just (Object o) -> o+  other           -> error $ "notification params not an object: " ++ show other++metaSubId :: Object -> Maybe Value+metaSubId o = do+  Object m <- KM.lookup "_meta" o+  KM.lookup "io.modelcontextprotocol/subscriptionId" m++spec :: Spec+spec = describe "Change notifications" $ do++  describe "Filter parsing" $ do+    it "parses the requested notification types" $ do+      let f = parseNotificationFilter fullFilterParams+      filterTools f `shouldBe` True+      filterPrompts f `shouldBe` False+      filterResources f `shouldBe` False+      filterResourceSubs f `shouldBe` ["resource://info"]++    it "treats missing filters as subscribed-to-nothing" $ do+      let f = parseNotificationFilter Nothing+      filterIsEmpty f `shouldBe` True++  describe "Filter semantics" $ do+    it "delivers only opted-in types" $ do+      let f = parseNotificationFilter fullFilterParams+      filterAccepts f ToolsListChangedEvent `shouldBe` True+      filterAccepts f PromptsListChangedEvent `shouldBe` False+      filterAccepts f ResourcesListChangedEvent `shouldBe` False++    it "matches resource updates by watched URI" $ do+      let f = parseNotificationFilter fullFilterParams+      filterAccepts f (ResourceUpdatedEvent "resource://info") `shouldBe` True+      filterAccepts f (ResourceUpdatedEvent "resource://other") `shouldBe` False++  describe "Wire shapes" $ do+    it "acknowledges with the subscription id and the honored subset" $ do+      let ack = acknowledgedNotification subId (parseNotificationFilter fullFilterParams)+      notificationMethod ack `shouldBe` "notifications/subscriptions/acknowledged"+      let o = paramsOf ack+      metaSubId o `shouldBe` Just (Number 7)+      KM.lookup "notifications" o `shouldBe` Just (object+        [ "toolsListChanged" .= True+        , "resourceSubscriptions" .= (["resource://info"] :: [Text])+        ])++    it "tags event notifications with the subscription id" $ do+      let n = eventNotification subId (ResourceUpdatedEvent "resource://info")+      notificationMethod n `shouldBe` "notifications/resources/updated"+      let o = paramsOf n+      metaSubId o `shouldBe` Just (Number 7)+      KM.lookup "uri" o `shouldBe` Just (String "resource://info")++    it "uses the standard list_changed methods" $ do+      notificationMethod (eventNotification subId ToolsListChangedEvent)+        `shouldBe` "notifications/tools/list_changed"+      notificationMethod (eventNotification subId PromptsListChangedEvent)+        `shouldBe` "notifications/prompts/list_changed"+      notificationMethod (eventNotification subId ResourcesListChangedEvent)+        `shouldBe` "notifications/resources/list_changed"++    it "legacy notifications are untagged" $ do+      let n = legacyEventNotification ToolsListChangedEvent+      notificationMethod n `shouldBe` "notifications/tools/list_changed"+      notificationParams n `shouldBe` Nothing++    it "closure responses carry resultType, the subscription id and the server identity" $ do+      let r = closureResponse (McpServerInfo "S" "2.0" "") subId+      responseResult r `shouldBe` Just (object+        [ "resultType" .= ("complete" :: Text)+        , "_meta" .= object+            [ "io.modelcontextprotocol/subscriptionId" .= (7 :: Int)+            , "io.modelcontextprotocol/serverInfo" .= object+                [ "name" .= ("S" :: Text), "version" .= ("2.0" :: Text) ]+            ]+        ])++  describe "Notifier plumbing" $ do+    it "delivers published events to subscribers" $ do+      (notifier, source) <- newMcpNotifier+      chan <- atomically $ subscribeEvents source+      notifyToolsListChanged notifier+      event <- atomically $ readTChan chan+      event `shouldBe` ToolsListChangedEvent++  describe "Era-aware capability advertisement" $ do+    let toolsServer = noHandlers+          { tools = Just (\_ -> pure [], \_ n _ -> pure (Left (UnknownTool n)))+          , resources = Just (\_ -> pure [], \_ _ -> pure (Left (ResourceNotFound "x")))+          }+        run support method params = handleMcpMessage+          (McpServerInfo "T" "1" "")+          defaultCacheHints+          support+          toolsServer+          anonymousContext+          (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params))+        capsOf resp = case resp of+          Just (JsonRpcMessageResponse r)+            | Just (Object o) <- responseResult r+            , Just (Object caps) <- KM.lookup "capabilities" o -> pure caps+          other -> error $ "no capabilities in: " ++ show other+        initParams = Just $ object+          [ "protocolVersion" .= ("2025-11-25" :: Text)+          , "capabilities" .= object []+          , "clientInfo" .= object ["name" .= ("c" :: Text), "version" .= ("1" :: Text)]+          ]++    it "legacy initialize advertises listChanged only with legacy push" $ do+      caps <- capsOf =<< run (NotificationSupport True True) "initialize" initParams+      KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True])+      -- legacy subscribe (the removed resources/subscribe RPC) is never advertised+      KM.lookup "resources" caps `shouldBe` Just (object ["listChanged" .= True])++    it "legacy initialize over a push-less transport advertises neither" $ do+      caps <- capsOf =<< run (NotificationSupport False True) "initialize" initParams+      KM.lookup "tools" caps `shouldBe` Just (object [])+      KM.lookup "resources" caps `shouldBe` Just (object [])++    it "modern discover advertises listChanged and subscribe when listen is served" $ do+      caps <- capsOf =<< run (NotificationSupport False True) "server/discover" Nothing+      KM.lookup "tools" caps `shouldBe` Just (object ["listChanged" .= True])+      KM.lookup "resources" caps `shouldBe`+        Just (object ["subscribe" .= True, "listChanged" .= True])++    it "no support means nothing extra is advertised" $ do+      caps <- capsOf =<< run noNotificationSupport "server/discover" Nothing+      KM.lookup "tools" caps `shouldBe` Just (object [])

@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Coverage for resource templates (record constructors → URI templates)+-- and argument completion (completion/complete).+module Spec.TemplatesCompletions (spec) where++import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import MCP.Server+import MCP.Server.Derive+import MCP.Server.Handlers (handleMcpMessage)+import MCP.Server.JsonRpc+import Test.Hspec+import TestTypes++templResourceHandlers :: (ResourceListHandler, ResourceReadHandler)+templResourceHandlers = $(deriveResourceHandler ''TemplResource 'handleTemplResource)++templTemplates :: ResourceTemplateListHandler+templTemplates = $(deriveResourceTemplatesWithDescription ''TemplResource+  [("MemberProfile", "A member's profile"), ("OrderItem", "One item of an order")])++readUri :: String -> IO (Either Error ResourceContent)+readUri s = case parseURI s of+  Just uri -> snd templResourceHandlers anonCtx uri+  Nothing  -> fail ("bad test URI: " ++ s)++expectText :: Either Error ResourceContent -> Text -> Expectation+expectText (Right (ResourceText _ _ content)) expected = content `shouldBe` expected+expectText other expected =+  expectationFailure $ "Expected ResourceText '" ++ T.unpack expected ++ "' but got: " ++ show other++-- A completion handler that records what it receives in its suggestions+testCompletions :: CompletionHandler+testCompletions _ ref argName partial ctxArgs = pure $ Right $ completionResult $+  case ref of+    CompletionRefPrompt name ->+      [ "prompt:" <> name <> ":" <> argName <> ":" <> partial+        <> ":" <> T.intercalate "," (Map.keys ctxArgs)+      ]+    CompletionRefResource uri -> [ "resource:" <> uri <> ":" <> argName ]++completionServer :: McpServerHandlers+completionServer = noHandlers { completions = Just testCompletions }++runReq :: McpServerHandlers -> Text -> Maybe Value -> IO (Maybe JsonRpcMessage)+runReq handlers method params =+  handleMcpMessage+    (McpServerInfo "T" "1" "")+    defaultCacheHints+    noNotificationSupport+    handlers+    anonymousContext+    (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) method params))++resultOf :: Maybe JsonRpcMessage -> IO Object+resultOf (Just (JsonRpcMessageResponse r)) = case responseResult r of+  Just (Object o) -> pure o+  other -> expectationFailure ("Expected object result, got: " ++ show other) >> pure KM.empty+resultOf other =+  expectationFailure ("Expected a response, got: " ++ show other) >> pure KM.empty++spec :: Spec+spec = describe "Resource templates and completions" $ do++  describe "Template derivation" $ do+    it "advertises record constructors as URI templates" $ do+      templates <- templTemplates anonCtx+      map resourceTemplateURITemplate templates `shouldBe`+        [ "resource://member_profile/{memberId}"+        , "resource://order_item/{orderId}/{itemName}"+        ]+      map resourceTemplateDescription templates `shouldBe`+        [ Just "A member's profile", Just "One item of an order" ]++    it "excludes record constructors from the static resource list" $ do+      statics <- fst templResourceHandlers anonCtx+      map resourceDefinitionURI statics `shouldBe` ["resource://catalog"]++  describe "Template reads" $ do+    it "still reads static resources" $ do+      result <- readUri "resource://catalog"+      result `expectText` "The catalog"++    it "reads a single-parameter template" $ do+      result <- readUri "resource://member_profile/alice"+      result `expectText` "Profile of alice"++    it "percent-decodes template segments" $ do+      result <- readUri "resource://member_profile/alice%20smith"+      result `expectText` "Profile of alice smith"++    it "ignores query strings and fragments when matching templates" $ do+      result <- readUri "resource://member_profile/alice?x=1"+      result `expectText` "Profile of alice"+      result2 <- readUri "resource://member_profile/alice#frag"+      result2 `expectText` "Profile of alice"++    it "reads a multi-parameter template with typed segments" $ do+      result <- readUri "resource://order_item/42/widget"+      result `expectText` "Order 42 item widget"++    it "rejects segments that fail the field's type" $ do+      result <- readUri "resource://order_item/notanum/widget"+      case result of+        Left (InvalidParams msg) -> msg `shouldSatisfy` T.isInfixOf "template field 'orderId'"+        other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other++    it "falls through to ResourceNotFound on a segment-count mismatch" $ do+      result <- readUri "resource://member_profile/a/b"+      case result of+        Left (ResourceNotFound _) -> pure ()+        other -> expectationFailure $ "Expected ResourceNotFound but got: " ++ show other++  describe "resources/templates/list dispatch" $ do+    it "returns templates and carries the modern cache envelope" $ do+      let handlers = noHandlers { resourceTemplates = Just templTemplates }+      o <- resultOf =<< runReq handlers "resources/templates/list" (Just (object+        [ "_meta" .= object ["io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)] ]))+      KM.member "resourceTemplates" o `shouldBe` True+      KM.member "ttlMs" o `shouldBe` True+      KM.lookup "resultType" o `shouldBe` Just (String "complete")++    it "answers -32601 when no template handler is configured" $ do+      resp <- runReq noHandlers "resources/templates/list" Nothing+      case resp of+        Just (JsonRpcMessageResponse r) ->+          fmap errorCode (responseError r) `shouldBe` Just (-32601)+        other -> expectationFailure $ "Expected a response, got: " ++ show other++    it "answers resources/list with an empty list for a templates-only server" $ do+      let handlers = noHandlers { resourceTemplates = Just templTemplates }+      o <- resultOf =<< runReq handlers "resources/list" Nothing+      KM.lookup "resources" o `shouldBe` Just (toJSON ([] :: [ResourceDefinition]))++  describe "completion/complete" $ do+    it "dispatches prompt refs with context arguments" $ do+      o <- resultOf =<< runReq completionServer "completion/complete" (Just (object+        [ "ref" .= object ["type" .= ("ref/prompt" :: Text), "name" .= ("recipe" :: Text)]+        , "argument" .= object ["name" .= ("idea" :: Text), "value" .= ("pa" :: Text)]+        , "context" .= object ["arguments" .= object ["cuisine" .= ("italian" :: Text)]]+        ]))+      KM.lookup "completion" o `shouldBe`+        Just (object ["values" .= (["prompt:recipe:idea:pa:cuisine"] :: [Text])])++    it "dispatches resource template refs" $ do+      o <- resultOf =<< runReq completionServer "completion/complete" (Just (object+        [ "ref" .= object ["type" .= ("ref/resource" :: Text), "uri" .= ("resource://member_profile/{memberId}" :: Text)]+        , "argument" .= object ["name" .= ("memberId" :: Text), "value" .= ("al" :: Text)]+        ]))+      KM.lookup "completion" o `shouldBe`+        Just (object ["values" .= (["resource:resource://member_profile/{memberId}:memberId"] :: [Text])])++    it "answers -32601 when no completion handler is configured" $ do+      resp <- runReq noHandlers "completion/complete" Nothing+      case resp of+        Just (JsonRpcMessageResponse r) ->+          fmap errorCode (responseError r) `shouldBe` Just (-32601)+        other -> expectationFailure $ "Expected a response, got: " ++ show other++  describe "Capabilities" $ do+    it "advertises completions and resources-via-templates when configured" $ do+      let handlers = noHandlers+            { resourceTemplates = Just templTemplates+            , completions = Just testCompletions+            }+      o <- resultOf =<< runReq handlers "server/discover" Nothing+      case KM.lookup "capabilities" o of+        Just (Object caps) -> do+          KM.member "completions" caps `shouldBe` True+          KM.member "resources" caps `shouldBe` True+          KM.member "tools" caps `shouldBe` False+        other -> expectationFailure $ "capabilities not an object: " ++ show other

@@ -3,27 +3,27 @@  module Spec.ToolCallParsing (spec) where +import Data.Aeson (Value (..)) import Data.Text (Text) import qualified Data.Text as T import MCP.Server import MCP.Server.Derive import Test.Hspec+import TestHelpers import TestTypes -allTypesHandlers :: (ToolListHandler IO, ToolCallHandler IO)+allTypesHandlers :: (ToolListHandler, ToolCallHandler) allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool) -callTool :: Text -> [(Text, Text)] -> IO (Either Error Content)-callTool = snd allTypesHandlers anonCtx+callTool :: Text -> [(Text, Text)] -> IO (Either Error ToolResult)+callTool name args = snd allTypesHandlers anonCtx name (stringArgs args) -shouldBeRight :: IO (Either Error Content) -> Text -> IO ()+shouldBeRight :: IO (Either Error ToolResult) -> Text -> IO () shouldBeRight action expected = do   result <- action-  case result of-    Right (ContentText content) -> content `shouldBe` expected-    other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other+  result `shouldBeTextResult` expected -shouldBeInvalidParams :: IO (Either Error Content) -> Text -> IO ()+shouldBeInvalidParams :: IO (Either Error ToolResult) -> Text -> IO () shouldBeInvalidParams action expectedSubstring = do   result <- action   case result of@@ -31,7 +31,7 @@       T.isInfixOf expectedSubstring msg `shouldBe` True     other -> expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other -shouldBeMissingParams :: IO (Either Error Content) -> Text -> IO ()+shouldBeMissingParams :: IO (Either Error ToolResult) -> Text -> IO () shouldBeMissingParams action expectedSubstring = do   result <- action   case result of@@ -146,3 +146,14 @@       shouldBeMissingParams         (callTool "required_fields" [("rfText", "hello")])         "is missing"++  describe "Integer exponent bound" $ do+    -- Regression: aeson keeps huge exponents compact, so without a bound a+    -- ~13-byte payload like 1e100000 would materialize a 100001-digit Integer.+    it "rejects huge exponents without materializing the Integer" $ do+      result <- snd allTypesHandlers anonCtx "optional_fields"+        (valueArgs [("ofInteger", Number (read "1e100000"))])+      case result of+        Left (InvalidParams msg) ->+          msg `shouldSatisfy` T.isInfixOf "exponent too large"+        other -> expectationFailure $ "Expected InvalidParams but got: " ++ show other

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Coverage for the 0.2 typed-argument features: native JSON values,+-- enumerations, lists, nested records, isError results and multi-message+-- prompts.+module Spec.TypedArgs (spec) where++import Data.Aeson (Value (..), object, toJSON, (.=))+import Data.Text (Text)+import qualified Data.Text as T+import MCP.Server+import MCP.Server.Derive+import Test.Hspec+import TestHelpers+import TestTypes++typedHandlers :: (ToolListHandler, ToolCallHandler)+typedHandlers = $(deriveToolHandler ''TypedTool 'handleTypedTool)++convHandlers :: (PromptListHandler, PromptGetHandler)+convHandlers = $(derivePromptHandler ''ConvPrompt 'handleConvPrompt)++callTyped :: Text -> [(Text, Value)] -> IO (Either Error ToolResult)+callTyped name args = snd typedHandlers anonCtx name (valueArgs args)++toolNamed :: Text -> [ToolDefinition] -> ToolDefinition+toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of+  (d:_) -> d+  []    -> error $ "tool not found: " ++ T.unpack n++expectInvalidParams :: Either Error ToolResult -> Text -> Expectation+expectInvalidParams (Left (InvalidParams msg)) expectedSubstring =+  msg `shouldSatisfy` T.isInfixOf expectedSubstring+expectInvalidParams other expectedSubstring =+  expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other++spec :: Spec+spec = describe "Typed tool arguments" $ do++  describe "Enumerations" $ do+    it "decodes enum arguments from strings" $ do+      result <- callTyped "paint" [("color", String "green"), ("brightness", Number 5)]+      result `shouldBeTextResult` "Painting Green at 5"++    it "rejects unknown enum values with the allowed set" $ do+      result <- callTyped "paint" [("color", String "purple"), ("brightness", Number 5)]+      expectInvalidParams result "expected one of: red, green, blue"++    it "generates a string schema with enum values" $ do+      toolDefs <- fst typedHandlers anonCtx+      let paintDef = toolNamed "paint" toolDefs+      case lookupProp "color" paintDef of+        Just prop -> schemaShape prop `shouldBe` SchemaString (Just ["red", "green", "blue"])+        Nothing -> expectationFailure "color property missing"++  describe "Native JSON values" $ do+    it "accepts native numbers" $ do+      result <- callTyped "paint" [("color", String "red"), ("brightness", Number 7)]+      result `shouldBeTextResult` "Painting Red at 7"++    it "still accepts numbers sent as strings (lenient)" $ do+      result <- callTyped "paint" [("color", String "red"), ("brightness", String "7")]+      result `shouldBeTextResult` "Painting Red at 7"++    it "rejects non-integral numbers for Int fields" $ do+      result <- callTyped "paint" [("color", String "red"), ("brightness", Number 7.5)]+      expectInvalidParams result "field 'brightness'"++  describe "Lists" $ do+    it "decodes arrays of integers" $ do+      result <- callTyped "bulk_add" [("values", toJSON [1 :: Int, 2, 3])]+      result `shouldBeTextResult` "Sum: 6"++    it "rejects mistyped array elements" $ do+      result <- callTyped "bulk_add" [("values", toJSON [Number 1, String "x"])]+      expectInvalidParams result "Failed to parse Int"++    it "generates an array schema" $ do+      toolDefs <- fst typedHandlers anonCtx+      let bulkDef = toolNamed "bulk_add" toolDefs+      fmap schemaTypeName (lookupProp "values" bulkDef) `shouldBe` Just "array"++  describe "Nested records" $ do+    it "decodes nested objects" $ do+      result <- callTyped "query_data"+        [("filters", object ["tags" .= (["a", "b"] :: [Text]), "maxCount" .= (7 :: Int)])]+      result `shouldBeTextResult` "Query tags=a,b max=7"++    it "treats missing optional nested fields as Nothing" $ do+      result <- callTyped "query_data"+        [("filters", object ["tags" .= (["a"] :: [Text])])]+      result `shouldBeTextResult` "Query tags=a"++    it "reports missing required nested fields with their path" $ do+      result <- callTyped "query_data" [("filters", object [])]+      expectInvalidParams result "field 'tags' is missing"++    it "rejects non-object values for record fields" $ do+      result <- callTyped "query_data" [("filters", String "nope")]+      expectInvalidParams result "field 'filters'"++    it "generates a nested object schema" $ do+      toolDefs <- fst typedHandlers anonCtx+      let queryDef = toolNamed "query_data" toolDefs+      case lookupProp "filters" queryDef of+        Just prop -> do+          schemaTypeName prop `shouldBe` "object"+          map fst (schemaProps prop) `shouldBe` ["tags", "maxCount"]+          schemaRequired prop `shouldBe` ["tags"]+        Nothing -> expectationFailure "filters property missing"++  describe "Tool execution errors" $ do+    it "reports handler failures as isError results, not protocol errors" $ do+      result <- callTyped "always_fails" [("reason", String "boom")]+      case result of+        Right tr -> do+          toolResultIsError tr `shouldBe` True+          toolResultContent tr `shouldBe` [ContentText "boom"]+        Left err -> expectationFailure $ "Expected isError result but got protocol error: " ++ show err++  describe "ToToolResult list semantics" $ do+    it "propagates isError when merging a list of results" $ do+      let merged = toToolResult [toolError "boom", toolResult [ContentText "ok"]]+      toolResultIsError merged `shouldBe` True+      toolResultContent merged `shouldBe` [ContentText "boom", ContentText "ok"]++  describe "Multi-message prompts" $ do+    it "returns a described multi-message conversation with roles" $ do+      result <- snd convHandlers anonCtx "conversation" (promptArgsMap [("topic", "haskell")])+      case result of+        Right (PromptResult desc msgs) -> do+          desc `shouldBe` Just "About haskell"+          map promptMessageRole msgs `shouldBe` [RoleUser, RoleAssistant]+        Left err -> expectationFailure $ "Expected prompt result but got: " ++ show err

@@ -5,6 +5,7 @@ import           Data.Aeson import qualified Data.Aeson.KeyMap    as KM import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map             as Map import qualified Data.Text            as T import qualified Data.Text.Encoding   as TE import           MCP.Server.Protocol@@ -61,7 +62,8 @@       let response = ToolsCallResponse             { toolsCallContent = [ContentText "Result: √16 = 4, π ≈ 3.14159"]             , toolsCallIsError = Nothing-            , toolsCallMeta = Nothing  -- 2025-06-18: New _meta field+            , toolsCallStructuredContent = Nothing+            , toolsCallMeta = Nothing             }       let encoded = encode response       -- Just verify the JSON can be encoded and contains Unicode@@ -87,7 +89,8 @@       let response = ToolsCallResponse             { toolsCallContent = [ContentText "Mathematical result: √(π²+e²) ≈ 4.53"]             , toolsCallIsError = Nothing-            , toolsCallMeta = Nothing  -- 2025-06-18: New _meta field+            , toolsCallStructuredContent = Nothing+            , toolsCallMeta = Nothing             }       let json = toJSON response       -- Verify the JSON can be encoded and contains Unicode@@ -177,8 +180,8 @@             ]        let promptGetHandler name args = case name of-            "math_formula" -> case lookup "formula" args of-              Just formula -> return $ Right $ ContentText $ "Formula: " <> formula <> " → √(solution)"+            "math_formula" -> case Map.lookup "formula" args of+              Just formula -> return $ Right $ toPromptResult $ ContentText $ "Formula: " <> formula <> " → √(solution)"               Nothing -> return $ Left $ MissingRequiredParams "formula"             _ -> return $ Left $ InvalidPromptName name @@ -201,23 +204,23 @@             ToolDefinition               { toolDefinitionName = "calculate"               , toolDefinitionDescription = "Calculate with Unicode symbols: √∑∏"-              , toolDefinitionInputSchema = InputSchemaDefinitionObject-                  { properties = [("expression", InputSchemaDefinitionProperty "string" "Mathematical expression")]-                  , required = ["expression"]-                  }+              , toolDefinitionInputSchema = schema $ SchemaObject+                  [("expression", describedSchema "Mathematical expression" (SchemaString Nothing))]+                  ["expression"]+              , toolDefinitionOutputSchema = Nothing               , toolDefinitionTitle = Nothing  -- 2025-06-18: New title field               }             ]        let toolCallHandler name args = case name of-            "calculate" -> case lookup "expression" args of-              Just expr -> return $ Right $ ContentText $ "Result: " <> expr <> " → √answer"-              Nothing -> return $ Left $ MissingRequiredParams "expression"+            "calculate" -> case Map.lookup "expression" args of+              Just (String expr) -> return $ Right $ toToolResult $ ContentText $ "Result: " <> expr <> " → √answer"+              _ -> return $ Left $ MissingRequiredParams "expression"             _ -> return $ Left $ UnknownTool name        -- Handlers above ignore the per-request client context-      let ctx = ClientContext Nothing Nothing-      let handlers = McpServerHandlers+      let ctx = anonymousContext+      let handlers = noHandlers             { prompts = Just (const promptListHandler, const promptGetHandler)             , resources = Just (const resourceListHandler, const resourceReadHandler)             , tools = Just (const toolListHandler, const toolCallHandler)@@ -234,9 +237,9 @@       toolList `shouldSatisfy` (not . null)        -- Test actual Unicode handling-      promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") ctx "math_formula" [("formula", "√(x²+y²)")]+      promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") ctx "math_formula" (Map.fromList [("formula", "√(x²+y²)")])       case promptResult of-        Right (ContentText txt) -> txt `shouldSatisfy` T.isInfixOf "√"+        Right (PromptResult _ [PromptMessage _ (ContentText txt)]) -> txt `shouldSatisfy` T.isInfixOf "√"         _ -> expectationFailure "Expected successful prompt result"        uri <- case parseURI "resource://unicode_symbols" of@@ -247,9 +250,9 @@         Right (ResourceText _ _ txt) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"         _ -> expectationFailure "Expected successful resource result" -      toolResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") ctx "calculate" [("expression", "∫₀^∞ e^(-x²) dx = √π/2")]-      case toolResult of-        Right (ContentText txt) -> do+      callResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") ctx "calculate" (Map.fromList [("expression", String "∫₀^∞ e^(-x²) dx = √π/2")])+      case callResult of+        Right tr | [ContentText txt] <- toolResultContent tr -> do           txt `shouldSatisfy` T.isInfixOf "√"           txt `shouldSatisfy` T.isInfixOf "∫"         _ -> expectationFailure "Expected successful tool result"

@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shared helpers for exercising the 0.2 handler API from tests.+module TestHelpers+  ( -- * Building argument maps+    stringArgs+  , valueArgs+  , promptArgsMap+    -- * Result expectations+  , shouldBeTextResult+  , shouldBeTextResultContaining+  , shouldBePromptText+    -- * Schema access+  , schemaTypeName+  , schemaProps+  , schemaRequired+  , lookupProp+  ) where++import           Data.Aeson (Value (..))+import           Data.Map   (Map)+import qualified Data.Map   as Map+import           Data.Text  (Text)+import qualified Data.Text  as T+import           MCP.Server+import           Test.Hspec++-- | Tool arguments where every value is a JSON string (exercises the lenient+-- string-fallback parsing that pre-0.2 clients rely on).+stringArgs :: [(Text, Text)] -> Map Text Value+stringArgs = Map.fromList . map (fmap String)++-- | Tool arguments with native JSON values.+valueArgs :: [(Text, Value)] -> Map Text Value+valueArgs = Map.fromList++-- | Prompt arguments (string-valued per the MCP spec).+promptArgsMap :: [(Text, Text)] -> Map Text Text+promptArgsMap = Map.fromList++-- | Expect a successful, non-error tool result with exactly one text block.+shouldBeTextResult :: Either Error ToolResult -> Text -> Expectation+shouldBeTextResult (Right tr) expected+  | not (toolResultIsError tr)+  , [ContentText content] <- toolResultContent tr = content `shouldBe` expected+shouldBeTextResult other expected =+  expectationFailure $ "Expected text result '" ++ T.unpack expected ++ "' but got: " ++ show other++-- | Like 'shouldBeTextResult' but with substring matching.+shouldBeTextResultContaining :: Either Error ToolResult -> Text -> Expectation+shouldBeTextResultContaining (Right tr) expected+  | not (toolResultIsError tr)+  , [ContentText content] <- toolResultContent tr =+      content `shouldSatisfy` T.isInfixOf expected+shouldBeTextResultContaining other expected =+  expectationFailure $ "Expected text result containing '" ++ T.unpack expected ++ "' but got: " ++ show other++-- | Expect a prompt result of a single user message with the given text.+shouldBePromptText :: Either Error PromptResult -> Text -> Expectation+shouldBePromptText (Right (PromptResult _ [PromptMessage RoleUser (ContentText content)])) expected =+  content `shouldBe` expected+shouldBePromptText other expected =+  expectationFailure $ "Expected prompt text '" ++ T.unpack expected ++ "' but got: " ++ show other++-- | The JSON Schema type keyword for a schema.+schemaTypeName :: Schema -> Text+schemaTypeName s = case schemaShape s of+  SchemaString _   -> "string"+  SchemaInteger    -> "integer"+  SchemaNumber     -> "number"+  SchemaBoolean    -> "boolean"+  SchemaArray _    -> "array"+  SchemaObject _ _ -> "object"++-- | The properties of an object schema (empty for non-objects).+schemaProps :: Schema -> [(Text, Schema)]+schemaProps s = case schemaShape s of+  SchemaObject props _ -> props+  _                    -> []++-- | The required field names of an object schema.+schemaRequired :: Schema -> [Text]+schemaRequired s = case schemaShape s of+  SchemaObject _ req -> req+  _                  -> []++-- | Look up a property schema in a tool's input schema.+lookupProp :: Text -> ToolDefinition -> Maybe Schema+lookupProp name def = lookup name (schemaProps (toolDefinitionInputSchema def))

@@ -4,12 +4,15 @@  import           Data.Text  (Text) import qualified Data.Text  as T-import           MCP.Server (ClientContext(..), Content(..), ResourceContent(..))+import           MCP.Server (ClientContext, anonymousContext, Content (..), MessageRole (..),+                             PromptMessage (..), PromptResult (..),+                             ResourceContent (..), ToolResult, toolError,+                             toolResult) import           Network.URI (URI)  -- Context passed to handlers in tests (no transport-level identity) anonCtx :: ClientContext-anonCtx = ClientContext Nothing Nothing+anonCtx = anonymousContext  -- Test data types for end-to-end testing data TestPrompt@@ -135,6 +138,59 @@         , "float=" <> maybe "Nothing" (T.pack . show) f         , "bool=" <> maybe "Nothing" (T.pack . show) b         ]++-- Types exercising 0.2 typed arguments: enums, lists, nested records+data Color = Red | Green | Blue+    deriving (Show, Eq)++data Filters = Filters { tags :: [Text], maxCount :: Maybe Int }+    deriving (Show, Eq)++data TypedTool+    = Paint { color :: Color, brightness :: Int }+    | BulkAdd { values :: [Int] }+    | QueryData { filters :: Filters }+    | AlwaysFails { reason :: Text }+    deriving (Show, Eq)++handleTypedTool :: ClientContext -> TypedTool -> IO ToolResult+handleTypedTool _ (Paint c b) =+    pure $ toolResult [ContentText $ "Painting " <> T.pack (show c) <> " at " <> T.pack (show b)]+handleTypedTool _ (BulkAdd vs) =+    pure $ toolResult [ContentText $ "Sum: " <> T.pack (show (sum vs))]+handleTypedTool _ (QueryData (Filters ts mc)) =+    pure $ toolResult [ContentText $ "Query tags=" <> T.intercalate "," ts+                        <> maybe "" ((" max=" <>) . T.pack . show) mc]+handleTypedTool _ (AlwaysFails msg) =+    pure $ toolError msg++-- Resource type mixing static resources and templates (record constructors)+data TemplResource+    = Catalog+    | MemberProfile { memberId :: Text }+    | OrderItem { orderId :: Int, itemName :: Text }+    deriving (Show, Eq)++handleTemplResource :: ClientContext -> URI -> TemplResource -> IO ResourceContent+handleTemplResource _ uri Catalog =+    pure $ ResourceText uri "text/plain" "The catalog"+handleTemplResource _ uri (MemberProfile uid) =+    pure $ ResourceText uri "text/plain" ("Profile of " <> uid)+handleTemplResource _ uri (OrderItem oid item) =+    pure $ ResourceText uri "text/plain" ("Order " <> T.pack (show oid) <> " item " <> item)++-- A prompt whose handler produces a multi-message conversation+data ConvPrompt = Conversation { topic :: Text }+    deriving (Show, Eq)++handleConvPrompt :: ClientContext -> ConvPrompt -> IO PromptResult+handleConvPrompt _ (Conversation t) = pure $ PromptResult+    { promptResultDescription = Just ("About " <> t)+    , promptResultMessages =+        [ PromptMessage RoleUser (ContentText ("Tell me about " <> t))+        , PromptMessage RoleAssistant (ContentText ("Here is what I know about " <> t))+        ]+    }  -- Test descriptions for custom description functionality testDescriptions :: [(String, String)]

@@ -0,0 +1,1 @@+{"id":12,"jsonrpc":"2.0","result":{"completion":{"values":["alpha"]}}}

@@ -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"}}}

@@ -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"}}}

@@ -0,0 +1,1 @@+{"id":2,"jsonrpc":"2.0","result":{}}

@@ -0,0 +1,1 @@+{"id":8,"jsonrpc":"2.0","result":{"description":"A greeting","messages":[{"content":{"text":"Hello, World!","type":"text"},"role":"user"}]}}

@@ -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"}]}}

@@ -0,0 +1,1 @@+{"id":9,"jsonrpc":"2.0","result":{"resources":[{"description":"Some info","mimeType":"text/plain","name":"info","uri":"resource://info"}]}}

@@ -0,0 +1,1 @@+{"id":10,"jsonrpc":"2.0","result":{"contents":[{"mimeType":"text/plain","text":"The golden info","uri":"resource://info"}]}}

@@ -0,0 +1,1 @@+{"id":11,"jsonrpc":"2.0","result":{"resourceTemplates":[{"description":"An item","mimeType":"text/plain","name":"item","uriTemplate":"resource://item/{itemId}"}]}}

@@ -0,0 +1,1 @@+{"id":6,"jsonrpc":"2.0","result":{"content":[{"text":"kaboom","type":"text"}],"isError":true}}

@@ -0,0 +1,1 @@+{"id":4,"jsonrpc":"2.0","result":{"content":[{"text":"echo: hi","type":"text"}]}}

@@ -0,0 +1,1 @@+{"error":{"code":-32602,"message":"Unknown tool: nope"},"id":5,"jsonrpc":"2.0"}

@@ -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"}]}}

@@ -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"}}

@@ -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"}

@@ -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"}

@@ -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"}}

@@ -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}}

@@ -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}}

@@ -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}}

@@ -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}}

@@ -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"}}

@@ -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}}

@@ -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"}