mcp-server 0.2.0.1 → 0.2.0.2

raw patch · 8 files changed

+682/−370 lines, 8 filesdep ~http-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: http-types

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• README.md +436/−366
• mcp-server.cabal +4/−1
• src/MCP/Server/Handlers.hs +29/−1
• src/MCP/Server/Transport/Stdio.hs +8/−2
• test/HspecMain.hs +4/−0
• test/Spec/HandlerExceptions.hs +54/−0
• test/Spec/HttpTransport.hs +124/−0

@@ -1,5 +1,28 @@ # Revision history for mcp-server +## 0.2.0.2 - 2026-09-08++* stdio: in-flight requests are drained at stdin EOF instead of being+  cancelled. Since 0.2.0.1 made stdio requests concurrent, a client that+  wrote its requests and closed stdin straight away (scripts, `echo ... |+  server`, conformance replays) lost the responses to whatever was still+  running when EOF arrived — most visibly the last request in the batch.+  Per the lifecycle spec the client closes stdin and then waits for the+  server to exit, so the server now finishes outstanding work and writes+  those responses before shutting down. Subscription streams are still+  closed at EOF as before, and `notifications/cancelled` still interrupts+  a running request.+* A handler that throws an exception (rather than returning an error+  value such as `toolError`) now yields a `-32603` internal-error response+  for its request id, on both transports and in both protocol eras.+  Previously the exception escaped the transport: on stdio the request's+  task died silently and the client waited forever for that id; on HTTP+  Warp answered a bare text/plain 500 (single-JSON responses) or dropped+  the connection with an empty body (SSE responses). The exception's first+  line is the error message; the full rendering (including any call+  stack) is logged to stderr. Asynchronous exceptions are rethrown+  untouched, so cancellation is unaffected.+ ## 0.2.0.1 - 2026-08-01  (Supersedes 0.2.0.0, which is **deprecated on Hackage**: it was published

@@ -1,106 +1,209 @@ # mcp-server -A fully-featured Haskell library for building [Model Context Protocol (MCP)](https://modelcontextprotocol.io/) servers.+[![Hackage](https://img.shields.io/hackage/v/mcp-server.svg)](https://hackage.haskell.org/package/mcp-server)+[![CI](https://github.com/drshade/haskell-mcp-server/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/drshade/haskell-mcp-server/actions/workflows/haskell-ci.yml) -## Features+Build [Model Context Protocol](https://modelcontextprotocol.io/) servers in+Haskell from plain data types. Declare your tools, prompts and resources as+ADTs, write one handler per type, and the library derives the JSON schemas,+argument decoding, validation and wire protocol for you — then serves it over+stdio or Streamable HTTP to Claude Code, Codex, Claude Desktop, Cursor and any+other MCP client. -- **Complete MCP Implementation**: 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-- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP Streamable HTTP)+```haskell+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -## Supported MCP Features+import Data.Text (Text)+import MCP.Server+import MCP.Server.Derive -- ✅ **Prompts**: User-controlled prompt templates with arguments-- ✅ **Resources**: Application-controlled readable resources-- ✅ **Resource Templates**: Parameterized resources via URI templates-- ✅ **Tools**: Model-controlled callable functions-- ✅ **Completions**: Argument autocompletion for prompts and templates-- ✅ **Change Notifications**: `listChanged`/resource-update pushes, via `subscriptions/listen` (2026-07-28) or legacy stdio delivery-- ✅ **Progress & Logging**: `notifications/progress` and `notifications/message` scoped to the requesting client-- ✅ **Cancellation**: `notifications/cancelled` (stdio) and stream closure (HTTP) interrupt in-flight handlers-- ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation-- ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses+data Units = Celsius | Fahrenheit -## Quick Start+data WeatherTool+    = CurrentWeather { city :: Text, units :: Maybe Units }+    | Forecast       { city :: Text, days :: Int } -Add the library `mcp-server` to your cabal file:+handleTool :: ClientContext -> WeatherTool -> IO Content+handleTool _ (CurrentWeather c _) = pure $ ContentText $ "Sunny in " <> c+handleTool _ (Forecast c n)       = pure $ ContentText $ "Forecast for " <> c +$(pure [])  -- end the declaration group so the splice below can see the types++main :: IO ()+main = runMcpServerStdio serverInfo noHandlers+    { tools = Just $(deriveToolHandler ''WeatherTool 'handleTool) }+  where+    serverInfo = McpServerInfo+      { serverName = "weather", serverVersion = "1.0.0"+      , serverInstructions = "Weather lookups" }+```++That is a complete, working MCP server exposing two tools, `current_weather`+and `forecast`, each with a JSON schema derived from its constructor's fields.++## What you get for free++The derivation reads your types, so the schema on the wire always matches the+handler that receives the arguments. Given this constructor from+[`examples/Complete`](examples/Complete/Types.hs):++```haskell+data ShippingSpeed = Standard | Express | Overnight++data Address = Address+    { street  :: Text+    , city    :: Text+    , zipCode :: Maybe Text+    }++data MyTool+    = Checkout { speed :: ShippingSpeed, shipTo :: Address }+    | ...+```++`tools/list` returns exactly this (captured from the running example):++```json+{+  "name": "checkout",+  "description": "Checkout",+  "annotations": { "destructiveHint": true },+  "inputSchema": {+    "type": "object",+    "required": ["speed", "shipTo"],+    "properties": {+      "speed":  { "type": "string", "enum": ["standard", "express", "overnight"] },+      "shipTo": {+        "type": "object",+        "required": ["street", "city"],+        "properties": {+          "street":  { "type": "string" },+          "city":    { "type": "string" },+          "zipCode": { "type": "string" }+        }+      }+    }+  }+}+```++and a `tools/call` with matching arguments arrives in your handler as a fully+decoded `Checkout Express (Address "1 Main St" "Springfield" Nothing)`.+Malformed arguments never reach you; the library answers with the appropriate+JSON-RPC error. The same machinery works in reverse for typed results (see+[Structured output](#structured-output)).++Beyond the derivation, the library handles:++- **Both protocol eras.** Legacy revisions `2024-11-05` through `2025-11-25`+  negotiated via `initialize`, and the stateless `2026-07-28` revision+  declared per request in `_meta`, from one server binary.+- **Two transports.** stdio, and Streamable HTTP with bearer auth, Origin+  validation, per-request SSE and a plain WAI application you can embed.+- **Long-running tools.** Progress notifications, per-request client logging,+  and cancellation of in-flight requests on both transports.+- **Live servers.** `listChanged` and resource-update pushes over+  `subscriptions/listen`.+- **Conformance fixtures.** A language-agnostic corpus of request/response+  pairs the test suite replays against every protocol era.++## Installation++Add `mcp-server` to your `build-depends`:+ ```cabal build-depends:-  mcp-server+  base, text, mcp-server ``` -Create a simple module, such as this example below:+Tested against GHC 9.6 through 9.14 in CI. The HTTP transport requires+`ghc-options: -threaded` (Warp needs the threaded runtime). -```haskell-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+## Connecting to a client -import Data.Text (Text)-import MCP.Server-import MCP.Server.Derive+Build your server, then register it with your client of choice. The examples+below use the `simple-example` executable from this repository; substitute+your own. --- Define your data types-data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text }-data MyResource = Menu | Specials-data MyTool = Search { query :: Text } | Order { item :: Text }+### Claude Code --- Implement handlers. Every handler receives the per-request 'ClientContext'--- (the caller's bearer token and principal on the HTTP transport) first.-handlePrompt :: ClientContext -> MyPrompt -> IO Content-handlePrompt _ (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea-handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items+```bash+# stdio: everything after -- is the command Claude Code spawns+claude mcp add my-server -- "$(cabal list-bin exe:simple-example)" -handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent-handleResource _ uri Menu = pure $ ResourceText uri "text/plain" "Today's menu..."-handleResource _ uri Specials = pure $ ResourceText uri "text/plain" "Daily specials..."+# pass environment variables with --env+claude mcp add my-server --env API_KEY=secret -- /path/to/my-server -handleTool :: ClientContext -> MyTool -> IO Content-handleTool _ (Search query) = pure $ ContentText $ "Search results for " <> query-handleTool _ (Order item) = pure $ ContentText $ "Ordered " <> item+# Streamable HTTP+claude mcp add --transport http my-server http://localhost:3000/mcp+``` --- Template Haskell staging: this empty splice ends the declaration group,--- so the derive splices below can see the types above. (Alternatively,--- declare the types in a separate module, as the examples/ do.)-$(pure [])+Verify with `claude mcp list` or `/mcp` inside a session. Add+`--scope project` to write a `.mcp.json` you can commit for your team: --- Derive handlers automatically-main :: IO ()-main = runMcpServerStdio serverInfo handlers-  where-    serverInfo = McpServerInfo-      { serverName = "My MCP Server"-      , serverVersion = "1.0.0"-      , serverInstructions = "A sample MCP server"-      }-    -- Start from 'noHandlers' and record-update the features you provide:-    -- constructing McpServerHandlers directly breaks (at runtime!) when a-    -- field is missed, and the library grows new handler slots over time.-    handlers = noHandlers-      { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt)-      , resources = Just $(deriveResourceHandler ''MyResource 'handleResource)-      , tools = Just $(deriveToolHandler ''MyTool 'handleTool)-      }+```json+{+  "mcpServers": {+    "my-server": {+      "type": "stdio",+      "command": "/path/to/my-server",+      "env": { "API_KEY": "${API_KEY}" }+    }+  }+} ``` -### Advanced Template Haskell Features+Cursor and several other clients read the same `mcpServers` shape. -#### Automatic Naming Conventions+### Codex -Constructor names are automatically converted to snake_case for MCP names:+```bash+codex mcp add my-server --env API_KEY=secret -- /path/to/my-server+``` -```haskell-data MyTool = GetValue | SetValue | SearchItems--- Becomes: "get_value", "set_value", "search_items"+Or in `~/.codex/config.toml`, which is also where HTTP servers go:++```toml+[mcp_servers.my-server]+command = "/path/to/my-server"++[mcp_servers.my-http-server]+url = "http://localhost:3000/mcp" ``` -#### Typed Tool Arguments+### Claude Desktop -Tool arguments are decoded from full JSON values, and the generated-`inputSchema` mirrors the field types:+Claude Desktop launches stdio servers from `claude_desktop_config.json`. A+Docker image is a convenient way to ship a Haskell binary to it — the+repository's [`Dockerfile`](Dockerfile) builds all three examples: +```bash+docker build -t haskell-mcp-server .+```++```json+{+  "mcpServers": {+    "simple-example": {+      "command": "docker",+      "args": ["run", "-i", "--entrypoint=/usr/local/bin/simple-example", "haskell-mcp-server"]+    }+  }+}+```++### Keep stdout clean++On stdio, `stdout` carries only JSON-RPC. The library writes nothing else+there, and your handlers must not either: log to `stderr`.++## Defining tools++### Naming and arguments++Constructor names become snake_case tool names; record fields become named+arguments. The generated `inputSchema` mirrors the field types:+ ```haskell data Color = Red | Green | Blue          -- all-nullary type: string enum data Filters = Filters                   -- record: nested JSON object@@ -108,54 +211,73 @@   , maxCount :: Maybe Int                -- Maybe: optional field   } -data MyTool = Search-  { query   :: Text-  , color   :: Color                     -- "red" | "green" | "blue"-  , filters :: Filters                   -- { "tags": [...], "maxCount": ... }-  , limit   :: Maybe Int-  }+data MyTool+    = SearchItems                        -- "search_items"+      { query   :: Text+      , color   :: Color                 -- "red" | "green" | "blue"+      , filters :: Filters               -- { "tags": [...], "maxCount": ... }+      , limit   :: Maybe Int+      } ```  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.+parsed leniently: `42` and `"42"` are both accepted, 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.+A constructor may also wrap a single record type, which is unwrapped+recursively until a record is found: -#### Tool Results+```haskell+data SetValueParams = SetValueParams { key :: Text, value :: Text } -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:+data SimpleTool+    = GetValue { key :: Text }+    | SetValue SetValueParams              -- fields of SetValueParams are the arguments+``` +Positional (unnamed) fields are not supported, because they have no names to+put in the schema:+ ```haskell+data SimpleTool = GetValue Int | SetValue Int Text   -- ❌ rejected+```++### Results and errors++Simple handlers return `Content` (or `Text`). Return a `ToolResult` for+multiple content blocks or to report an execution failure with `isError`,+which the spec prefers over a protocol error so the model can see what went+wrong and react:++```haskell handleTool :: ClientContext -> MyTool -> IO ToolResult-handleTool _ (Search q _ _ _)+handleTool _ (SearchItems 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).+Content blocks can carry annotations (`audience`, `priority`,+`lastModified`) via the `ContentAnnotated` wrapper: -#### Derived Output Schemas+```haskell+ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 }+                 (ContentText "important result")+``` -Tools can be typed on the way out too: give the derivation a result record-and it derives the tool's `outputSchema` (same field rules as inputs —-primitives, `Maybe`, lists, enums, nested records) and serializes your typed-values into `structuredContent`, guaranteed to match the schema. Per the-spec's recommendation, the JSON is also returned as a text content block for-clients that predate structured output:+### Structured output +Give the derivation a result type and it derives the tool's `outputSchema`+(same field rules as inputs) and serializes your value into+`structuredContent`, guaranteed to match. Per the spec's recommendation the+JSON is also returned as a text block for clients that predate structured+output:+ ```haskell data WeatherReport = WeatherReport     { temperature :: Int     , sky         :: Sky          -- enum     , alerts      :: [Text]-    , humidity    :: Maybe Int    -- optional, omitted when Nothing+    , humidity    :: Maybe Int    -- omitted when Nothing     }  handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport)@@ -168,160 +290,208 @@ `ToolOutputWith` supplies custom content blocks alongside the structured value; `ToolOutputRaw` is the escape hatch back to a plain `ToolResult`. -#### Nested Parameter Types+### Descriptions, annotations and icons -You can nest parameter types with automatic unwrapping:+Every `derive*` function has a `WithDescription` variant taking a flat list of+constructor and field descriptions, and a `WithOptions` variant taking+per-constructor `DefinitionOptions`: description, title, icons, behavioral+annotations (which drive client permission UX, such as auto-approving+read-only tools) and argument descriptions scoped to that constructor.  ```haskell--- Parameter record types-data GetValueParams = GetValueParams { _gvpKey :: Text }-data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text }---- Main tool type-data SimpleTool-    = GetValue GetValueParams-    | SetValue SetValueParams-    deriving (Show, Eq)+descriptions =+  [ ("SearchItems", "Search the catalog")     -- constructor+  , ("query",       "Search terms")           -- field+  ]+tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) ``` -The Template Haskell derivation recursively unwraps single-parameter constructors until it reaches a record type, then extracts all fields for the MCP schema.+```haskell+tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool+  [ ("SearchItems", defaultDefinitionOptions+      { optDescription = Just "Search the catalog"+      , optToolAnnotations = Just defaultToolAnnotations+          { toolReadOnlyHint = Just True, toolIdempotentHint = Just True }+      , optIcons = [icon "https://example.com/search.png"]+      , optFieldDescriptions = [("query", "Search terms")]+      })+  ])+``` -#### Resource URI Generation+## Defining prompts -Resources automatically get `resource://` URIs based on constructor names:+Prompts derive the same way. Arguments are string-valued per the spec, so+prompt records are limited to primitive and enumeration fields:  ```haskell-data MyResource = Menu | Specials--- Generates: "resource://menu", "resource://specials"+data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text }++handlePrompt :: ClientContext -> MyPrompt -> IO Content+handlePrompt _ (Recipe idea)    = pure $ ContentText $ "Recipe for " <> idea+handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items++prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) ``` -#### Resource Templates+Return a `PromptResult` instead of `Content` for a description and a+multi-message conversation with user and assistant roles. -Record constructors become parameterized resource *templates* (RFC 6570 URI-templates), with one percent-decoded path segment per field:+## Defining resources +Nullary constructors become static resources with `resource://` URIs; record+constructors become resource *templates* (RFC 6570), one percent-decoded path+segment per field:+ ```haskell data MyResource-    = Menu                                            -- static: resource://menu+    = Menu                                            -- 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:+handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent+handleResource _ uri Menu                = pure $ ResourceText uri "text/plain" "Today's menu..."+handleResource _ uri (ProductDetail sku) = pure $ ResourceText uri "text/plain" ("Details for " <> sku)+handleResource _ uri (OrderItem o i)     = ... -```haskell+resources         = Just $(deriveResourceHandler ''MyResource 'handleResource) resourceTemplates = Just $(deriveResourceTemplates ''MyResource) ``` -#### Argument Completion+The read handler matches template URIs such as+`resource://product_detail/ABC123` and decodes the segments into the+constructor's fields; typed fields like `Int` are parsed, and a failing+segment yields an invalid-params error. +## Argument completion+ Provide a `completions` handler to serve `completion/complete` for prompt-arguments and resource-template parameters:+arguments and resource-template parameters. The capability is advertised+automatically when the handler is present:  ```haskell-handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult)+handleComplete :: 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.+handlers = noHandlers { completions = Just handleComplete, ... }+``` -#### Unsupported Patterns+## Assembling the server -We do not support positional (unnamed) parameters:+Start from `noHandlers` and record-update the features you provide.+Constructing `McpServerHandlers` directly is discouraged: the library grows+new handler slots over time, and a missed field fails at runtime rather than+compile time.  ```haskell--- ❌ This won't work - no field names-data SimpleTool-    = GetValue Int-    | SetValue Int Text+handlers = noHandlers+  { prompts           = Just $(derivePromptHandler ''MyPrompt 'handlePrompt)+  , resources         = Just $(deriveResourceHandler ''MyResource 'handleResource)+  , resourceTemplates = Just $(deriveResourceTemplates ''MyResource)+  , tools             = Just $(deriveToolHandler ''MyTool 'handleTool)+  , completions       = Just handleComplete+  } ``` -All parameter types must ultimately resolve to records with named fields to generate proper MCP schemas.+Two Template Haskell details to know: -#### Tool Annotations, Icons and Titles+- A `derive*` splice can only see types declared in an earlier declaration+  group. Either put the types in their own module (as the+  [examples](examples/) do) or end the group with an empty `$(pure [])`+  splice before the `main` that uses them.+- Every handler receives the per-request `ClientContext` first. It carries the+  caller's bearer token and principal on HTTP, the protocol revision and+  client identity for modern clients, and the `reportProgress` and+  `logToClient` actions described below. -The `WithOptions` derivation variants take per-constructor-`DefinitionOptions` — description, title, icons, behavioral annotations-(which drive client permission UX, e.g. auto-approving read-only tools),-and argument descriptions scoped to the constructor:+### Manual handlers +The derived handlers are ordinary values, so for full control you can supply+your own instead. Prompt arguments arrive as `Map Text Text`, tool arguments+as `Map Text Value`:+ ```haskell-tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool-  [ ("Search", defaultDefinitionOptions-      { optDescription = Just "Search the catalog"-      , optToolAnnotations = Just defaultToolAnnotations-          { toolReadOnlyHint = Just True, toolIdempotentHint = Just True }-      , optIcons = [icon "https://example.com/search.png"]-      , optFieldDescriptions = [("q", "Search terms")]-      })-  ])+promptListHandler :: ClientContext -> IO [PromptDefinition]+promptGetHandler  :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult)++handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) } ``` -Content blocks can carry annotations too (`audience`, `priority`,-`lastModified`), attached with the `ContentAnnotated` wrapper:+## Transports +### stdio++`runMcpServerStdio serverInfo handlers` serves JSON-RPC over stdin and+stdout. `runMcpServerStdioWithConfig` takes a `StdioConfig` for verbose+request logging on stderr, cacheability hints for modern clients, and a+change-notification source.++### Streamable HTTP+ ```haskell-ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 }-                 (ContentText "important result")+import MCP.Server.Transport.Http++main = runMcpServerHttp serverInfo handlers            -- localhost:3000/mcp++main = runMcpServerHttpWithConfig defaultHttpConfig+    { httpPort = 8080+    , httpHost = "0.0.0.0"+    , httpEndpoint = "/api/mcp"+    , httpVerbose = True                                -- request/response logging on stderr+    , httpAllowedOrigins = Just ["https://app.example.com"]+    } serverInfo handlers ``` -## Custom Descriptions+`httpAllowedOrigins` is DNS-rebinding protection: requests carrying an+`Origin` outside the list get 403. `Nothing` disables the check and is only+appropriate for servers unreachable from browsers. -You can provide custom descriptions for constructors and fields using the `*WithDescription` variants:+**Bearer-token authentication** is a callback. Return `Just principal` (any+JSON `Value`, such as a role) to admit the request, or `Nothing` for 401. The+principal reaches handlers as `clientPrincipal` in the `ClientContext`; token+policy lives entirely in your application.  ```haskell--- Define descriptions for constructors and fields-descriptions :: [(String, String)]-descriptions =-  [ ("Recipe", "Generate a recipe for a specific dish")     -- Constructor description-  , ("Search", "Search our menu database")                  -- Constructor description-  , ("idea", "The dish you want a recipe for")              -- Field description-  , ("query", "Search terms to find menu items")            -- Field description-  ]---- Use in derivation-handlers = noHandlers-  { prompts = Just $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt descriptions)-  , tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions)-  , resources = Just $(deriveResourceHandlerWithDescription ''MyResource 'handleResource descriptions)+defaultHttpConfig+  { httpAuthorize = Just $ \mtoken -> case mtoken of+      Just "secret-admin-token" -> pure $ Just (String "admin")+      Just "secret-user-token"  -> pure $ Just (String "user")+      _                         -> pure Nothing   } ``` -## Manual Handler Implementation+The endpoint accepts POST only. Server-to-client notifications flow over the+`subscriptions/listen` POST response stream rather than the deprecated+standalone GET stream, and CORS is enabled for web clients. -For fine-grained control, implement handlers manually:+### Embedding in an existing WAI stack -```haskell-import MCP.Server+The MCP endpoint is a plain [WAI](https://hackage.haskell.org/package/wai)+application, exported as `mcpApplication`, so it can be mounted inside your+own Warp settings, TLS, middleware or router: --- Manual handler implementation. Every handler receives the per-request--- '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 -> Map Text Text -> IO (Either Error PromptResult)--- ... implement your custom logic+```haskell+import MCP.Server (mcpApplication, defaultHttpConfig)+import qualified Network.Wai.Handler.Warp as Warp -main :: IO ()-main = runMcpServerStdio serverInfo handlers-  where-    handlers = noHandlers-      { prompts = Just (promptListHandler, promptGetHandler)-      }+main = Warp.runSettings mySettings $ \req respond ->+    -- route /mcp to the MCP endpoint, everything else to your app+    mcpApplication defaultHttpConfig serverInfo handlers req respond ``` -## Progress and Per-Request Logging+`httpPort` and `httpHost` are ignored when embedding; the endpoint path,+Origin validation, bearer auth and streaming all apply as usual. -Handlers can report progress on long-running work and send log messages to-the calling client through actions on the `ClientContext`:+## Long-running tools +### Progress and logging++Handlers report progress and send log messages to the calling client through+actions on the `ClientContext`. Both are safe to call unconditionally:+ ```haskell handleTool ctx (ImportData file) = do     reportProgress ctx 0.0 (Just 1.0) (Just "starting import")@@ -330,44 +500,32 @@     reportProgress ctx 1.0 (Just 1.0) Nothing ``` -Both are safe to call unconditionally:- - `reportProgress` emits `notifications/progress` only when the request-  carried a `progressToken` (progress values must increase call over call).+  carried a `progressToken`. Progress values must increase call over call. - `logToClient` emits `notifications/message` only when the request declared-  `io.modelcontextprotocol/logLevel` — the spec forbids it otherwise — and-  drops messages below the declared level.--Delivery is transport-appropriate: on stdio the notifications interleave-before the response; on HTTP, a request that opted in is answered with an-SSE response stream carrying the notifications followed by the final-response (requests that didn't opt in keep the single-JSON response).+  `io.modelcontextprotocol/logLevel`, as the spec requires, and drops+  messages below the declared level. -## Cancellation+On stdio the notifications interleave before the response. On HTTP, a request+that opted in is answered with an SSE stream carrying the notifications+followed by the final response; other requests keep the single-JSON response. -In-flight requests can be cancelled, and per the spec the server then stops-work as soon as practical and sends nothing further for that request:+### Cancellation -- **stdio**: each request runs in its own task; a `notifications/cancelled`-  naming its id cancels the task (cancellations for unknown or completed ids-  are ignored, as required).-- **HTTP**: closing the response stream is the cancellation signal. For SSE-  responses the handler is cancelled as soon as the disconnect is detected-  (within one keep-alive interval). For single-JSON responses a disconnect-  is only detected at the final write — the handler runs to completion-  first — so mid-handler cancellation applies to streaming requests:-  clients wanting cancellable calls should opt into streaming via a-  `progressToken`.+In-flight requests can be cancelled, after which the server stops work as soon+as practical and sends nothing further for that request: -A consequence of cancellable requests: **requests are now served-concurrently on both transports** (stdio previously processed them strictly-sequentially). Handlers touching shared mutable state must synchronize-(`MVar`, `STM`, ...) — as was already required for HTTP servers.+- **stdio**: each request runs in its own task, and a `notifications/cancelled`+  naming its id cancels that task. Unknown or completed ids are ignored.+- **HTTP**: closing the response stream is the cancellation signal. SSE+  responses detect the disconnect within one keep-alive interval. Single-JSON+  responses only detect it at the final write, so clients wanting cancellable+  calls should opt into streaming via a `progressToken`. -Cancellation is delivered to handler code as an asynchronous exception (the-standard GHC mechanism, as used by `timeout` and `cancel`). Handlers are-interruptible wherever they block in `IO`; a handler that acquires resources-must release them with `bracket`/`finally` so cancellation cannot leak them:+Cancellation is delivered as an asynchronous exception, the standard GHC+mechanism used by `timeout` and `cancel`. Handlers are interruptible wherever+they block in `IO`, and one that acquires resources should release them with+`bracket` or `finally`:  ```haskell handleTool ctx (ImportData file) =@@ -375,18 +533,21 @@         ... ``` -Handlers that must not be interrupted mid-operation can shield critical-sections with `mask`, but should keep them short — cancellation waits for-them.+Critical sections can be shielded with `mask`, but keep them short: cancellation+waits for them. -## Change Notifications+### Concurrency -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:+Requests are served concurrently on both transports. Handlers touching shared+mutable state must synchronize with `MVar`, `STM` or similar. +## Change notifications++Servers whose tool, prompt or resource lists change at runtime can push+change notifications. Create a notifier, hand its source to the transport, and+call the notifier when things change:+ ```haskell-main :: IO () main = do     (notifier, source) <- newMcpNotifier     _ <- forkIO $ appLogic notifier   -- calls notifyToolsListChanged etc.@@ -395,167 +556,76 @@         serverInfo handlers ``` -Delivery is transport- and era-aware, and the `listChanged`/`subscribe`-capabilities are advertised automatically where delivery is actually-possible:+Delivery is transport- and era-aware, and the `listChanged` and `subscribe`+capabilities are advertised only where delivery is 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+  they opted into, tagged with their subscription id, including   `notifications/resources/updated` for watched URIs. - **Legacy stdio clients** receive spontaneous untagged notifications once-  their `notifications/initialized` arrives (the lifecycle's ready signal).-- **Legacy HTTP clients** have no delivery channel (this library does not-  offer the deprecated GET SSE stream), so nothing is advertised to them.--## HTTP Transport--The library supports the MCP Streamable HTTP transport. Compile your-executable with `ghc-options: -threaded` — Warp requires the threaded runtime:--```haskell-import MCP.Server.Transport.Http---- Simple HTTP server (localhost:3000/mcp)-main = runMcpServerHttp serverInfo handlers---- Custom configuration-main = runMcpServerHttpWithConfig customConfig serverInfo handlers-  where-    customConfig = defaultHttpConfig-      { httpPort = 8080-      , httpHost = "0.0.0.0"-      , httpEndpoint = "/api/mcp"-      , httpVerbose = True     -- Enable detailed logging-      , 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).-      }-```--**Bearer-token authentication** (optional): supply an `httpAuthorize` callback-to validate the `Authorization: Bearer` token each request presents. Return-`Just principal` to authorize (the principal — any JSON `Value`, e.g. a role —-reaches your handlers as `clientPrincipal` in the `ClientContext`), or-`Nothing` to reject the request with 401. Token policy lives entirely in your-application; the library only threads the identity through:--```haskell-    customConfig = defaultHttpConfig-      { httpAuthorize = Just $ \mtoken -> case mtoken of-          Just "secret-admin-token" -> pure $ Just (String "admin")-          Just "secret-user-token"  -> pure $ Just (String "user")-          _                         -> pure Nothing-      }-```--**Features:**-- CORS enabled for web clients-- POST `/mcp` for JSON-RPC messages (GET returns 405 — server-to-client-  notifications flow over the `subscriptions/listen` POST response stream,-  not a standalone GET stream)-- Dual-era protocol support: legacy revisions (`2024-11-05`–`2025-11-25`)-  negotiate via `initialize`; the stateless `2026-07-28` revision declares its-  version per request in `_meta`, with full request-metadata header-  validation (`MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` including the-  base64 sentinel encoding)-- Change notifications as long-lived SSE streams via `httpNotifications`-  (see [Change Notifications](#change-notifications))-- Optional pluggable bearer-token authentication via `httpAuthorize`-- Origin validation via `httpAllowedOrigins`-- Cacheability hints for modern list/read results via `httpCacheHints`--### Embedding in an existing WAI stack--`runMcpServerHttp` starts its own Warp server, but the MCP endpoint is a-plain [WAI](https://hackage.haskell.org/package/wai) application underneath,-and it is exported — so you can mount it inside whatever you already run-(your own Warp settings, TLS, middleware, or a larger router):--```haskell-import MCP.Server (mcpApplication, defaultHttpConfig)-import qualified Network.Wai.Handler.Warp as Warp--main :: IO ()-main = Warp.runSettings mySettings $ \req respond ->-    -- route /mcp to the MCP endpoint, everything else to your app-    mcpApplication defaultHttpConfig serverInfo handlers req respond-```--`httpPort`/`httpHost` are ignored when embedding (they only configure the-server `runMcpServerHttp` starts); the endpoint path, Origin validation,-bearer auth and `subscriptions/listen` streaming all apply as usual.--## Conformance corpus+  their `notifications/initialized` arrives.+- **Legacy HTTP clients** have no delivery channel, so nothing is advertised. -The wire-format fixtures under-[`test/golden/`](test/golden/README.md) double as an **API-agnostic MCP-conformance corpus**: each case is a raw JSON-RPC `.request.json` and the-exact `.response.json` a reference server answers, per protocol era-(legacy `initialize`-negotiated revisions and the stateless `2026-07-28`-revision), enumerated by a `manifest.json`. Nothing in the corpus is-Haskell-specific — any MCP server implementation that reproduces the small-reference server described in the corpus README can replay the requests and-diff the responses. Contributions of new cases are welcome.+## Protocol support -## Roadmap+| Feature | Legacy (`2024-11-05` to `2025-11-25`) | Modern (`2026-07-28`) |+| --- | --- | --- |+| Version selection | `initialize` handshake | per-request `_meta`, `server/discover` |+| Prompts, resources, resource templates, tools | ✅ | ✅ |+| Argument completion | ✅ | ✅ |+| Tool annotations, icons, structured output | ✅ | ✅ |+| Progress and per-request logging | ✅ | ✅ |+| Cancellation | ✅ | ✅ |+| Change notifications | stdio only | `subscriptions/listen` (stdio and HTTP) |+| Result typing and cacheability hints | — | `resultType`, `httpCacheHints` |+| HTTP request-metadata headers | — | `MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` validated | -Design decisions and planned work live as ADRs under+Design decisions and planned work (input-required results, OAuth resource+metadata, pagination, the tasks extension) live as ADRs under [`specs/`](specs/README.md), ordered by [`specs/ROADMAP.md`](specs/ROADMAP.md).  ## Examples -The library includes several examples:--- **`examples/Simple/`**: Basic key-value store using Template Haskell derivation (STDIO)-- **`examples/Complete/`**: Full-featured example with prompts, resources, a resource template, tools (enum/nested/list arguments, `isError`), and completions (STDIO)-- **`examples/HttpSimple/`**: HTTP version of the simple key-value store--## Docker Usage--I like to build and publish my MCP servers to Docker - which means that it's much easier to configure assistants such as Claude Desktop to run them.+- [`examples/Simple/`](examples/Simple/): a key-value store with two tools over stdio.+- [`examples/Complete/`](examples/Complete/): prompts, resources, a resource+  template, tools with enum, nested and list arguments, `isError`,+  annotations, progress and completions.+- [`examples/HttpSimple/`](examples/HttpSimple/): the key-value store over+  Streamable HTTP.  ```bash-# Build the image-docker build -t haskell-mcp-server .--# Run different examples-docker run -i --entrypoint="/usr/local/bin/simple-example" haskell-mcp-server+cabal run simple-example        # stdio; type JSON-RPC on stdin+cabal run http-simple-example   # http://localhost:3000/mcp ``` -And then configure Claude by editing `claude_desktop_config.json`:+## Conformance corpus -```json-{-    "mcpServers": {-       "simple-example": {-            "command": "docker",-            "args": [-                "run",-                "-i",-                "--entrypoint=/usr/local/bin/simple-example",-                "haskell-mcp-server"-            ]-        }-    }-}-```+The wire-format fixtures under [`test/golden/`](test/golden/README.md) are a+language-agnostic MCP conformance corpus: each case is a raw JSON-RPC+`.request.json` and the exact `.response.json` a reference server answers,+per protocol era, enumerated by a `manifest.json`. Any MCP implementation+that reproduces the small reference server described there can replay the+requests and diff the responses. Contributions of new cases are welcome.  ## Documentation +- [API documentation on Hackage](https://hackage.haskell.org/package/mcp-server) - [MCP Specification (2026-07-28)](https://modelcontextprotocol.io/specification/2026-07-28/) - [MCP Specification (2025-11-25, newest legacy revision)](https://modelcontextprotocol.io/specification/2025-11-25/)-- [API Documentation](https://hackage.haskell.org/package/mcp-server)-- [Examples](examples/)  ## Contributing -Contributions are welcome! Please see the issue tracker for open issues and feature requests.+Contributions are welcome. See the issue tracker for open issues and feature+requests, and [RELEASING.md](RELEASING.md) for how versions reach Hackage. -## Disclaimer - AI Assistance+## AI assistance -I am not sure whether there is any stigma associated with this but Claude helped me write a lot of this library. I started with a very specific specification of what I wanted to achieve and worked shoulder-to-shoulder with Claude to implement and refactor the library until I was happy with it. A few of the features such as the Derive functions are a little out of my comfort zone to have manually written, so I appreciated having an expert guide me here - however I do suspect that this implementation may be sub-par and I do intend to refactor and rewrite large pieces of this through regular maintenance.+Much of this library was written with Claude, working from a specification I+wrote and iterating together until I was happy with the result. I review and+maintain all of it, but parts such as the Template Haskell derivation sit+outside what I would have written unaided, and I expect to keep refactoring+them.  ## License 

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.2.0.1+version: 0.2.0.2 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -185,6 +185,8 @@     Spec.DefinitionMetadata     Spec.DerivedOutput     Spec.GoldenWire+    Spec.HandlerExceptions+    Spec.HttpTransport     Spec.JSONConversion     Spec.ModernEra     Spec.Progress@@ -217,6 +219,7 @@     containers,     directory,     hspec,+    http-types,     mcp-server,     network-uri,     stm,

@@ -30,6 +30,9 @@   , errorMessageFromMcpError   ) where +import           Control.Exception      (SomeAsyncException, SomeException,+                                         displayException, fromException,+                                         throwIO, try) import           Control.Monad          (when) import           Data.Aeson import qualified Data.Aeson.Key         as Key@@ -123,6 +126,31 @@   , "resources/templates/list"   ] +-- | Answer a request whose handler threw with a @-32603@ internal error+-- instead of letting the exception escape the transport, where it would+-- silently kill the request's task (stdio) or surface as a bare HTTP 500+-- (Warp) — either way the client never sees a response for that id.+-- Asynchronous exceptions are rethrown untouched: they are how cancellation+-- reaches a handler, and a cancelled request must produce no response.+guardHandler :: RequestId -> IO JsonRpcResponse -> IO JsonRpcResponse+guardHandler rid action = do+  outcome <- try action+  case outcome of+    Right resp -> pure resp+    Left (e :: SomeException) ->+      case fromException e :: Maybe SomeAsyncException of+        Just _  -> throwIO e+        Nothing -> do+          -- The full rendering (which on recent GHCs includes a call stack+          -- for 'error') goes to stderr; the wire carries its first line.+          let rendered = displayException e+          hPutStrLn stderr $ "Handler threw for request " ++ show rid ++ ": " ++ rendered+          pure $ makeErrorResponse rid $ JsonRpcError+            { errorCode = -32603+            , errorMessage = "Internal error: " <> T.pack (takeWhile (/= '\n') rendered)+            , errorData = Nothing+            }+ -- | Stamp the modern-revision result envelope onto a successful response: -- @resultType: \"complete\"@, the server's identity in result @_meta@, and -- (for cacheable methods) @ttlMs@ and @cacheScope@. Error responses and@@ -187,7 +215,7 @@             , reportProgress = progressReporter emit params             , logToClient = clientLogger emit params             }-      response <- case requestMethod req of+      response <- guardHandler (requestId req) $ case requestMethod req of         -- Era purity: the modern revision has neither initialize (nothing to         -- negotiate statelessly) nor ping (removed) — a request declaring a         -- modern revision must be served "according to this revision", so

@@ -10,7 +10,7 @@   ) where  import           Control.Concurrent     (ThreadId, forkIO, killThread)-import           Control.Concurrent.Async (Async, async, cancel)+import           Control.Concurrent.Async (Async, async, cancel, waitCatch) import           Control.Concurrent.MVar (modifyMVar_, newEmptyMVar, newMVar,                                           putMVar, readMVar, takeMVar,                                           withMVar)@@ -232,8 +232,14 @@       eof <- hIsEOF stdin       if eof         then do+          -- EOF means no more input, not "abandon outstanding work": per the+          -- lifecycle spec the client closes stdin and then waits for the+          -- server to exit, so drain in-flight requests (their responses are+          -- still wanted) before tearing down the open-ended streams.+          -- waitCatch, not wait: a handler that threw must not abort the+          -- shutdown of everything else.           inflight <- readMVar inflightVar-          mapM_ (cancel . snd) inflight+          mapM_ (waitCatch . snd) inflight           closeAllSubscriptions           logLine "stdin closed - shutting down"         else do

@@ -12,6 +12,8 @@ import qualified Spec.DefinitionMetadata import qualified Spec.DerivedOutput import qualified Spec.GoldenWire+import qualified Spec.HandlerExceptions+import qualified Spec.HttpTransport import qualified Spec.ModernEra import qualified Spec.Progress import qualified Spec.ProtocolVersionNegotiation@@ -32,6 +34,8 @@     Spec.DefinitionMetadata.spec     Spec.DerivedOutput.spec     Spec.GoldenWire.spec+    Spec.HandlerExceptions.spec+    Spec.HttpTransport.spec     Spec.ModernEra.spec     Spec.Progress.spec     Spec.ProtocolVersionNegotiation.spec

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++-- | A handler that throws (rather than returning an error value) must still+-- produce a response for its request id: a -32603 internal error. Without+-- this the exception escapes the transport and the client waits forever.+-- Asynchronous exceptions are deliberately not covered here — cancellation+-- relies on them propagating, which "Spec.Cancellation" pins down.+module Spec.HandlerExceptions (spec) where++import Control.Exception (throwIO, ErrorCall (..))+import Data.Aeson+import qualified Data.Text as T+import MCP.Server+import MCP.Server.Handlers (handleMcpMessage)+import MCP.Server.JsonRpc+import Test.Hspec++throwingServer :: McpServerHandlers+throwingServer = noHandlers+  { tools = Just+      ( \_ -> pure []+      , \_ _ _ -> throwIO (ErrorCall "tool exploded")+      )+  , prompts = Just+      ( \_ -> pure []+      , \_ _ _ -> error "prompt exploded"+      )+  }++call :: T.Text -> Value -> IO (Maybe JsonRpcMessage)+call method params =+  handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints+    noNotificationSupport (\_ -> pure ()) throwingServer anonymousContext+    (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 7) method (Just params)))++errorOf :: Maybe JsonRpcMessage -> (RequestId, Int, T.Text)+errorOf (Just (JsonRpcMessageResponse r)) = case responseError r of+  Just e  -> (responseId r, errorCode e, errorMessage e)+  Nothing -> error $ "expected an error response, got " ++ show (responseResult r)+errorOf other = error $ "expected a response, got " ++ show other++spec :: Spec+spec = describe "Handler exceptions" $ do+  it "a throwing tool handler yields -32603 for its request id" $ do+    (rid, code, msg) <- errorOf <$> call "tools/call" (object ["name" .= ("x" :: T.Text), "arguments" .= object []])+    rid `shouldBe` RequestIdNumber 7+    code `shouldBe` (-32603)+    msg `shouldSatisfy` T.isInfixOf "tool exploded"++  it "a throwing prompt handler yields -32603 (pure error, forced inside the handler)" $ do+    (rid, code, msg) <- errorOf <$> call "prompts/get" (object ["name" .= ("x" :: T.Text), "arguments" .= object []])+    rid `shouldBe` RequestIdNumber 7+    code `shouldBe` (-32603)+    msg `shouldSatisfy` T.isInfixOf "prompt exploded"

@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Drive the Streamable HTTP transport in-process through the exported+-- WAI application, without Warp or a socket. The handler-level specs pin+-- what 'handleMcpMessage' answers; these pin what actually reaches an+-- HTTP client, which is the layer that used to lose a throwing handler+-- (a bare Warp 500 for single-JSON responses, a dropped connection for+-- SSE ones).+module Spec.HttpTransport (spec) where++import Control.Exception (ErrorCall (..), throwIO)+import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import MCP.Server+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai+import Network.Wai.Internal (ResponseReceived (..))+import Test.Hspec++server :: McpServerHandlers+server = noHandlers+  { tools = Just+      ( \_ -> pure []+      , \_ name _ -> case name of+          "boom" -> throwIO (ErrorCall "tool exploded")+          "ok"   -> pure $ Right $ toToolResult ("fine" :: Text)+          _      -> pure $ Left $ UnknownTool name+      )+  }++app :: Wai.Application+app = mcpApplication defaultHttpConfig { httpAllowedOrigins = Nothing }+        (McpServerInfo "T" "1" "") server++-- | POST a JSON body to /mcp and collect the full response, whether it was+-- sent as a single body or streamed (SSE).+post :: [HTTP.Header] -> Value -> IO (HTTP.Status, [HTTP.Header], BS.ByteString)+post extraHeaders body = do+  chunks <- newIORef (BSL.toChunks (encode body))+  let nextChunk = atomicModifyIORef' chunks $ \cs -> case cs of+        []     -> ([], BS.empty)+        (c:cs') -> (cs', c)+      req = Wai.setRequestBodyChunks nextChunk Wai.defaultRequest+        { Wai.requestMethod = "POST"+        , Wai.rawPathInfo = "/mcp"+        , Wai.pathInfo = ["mcp"]+        , Wai.requestHeaders =+            ("Content-Type", "application/json")+              : ("Accept", "application/json, text/event-stream")+              : extraHeaders+        }+  out <- newIORef mempty+  result <- newIORef Nothing+  _ <- app req $ \resp -> do+    let (status, headers, withBody) = Wai.responseToStream resp+    withBody $ \streamingBody ->+      streamingBody (\b -> modifyIORef' out (<> b)) (pure ())+    writeIORef result (Just (status, headers))+    pure ResponseReceived+  Just (status, headers) <- readIORef result+  bytes <- BSL.toStrict . B.toLazyByteString <$> readIORef out+  pure (status, headers, bytes)++toolCall :: Text -> [(Key, Value)] -> Value+toolCall name meta = object+  [ "jsonrpc" .= ("2.0" :: Text)+  , "id" .= (7 :: Int)+  , "method" .= ("tools/call" :: Text)+  , "params" .= object+      ([ "name" .= name, "arguments" .= object [] ]+        ++ [ "_meta" .= object meta | not (null meta) ])+  ]++-- | The JSON-RPC error (code, message) in a response body, or in the+-- last SSE data event of a streamed one.+errorIn :: BS.ByteString -> Maybe (Int, Text)+errorIn raw = do+  let payload = case [ BS.drop 6 l | l <- BS.split 10 raw, "data: " `BS.isPrefixOf` l ] of+        [] -> raw+        ls -> last ls+  Object o <- decodeStrict payload+  Object e <- KM.lookup "error" o+  Number c <- KM.lookup "code" e+  String m <- KM.lookup "message" e+  pure (round c, m)++spec :: Spec+spec = describe "HTTP transport (in-process WAI)" $ do+  it "answers a normal tool call with 200 and a result" $ do+    (status, _, body) <- post [] (toolCall "ok" [])+    HTTP.statusCode status `shouldBe` 200+    body `shouldSatisfy` ("\"fine\"" `BS.isInfixOf`)++  it "answers a throwing handler with 200 and a -32603 body (legacy, single-JSON)" $ do+    (status, headers, body) <- post [] (toolCall "boom" [])+    HTTP.statusCode status `shouldBe` 200+    lookup "Content-Type" headers `shouldBe` Just "application/json"+    fmap fst (errorIn body) `shouldBe` Just (-32603)+    fmap snd (errorIn body) `shouldSatisfy` maybe False (T.isInfixOf "tool exploded")++  it "answers a throwing handler inside the SSE stream (legacy, progressToken)" $ do+    (status, headers, body) <- post [] (toolCall "boom" ["progressToken" .= ("t1" :: Text)])+    HTTP.statusCode status `shouldBe` 200+    lookup "Content-Type" headers `shouldBe` Just "text/event-stream"+    body `shouldSatisfy` ("data: " `BS.isPrefixOf`)+    fmap fst (errorIn body) `shouldBe` Just (-32603)++  it "answers a throwing handler with a -32603 body (modern 2026-07-28)" $ do+    (status, _, body) <- post+      [ ("MCP-Protocol-Version", "2026-07-28")+      , ("Mcp-Method", "tools/call")+      , ("Mcp-Name", "boom")+      ]+      (toolCall "boom" ["io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)])+    HTTP.statusCode status `shouldBe` 200+    fmap fst (errorIn body) `shouldBe` Just (-32603)+    -- an error carries no result envelope+    body `shouldSatisfy` (not . ("resultType" `BS.isInfixOf`))