mcp-server 0.3.0.0 → 0.3.0.1

raw patch · 51 files changed

+2929/−235 lines, 51 filesdep +cryptondep +ramdep +timedep ~basedep ~template-haskelldep ~textnew-component:exe:ask-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: crypton, ram, time

Dependency ranges changed: base, template-haskell, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +87/−0
• README.md +185/−25
• examples/Ask/Main.hs +125/−0
• examples/Ask/Types.hs +50/−0
• examples/Complete/Types.hs +1/−1
• examples/HttpSimple/Main.hs +1/−3
• examples/Simple/Main.hs +1/−3
• mcp-server.cabal +32/−1
• src/MCP/Server.hs +19/−0
• src/MCP/Server/Ask.hs +339/−0
• src/MCP/Server/Derive.hs +180/−19
• src/MCP/Server/Derive/Internal.hs +26/−24
• src/MCP/Server/Handlers.hs +83/−59
• src/MCP/Server/Internal/InputRound.hs +182/−0
• src/MCP/Server/Internal/Json.hs +50/−0
• src/MCP/Server/JsonRpc.hs +2/−0
• src/MCP/Server/Notifications.hs +2/−2
• src/MCP/Server/Protocol.hs +3/−1
• src/MCP/Server/RequestState.hs +157/−0
• src/MCP/Server/Transport/Http.hs +42/−19
• src/MCP/Server/Transport/Stdio.hs +11/−1
• src/MCP/Server/Types.hs +168/−11
• test/AskTypes.hs +135/−0
• test/HspecMain.hs +6/−0
• test/Spec/AskMonad.hs +258/−0
• test/Spec/BasicDerivation.hs +2/−2
• test/Spec/Cancellation.hs +14/−10
• test/Spec/DerivedAsk.hs +200/−0
• test/Spec/DerivedOutput.hs +7/−7
• test/Spec/GoldenWire.hs +40/−8
• test/Spec/HandlerExceptions.hs +2/−1
• test/Spec/HttpTransport.hs +59/−5
• test/Spec/InputRequired.hs +369/−0
• test/Spec/ModernEra.hs +3/−2
• test/Spec/Progress.hs +4/−3
• test/Spec/Subscriptions.hs +2/−1
• test/Spec/TemplatesCompletions.hs +5/−4
• test/Spec/ToolCallParsing.hs +4/−5
• test/Spec/TypedArgs.hs +5/−5
• test/Spec/UnicodeHandling.hs +6/−6
• test/TestHelpers.hs +24/−6
• test/golden/README.md +10/−1
• test/golden/legacy/tools-call-input-required.request.json +1/−0
• test/golden/legacy/tools-call-input-required.response.json +1/−0
• test/golden/manifest.json +20/−0
• test/golden/modern/tools-call-input-required.request.json +1/−0
• test/golden/modern/tools-call-input-required.response.json +1/−0
• test/golden/modern/tools-call-input-unsupported.request.json +1/−0
• test/golden/modern/tools-call-input-unsupported.response.json +1/−0
• test/golden/modern/tools-call-invalid-request-state.request.json +1/−0
• test/golden/modern/tools-call-invalid-request-state.response.json +1/−0

@@ -1,5 +1,92 @@ # Revision history for mcp-server +## 0.3.0.1 - 2026-10-20++Handlers can ask the user for input part-way through a request: the+multi round-trip requests of MCP 2026-07-28 (ADR 0009).++### Upgrading from 0.3.0.0++* Derived handlers (`derive*Handler`) need no changes.+* Hand-written `ToolCallHandler`, `PromptGetHandler` and+  `ResourceReadHandler` functions return `Outcome`: wrap results in+  `Complete`, e.g. `Right (Complete result)`.+* Code that builds a `ClientContext` by hand should start from+  `anonymousContext` and record-update it; the type gained fields.+* `mcpApplication` returns `IO Application`: bind it before handing it+  to Warp.+* Code that calls `handleMcpMessage` directly passes a `StateCodec` after+  the `CacheHints`; `handlePromptsGet`, `handleResourcesRead` and+  `handleToolsCall` take one as their first argument. One from+  `ephemeralStateCodec` will do.+* `MCP.Server` now exports the names of `MCP.Server.Ask` (`Ask`, `elicit`,+  `elicitUrl`, `step`, `Form`, `Answer(..)`, `HandlerMonad`, `runAsk`,+  `askContext`): hide or qualify them where they clash with your own.+* `MCP.Server.Derive` now exports aeson's `Value`, so a module that also+  imports `Value` from `Data.Aeson` may get a redundant-import warning;+  drop one of the two.++### Asking for input++* Derived handlers can ask: the `derive*Handler` functions accept+  handlers returning `Ask` as well as `IO` (through the new+  `HandlerMonad` class), so a handler starts asking by changing its+  type. `elicit` asks for a form and `elicitUrl` sends the user to a URL;+  the answer is `Accepted`, `Declined`, `Cancelled` or, without a round+  trip when the client cannot ask, `Unavailable`.+* `deriveForm`, `deriveFormWithDescription` and `deriveFormWithOptions`+  (labels and defaults, via `FormFieldOptions`) derive the new `Form`+  class from flat records. Fields a form cannot hold, options for unknown+  fields and defaults that do not fit their field are compile-time+  errors. `MCP.Server.Derive` re-exports aeson's `Value` for writing+  defaults.+* The `Ask` monad (new module `MCP.Server.Ask`, re-exported by+  `MCP.Server`) runs a handler from the start on every round against a+  journal of earlier rounds: answers and `step` results are recorded once+  and replayed. A handler that asks something different at a position+  fails rather than receiving the wrong answer. `runAsk` runs one from a+  hand-written handler.+* Low level: call handlers return `Outcome` (`Complete`, or+  `InputRequired` with requests and state), answered as an+  `input_required` result. Retries carry the answers in+  `clientInputResponses` and the handler's state in+  `clientRequestState`; `clientSupportsInput` checks the client's+  protocol revision and declared capabilities.+* The `requestState` sent to clients is sealed by a `StateCodec` (new+  module `MCP.Server.RequestState`): ChaCha20-Poly1305, bound to the+  caller, the request's parameters and an expiry (60 minutes by+  default), and verified before the handler runs. The default key is+  random per process; multi-instance HTTP deployments set a shared key+  with `httpStateCodec` and `aeadStateCodec`, which supports rotation.+  `stdioStateCodec` does the same for stdio.+* New example `ask-example` (`examples/Ask`): a table-booking server whose+  tools ask the user for details and confirmation.++### Other changes++* `deriveToolHandlerWithOutput` and its variants no longer need+  `toJSON`, `object` and `.=` from `Data.Aeson` in scope where they are+  spliced: the generated serializer looked those names up in the user's+  module.+* Documentation: every module has a header and every export a doc+  comment, and Haddock links that were ambiguous or out of scope are+  fixed.+* New dependencies: `crypton` (1.1.4 to 2.2), `ram` and `time`.++### Breaking changes, in full++* `ToolCallHandler`, `PromptGetHandler` and `ResourceReadHandler` return+  `Outcome`.+* `ClientContext` gains `clientInputResponses` and `clientRequestState`;+  `StdioConfig` and `HttpConfig` gain `stdioStateCodec` and+  `httpStateCodec`.+* `handleMcpMessage`, `handlePromptsGet`, `handleResourcesRead` and+  `handleToolsCall` take a `StateCodec`.+* `mcpApplication` returns `IO Application`, creating the default key+  once.+* `MCP.Server` exports `MCP.Server.Ask`, and `MCP.Server.Derive` exports+  aeson's `Value`: new names that can clash with or duplicate yours.+ ## 0.3.0.0 - 2026-10-16  * Raw JSON Schema keywords (ADR 0014): `SchemaRaw` is a new `SchemaType`

@@ -45,7 +45,7 @@  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):+[`examples/Complete`](https://github.com/drshade/haskell-mcp-server/blob/main/examples/Complete/Types.hs):  ```haskell data ShippingSpeed = Standard | Express | Overnight@@ -61,7 +61,8 @@     | ... ``` -`tools/list` returns exactly this (captured from the running example):+`tools/list` returns exactly this (captured from the running example; a+field without a description is described by its name):  ```json {@@ -72,14 +73,16 @@     "type": "object",     "required": ["speed", "shipTo"],     "properties": {-      "speed":  { "type": "string", "enum": ["standard", "express", "overnight"] },+      "speed":  { "type": "string", "enum": ["standard", "express", "overnight"],+                  "description": "speed" },       "shipTo": {         "type": "object",+        "description": "shipTo",         "required": ["street", "city"],         "properties": {-          "street":  { "type": "string" },-          "city":    { "type": "string" },-          "zipCode": { "type": "string" }+          "street":  { "type": "string", "description": "street" },+          "city":    { "type": "string", "description": "city" },+          "zipCode": { "type": "string", "description": "zipCode" }         }       }     }@@ -175,7 +178,7 @@  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:+repository's [`Dockerfile`](https://github.com/drshade/haskell-mcp-server/blob/main/Dockerfile) builds all the examples:  ```bash docker build -t haskell-mcp-server .@@ -228,7 +231,7 @@ recursively until a record is found:  ```haskell-data SetValueParams = SetValueParams { key :: Text, value :: Text }+data SetValueParams = SetValueParams { setKey :: Text, setValue :: Text }  data SimpleTool     = GetValue { key :: Text }@@ -292,7 +295,7 @@  ### Descriptions, annotations and icons -Every `derive*` function has a `WithDescription` variant taking a flat list of+Every `derive*Handler` and `deriveResourceTemplates` 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@@ -400,7 +403,7 @@  - 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 [])`+  [examples](https://github.com/drshade/haskell-mcp-server/tree/main/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@@ -415,11 +418,15 @@  ```haskell promptListHandler :: ClientContext -> IO [PromptDefinition]-promptGetHandler  :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult)+promptGetHandler  :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error (Outcome PromptResult))  handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) } ``` +`tools/call`, `prompts/get` and `resources/read` handlers return an+`Outcome`: `Complete result`, or a request for input (see+[Asking the user for input](#asking-the-user-for-input)).+ Tool schemas built by hand can use `SchemaRaw` for anything the typed shapes cannot express — `null`, `anyOf`, `$defs` and `$ref`, numeric bounds — and it is serialized as given:@@ -450,7 +457,7 @@ ### Streamable HTTP  ```haskell-import MCP.Server.Transport.Http+import MCP.Server  main = runMcpServerHttp serverInfo handlers            -- localhost:3000/mcp @@ -495,13 +502,17 @@ import MCP.Server (mcpApplication, defaultHttpConfig) import qualified Network.Wai.Handler.Warp as Warp -main = Warp.runSettings mySettings $ \req respond ->-    -- route /mcp to the MCP endpoint, everything else to your app-    mcpApplication defaultHttpConfig serverInfo handlers req respond+main = do+    mcp <- mcpApplication defaultHttpConfig serverInfo handlers+    Warp.runSettings mySettings $ \req respond ->+        -- route /mcp to the MCP endpoint, everything else to your app+        mcp req respond ``` -`httpPort` and `httpHost` are ignored when embedding; the endpoint path,-Origin validation, bearer auth and streaming all apply as usual.+Build the application once: it holds the key that protects multi+round-trip state. `httpPort` and `httpHost` are ignored when embedding; the+endpoint path, Origin validation, bearer auth and streaming all apply as+usual.  ## Long-running tools @@ -559,6 +570,150 @@ Requests are served concurrently on both transports. Handlers touching shared mutable state must synchronize with `MVar`, `STM` or similar. +## Asking the user for input++A tool, prompt or resource handler can stop part-way through and ask the+user something: a form to fill in, or a URL to visit. This uses the+2026-07-28 multi round-trip requests. Give the handler the type `Ask`+instead of `IO`, derive forms from the records you want back, and write+the questions in order, as if the handler could wait for the answers:++```haskell+data Environment = Staging | Production++data DeployTarget = DeployTarget+  { environment :: Environment     -- a choice: staging, production+  , reason      :: Text+  , notify      :: Maybe Bool      -- optional+  }++newtype Confirm = Confirm { proceed :: Bool }++data OpsTool = Deploy { service :: Text } | Status { service :: Text }++$(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")])+$(deriveForm ''Confirm)++handleTool :: ClientContext -> OpsTool -> Ask Content+handleTool _ (Deploy svc) = do+  target <- elicit ("Where should " <> svc <> " deploy to?")+  case target of+    Accepted t -> do+      plan <- step (planDeploy svc (environment t))      -- runs once+      ok   <- elicit ("Apply " <> describePlan plan <> "?")+      case ok of+        Accepted (Confirm True) -> ContentText <$> step (applyPlan plan)+        _                       -> pure (ContentText "Deployment cancelled")+    Unavailable -> pure (ContentText "This client cannot ask where to deploy")+    _           -> pure (ContentText "No target chosen")+handleTool _ (Status svc) = ContentText <$> liftIO (currentStatus svc)++tools = Just $(deriveToolHandler ''OpsTool 'handleTool)+```++`elicit` picks the form from the type the code expects back, so+`Accepted (Confirm True)` is all it takes to ask the `Confirm` form. The+answer is `Accepted` with the submitted record, `Declined` or `Cancelled`,+or `Unavailable`, without a round trip, when the client cannot ask: it+speaks an older protocol revision or did not declare form elicitation.+`elicitUrl` sends the user to a URL instead.++The `derive*Handler` functions take `IO` and `Ask` handlers alike, so a+handler switches by changing its type. A tool that never asks, like+`Status`, finishes in one round; plain IO runs in `Ask` through `liftIO`.+Structured output works the same way: return `Ask (ToolOutput a)`.++### Forms++`deriveForm` builds the form's schema and its parser from a record.+Elicitation forms are flat, so the fields can be `Text`, `Int`, `Integer`,+`Double`, `Float`, `Bool`, enumerations (offered as snake_cased choices),+lists of enumerations (several choices) and `Maybe` of these for optional+fields. Anything else, such as a nested record, is a compile-time error+naming the field. `deriveFormWithDescription` adds help text per field, and+`deriveFormWithOptions` also sets labels and starting values:++```haskell+$(deriveFormWithOptions ''DeployTarget+    [ ("environment", defaultFormFieldOptions+        { formFieldTitle = Just "Environment", formFieldDefault = Just "staging" })+    , ("reason", defaultFormFieldOptions { formFieldDescription = Just "Why deploy now?" })+    ])+```++A default that does not fit its field, or an option for a field the record+does not have, is also a compile-time error. `deriveForm` is a declaration splice, and+Template Haskell lets later splices see only the types declared above the+last declaration splice, so declare the tool, prompt and resource types+before the `deriveForm` lines (or in another module). For a form a record cannot+describe, write the `Form` instance by hand: a schema and a parser.++### How it works, and the rules that follow++The handler does not pause between rounds. Each round ends the request:+the client asks the user, then sends the request again with the answer,+possibly to another server instance. So the handler runs again from the+start, and the library replays a journal of what earlier rounds produced,+kept in the state the client carries: `elicit` returns the recorded+answer, or ends the round with its question; `step` returns its recorded+result instead of running the action again.++- **Ask the same questions and run the same steps in the same order on+  every round.** A handler that strays from its journal fails with an+  internal error naming the position, rather than receiving the answer to+  a different question.+- **`step` is at-least-once.** A client that retries from an earlier state+  runs later steps again. Make effects that must happen once idempotent.+- **`step` results travel to the client and back**, encrypted, on every+  later round: return an id rather than the whole object. Plain `liftIO` is+  not journaled and runs on every round; use it for reads.++### Protecting the state++The library protects the state the client carries between rounds: it is+encrypted, and bound to the caller, the request's arguments and an expiry+(60 minutes by default), and a retry presenting tampered, expired or+misdirected state is rejected before the handler runs. By default the key+is random per process, which suits stdio and a single HTTP instance. HTTP+deployments with several instances must share a key:++```haskell+main = do+  secret <- readSecret                                  -- 32 bytes, shared by every instance+  key <- maybe (fail "state key must be 32 bytes") pure (stateKey "2026-10" secret)+  runMcpServerHttpWithConfig defaultHttpConfig+    { httpStateCodec = Just (aeadStateCodec key []) }   -- to rotate: aeadStateCodec new [old]+    serverInfo handlers+```++### Low-level handlers++Hand-written call handlers return an `Outcome`: `Complete` with the result,+or `InputRequired` with requests keyed by ids of the handler's choosing and+some state of its own. On the retry the handler sees the answers in+`clientInputResponses` and its state in `clientRequestState`:++```haskell+deploy :: ToolCallHandler+deploy ctx _ _ = pure $ Right $+  case Map.lookup "confirm" (clientInputResponses ctx) of+    Nothing | clientSupportsInput ctx question ->+      InputRequired (Map.singleton "confirm" question) (Just "step-1")+    Just (ElicitResponse ElicitAccept (Just answer))+      | Map.lookup "ok" answer == Just (Bool True) ->+          Complete (toolResult [ContentText "Deployed"])+    _ -> Complete (toolError "Not confirmed")+  where+    question = ElicitForm "Deploy to production?"+      (schema (SchemaObject [("ok", schema SchemaBoolean)] ["ok"]))+```++`clientSupportsInput` says whether the client can answer: it must speak+2026-07-28 and have declared the elicitation mode (or sampling, or roots)+in question. Asking a client that cannot answer is reported as an internal+error, so check first and fall back. A low-level handler can also run an+`Ask` computation with `runAsk`, which is what the derived handlers do.+ ## Change notifications  Servers whose tool, prompt or resource lists change at runtime can push@@ -596,30 +751,35 @@ | Progress and per-request logging | ✅ | ✅ | | Cancellation | ✅ | ✅ | | Change notifications | stdio only | `subscriptions/listen` (stdio and HTTP) |+| Asking for input (multi round-trip requests) | — | `Ask` handlers and derived forms, protected `requestState` | | Result typing and cacheability hints | — | `resultType`, `httpCacheHints` | | HTTP request-metadata headers | — | `MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` validated | -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).+Design decisions and planned work (OAuth resource metadata, pagination,+the tasks extension) live as ADRs under+[`specs/`](https://github.com/drshade/haskell-mcp-server/blob/main/specs/README.md), ordered by [`specs/ROADMAP.md`](https://github.com/drshade/haskell-mcp-server/blob/main/specs/ROADMAP.md).  ## Examples -- [`examples/Simple/`](examples/Simple/): a key-value store with two tools over stdio.-- [`examples/Complete/`](examples/Complete/): prompts, resources, a resource+- [`examples/Simple/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/Simple): a key-value store with two tools over stdio.+- [`examples/Complete/`](https://github.com/drshade/haskell-mcp-server/tree/main/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+- [`examples/Ask/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/Ask): tools that ask the user for input+  part-way through: a table booking with a derived form, a confirmation+  and a fallback for clients that cannot ask.+- [`examples/HttpSimple/`](https://github.com/drshade/haskell-mcp-server/tree/main/examples/HttpSimple): the key-value store over   Streamable HTTP.  ```bash cabal run simple-example        # stdio; type JSON-RPC on stdin+cabal run ask-example           # stdio; asks for input (2026-07-28 clients) cabal run http-simple-example   # http://localhost:3000/mcp ```  ## Conformance corpus -The wire-format fixtures under [`test/golden/`](test/golden/README.md) are a+The wire-format fixtures under [`test/golden/`](https://github.com/drshade/haskell-mcp-server/blob/main/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@@ -635,7 +795,7 @@ ## Contributing  Contributions are welcome. See the issue tracker for open issues and feature-requests, and [RELEASING.md](RELEASING.md) for how versions reach Hackage.+requests, and [RELEASING.md](https://github.com/drshade/haskell-mcp-server/blob/main/RELEASING.md) for how versions reach Hackage.  ## AI assistance 

@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Tools that ask the user for input part-way through (multi round-trip+-- requests, MCP 2026-07-28). Run it, then watch stderr while a client+-- books a table: the handler replays from the top on every round, but each+-- 'step' runs once in a normal booking, its result replayed afterwards.+--+-- 'step' is at-least-once, though: a client that retries a round with an+-- earlier state (say, after losing a reply) runs the steps after that point+-- again. A real 'confirmBooking' must therefore be idempotent, for example+-- by keying the booking on something the retry repeats.+module Main where++import           Control.Monad.IO.Class (liftIO)+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Time.Clock.POSIX  (getPOSIXTime)+import           MCP.Server+import           MCP.Server.Derive+import           System.IO              (hPutStrLn, hSetEncoding, stderr,+                                         stdout, utf8)+import           Types++-- Returning 'Ask' instead of 'IO' is all it takes to ask questions.+handleTool :: ClientContext -> BookingTool -> Ask Content+handleTool _ (BookTable place) = do+    -- Ask for the details. 'elicit' picks the form from the type the+    -- answer is used at: BookingDetails.+    answer <- elicit ("Booking a table at " <> place <> ". What do you need?")+    case answer of+        Accepted details -> do+            -- Work between questions goes in 'step': it runs once, and+            -- its result is replayed on later rounds.+            offer <- step (findTable place details)+            ok <- elicit ("Book " <> offer <> "?")+            case ok of+                Accepted (Confirm True) -> do+                    ref <- step (confirmBooking offer)+                    pure $ ContentText $ "Booked " <> offer <> ". Your reference is " <> ref <> "."+                _ -> pure $ ContentText "No problem, nothing was booked."+        Declined  -> pure $ ContentText "No problem, nothing was booked."+        Cancelled -> pure $ ContentText "Booking cancelled."+        -- The client cannot show forms (an older protocol revision, or no+        -- elicitation capability): no round trip happens, so say what to do.+        Unavailable -> pure $ ContentText $+            "I can't ask for booking details in this client. Please call "+                <> place <> " to book."++handleTool _ (CancelBooking ref) = do+    ok <- elicit ("Cancel booking " <> ref <> "? This cannot be undone.")+    case ok of+        Accepted (Confirm True) -> do+            _ <- step (cancelBooking ref)+            pure $ ContentText $ "Booking " <> ref <> " is cancelled."+        -- Cancelling without confirmation would be destructive: refuse.+        Unavailable -> pure $ ContentText "Cancelling needs confirmation, which this client can't ask for."+        _ -> pure $ ContentText $ "Booking " <> ref <> " is unchanged."++-- A tool that never asks finishes in one round; plain IO goes through liftIO.+handleTool _ (OpeningHours place) =+    ContentText <$> liftIO (lookupHours place)++-- The "back end". Each logs to stderr so you can see when it runs.++findTable :: Text -> BookingDetails -> IO Text+findTable place details = do+    logLine $ "finding a table at " <> place <> " for " <> T.pack (show details)+    pure $ "a table for " <> T.pack (show (partySize details)) <> " at " <> place+        <> ", " <> slotTime (slot details)+        <> (if null (dietary details) then "" else " (kitchen notified: "+              <> T.intercalate ", " (map dietLabel (dietary details)) <> ")")+        <> (if highChair details == Just True then " with a high chair" else "")++-- Not idempotent: a retried final round would book again under a new+-- reference. Fine for a demo; see the note at the top of the module.+confirmBooking :: Text -> IO Text+confirmBooking offer = do+    now <- getPOSIXTime+    let ref = "BK-" <> T.pack (show (floor now `mod` (100000 :: Integer)))+    logLine $ "booked " <> offer <> " as " <> ref+    pure ref++cancelBooking :: Text -> IO ()+cancelBooking ref = logLine $ "cancelled " <> ref++lookupHours :: Text -> IO Text+lookupHours place = pure $ place <> " is open 12:00-15:00 and 17:30-23:00, Tuesday to Sunday."++slotTime :: Slot -> Text+slotTime Lunch       = "13:00"+slotTime EarlyDinner = "18:00"+slotTime LateDinner  = "20:30"++dietLabel :: Diet -> Text+dietLabel Vegetarian = "vegetarian"+dietLabel Vegan      = "vegan"+dietLabel GlutenFree = "gluten-free"+dietLabel NutAllergy = "nut allergy"++logLine :: Text -> IO ()+logLine = hPutStrLn stderr . ("[bookings] " <>) . T.unpack++main :: IO ()+main = do+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8+    runMcpServerStdio+        McpServerInfo+            { serverName = "Table Booking Example"+            , serverVersion = "0.1.0"+            , serverInstructions = "Books restaurant tables, asking the user for the details."+            }+        noHandlers+            { tools = Just $(deriveToolHandlerWithOptions ''BookingTool 'handleTool+                [ ("BookTable", defaultDefinitionOptions+                    { optDescription = Just "Book a table at a restaurant; asks the user for the details" })+                , ("CancelBooking", defaultDefinitionOptions+                    { optDescription = Just "Cancel a booking by its reference, after confirming with the user"+                    , optToolAnnotations = Just defaultToolAnnotations { toolDestructiveHint = Just True } })+                , ("OpeningHours", defaultDefinitionOptions+                    { optDescription = Just "A restaurant's opening hours"+                    , optToolAnnotations = Just defaultToolAnnotations { toolReadOnlyHint = Just True } })+                ])+            }

@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Types where++import           Data.Text         (Text)+import           MCP.Server.Derive++-- The tools. Declared above the deriveForm splices below: a splice only+-- sees the types declared above the last declaration splice.+data BookingTool+    = BookTable { restaurant :: Text }+    | CancelBooking { reference :: Text }+    | OpeningHours { restaurant :: Text }+    deriving (Show, Eq)++-- The forms: plain records whose answers the handlers want back.++-- An enumeration is offered as a choice ("lunch", "early_dinner", ...)+data Slot = Lunch | EarlyDinner | LateDinner+    deriving (Show, Eq)++data Diet = Vegetarian | Vegan | GlutenFree | NutAllergy+    deriving (Show, Eq)++data BookingDetails = BookingDetails+    { partySize :: Int+    , slot      :: Slot+    , dietary   :: [Diet]       -- a list of an enumeration: pick several+    , highChair :: Maybe Bool   -- Maybe: the user may leave it out+    } deriving (Show, Eq)++-- A yes/no question is a one-field form+newtype Confirm = Confirm { confirmed :: Bool }+    deriving (Show, Eq)++-- Labels, help text and starting values for the form's fields. A default+-- that does not fit its field is a compile-time error.+$(deriveFormWithOptions ''BookingDetails+    [ ("partySize", defaultFormFieldOptions+        { formFieldTitle = Just "Party size", formFieldDefault = Just (Number 2) })+    , ("slot", defaultFormFieldOptions+        { formFieldTitle = Just "Time", formFieldDefault = Just "early_dinner" })+    , ("dietary", defaultFormFieldOptions+        { formFieldTitle = Just "Dietary requirements"+        , formFieldDescription = Just "Tick any that apply to your party" })+    , ("highChair", defaultFormFieldOptions { formFieldTitle = Just "Need a high chair?" })+    ])++$(deriveFormWithDescription ''Confirm [("confirmed", "Tick to confirm")])

@@ -4,7 +4,7 @@  import           Data.Text (Text) --- High-level data type definitions from SPEC.md+-- High-level data type definitions (see specs/ADR_0001_original_spec.md)  data MyPrompt     = Recipe { idea :: Text }

@@ -23,9 +23,7 @@                 Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found"                 Just v  -> pure $ ContentText v         handleTool _ (SetValue k v) = do-            pairs <- readIORef store-            let newPairs = (k, v) : filter ((/= k) . fst) pairs-            writeIORef store newPairs+            atomicModifyIORef' store $ \pairs -> ((k, v) : filter ((/= k) . fst) pairs, ())             pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'"      -- Derive the tool handlers using Template Haskell with descriptions

@@ -23,9 +23,7 @@                 Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found"                 Just v  -> pure $ ContentText v         handleTool _ (SetValue k v) = do-            pairs <- readIORef store-            let newPairs = (k, v) : filter ((/= k) . fst) pairs-            writeIORef store newPairs+            atomicModifyIORef' store $ \pairs -> ((k, v) : filter ((/= k) . fst) pairs, ())             pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'"      -- Derive the tool handlers using Template Haskell with descriptions

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.3.0.0+version: 0.3.0.1 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -71,17 +71,21 @@   -- Modules exported by the library.   exposed-modules:     MCP.Server+    MCP.Server.Ask     MCP.Server.Derive     MCP.Server.Handlers     MCP.Server.JsonRpc     MCP.Server.Notifications     MCP.Server.Protocol+    MCP.Server.RequestState     MCP.Server.Transport.Http     MCP.Server.Transport.Stdio     MCP.Server.Types    other-modules:     MCP.Server.Derive.Internal+    MCP.Server.Internal.InputRound+    MCP.Server.Internal.Json    -- Modules included in this library but not exported.   -- other-modules:@@ -95,12 +99,15 @@     base64-bytestring >=1.0 && <1.3,     bytestring >=0.10 && <0.13,     containers >=0.6 && <0.9,+    crypton >=1.1.4 && <2.3,     http-types >=0.12 && <1,     network-uri >=2.6 && <2.8,+    ram >=0.20.1 && <0.23,     scientific >=0.3 && <0.4,     stm >=2.5 && <2.6,     template-haskell >=2.16 && <2.25,     text >=1.2 && <3,+    time >=1.9 && <1.17,     wai >=3.2 && <4,     warp >=3.3 && <4, @@ -150,6 +157,25 @@   -- Base language which the package is written in.   default-language: GHC2021 +executable ask-example+  -- Import common warning flags.+  import: warnings+  -- .hs or .lhs file containing the Main module.+  main-is: Main.hs+  -- Modules included in this executable, other than Main.+  other-modules: Types+  -- Other library packages from which modules are imported.+  build-depends:+    base,+    mcp-server,+    text,+    time,++  -- Directories containing source files.+  hs-source-dirs: examples/Ask+  -- Base language which the package is written in.+  default-language: GHC2021+ executable http-simple-example   -- Import common warning flags.   import: warnings@@ -179,14 +205,18 @@   default-language: GHC2021   -- Modules included in this executable, other than Main.   other-modules:+    AskTypes     Spec.AdvancedDerivation+    Spec.AskMonad     Spec.BasicDerivation     Spec.Cancellation     Spec.DefinitionMetadata+    Spec.DerivedAsk     Spec.DerivedOutput     Spec.GoldenWire     Spec.HandlerExceptions     Spec.HttpTransport+    Spec.InputRequired     Spec.JSONConversion     Spec.ModernEra     Spec.Progress@@ -224,5 +254,6 @@     mcp-server,     network-uri,     stm,+    template-haskell,     text,     wai,

@@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Build an MCP server: run it over stdio or HTTP, or mount it as a WAI+-- application, with the handler and definition types re-exported from+-- "MCP.Server.Types". "MCP.Server.Derive" generates handlers from data+-- types. module MCP.Server   ( -- * Server Runtime     runMcpServerStdio@@ -15,6 +19,19 @@   , defaultHttpConfig   , mcpApplication +    -- * Handlers that ask the client for input+  , module MCP.Server.Ask++    -- * Request state (multi round-trip requests)+  , StateCodec(..)+  , StateError(..)+  , StateKey+  , stateKey+  , stateKeyId+  , aeadStateCodec+  , ephemeralStateCodec+  , defaultStateLifetime+     -- * Change Notifications   , McpNotifier(..)   , NotificationSource@@ -24,6 +41,7 @@   , module MCP.Server.Types   ) where +import           MCP.Server.Ask import           MCP.Server.Notifications (McpNotifier (..), NotificationSource,                                            newMcpNotifier) import           MCP.Server.Transport.Stdio (StdioConfig (..), defaultStdioConfig,@@ -31,6 +49,7 @@                                              transportRunStdioWithConfig) import           MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig,                                             mcpApplication)+import           MCP.Server.RequestState import           MCP.Server.Types  -- | Run an MCP server using STDIO transport

@@ -0,0 +1,339 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Handlers that ask the client questions part-way through, written as+-- straight-line code.+--+-- A multi round-trip request ends each round that needs input: the client+-- answers and retries the request, possibly on another server instance.+-- So an t'Ask' handler does not pause at a question. It runs from the start+-- on every round, against a /journal/ of what earlier rounds produced, which+-- the library keeps sealed in the request state:+--+-- * 'elicit' returns the answer recorded for it, or ends the round with the+--   question when there is none yet.+-- * 'step' runs its action once, records the result, and returns the+--   recorded result on later rounds.+--+-- > confirmDelete :: ClientContext -> Text -> Ask ToolResult+-- > confirmDelete _ name = do+-- >   size <- step (fileSize name)+-- >   answer <- elicit ("Delete " <> name <> " (" <> showSize size <> ")?")+-- >   case answer of+-- >     Accepted (Confirm True) -> do+-- >       step (deleteFile name)+-- >       pure (toolResult [ContentText "Deleted"])+-- >     Unavailable -> pure (toolError "Confirmation needed: this client cannot ask")+-- >     _ -> pure (toolResult [ContentText "Kept"])+--+-- Three rules follow from replay:+--+-- * __Ask the same questions in the same order.__ Each 'elicit' and 'step'+--   takes the next position in the journal. If a round asks something+--   different at a position, the request fails with an internal error that+--   names the position, rather than passing an answer to the wrong question.+-- * __'step' is at-least-once.__ If a round's reply is lost and the client+--   retries with an earlier state, the step runs again. Effects that must+--   happen once must be idempotent or guarded on the server.+-- * __'step' results travel to the client and back__ (encrypted) on every+--   later round. Keep them small: an id rather than the object.+--+-- Plain 'liftIO' is not journaled: it runs on every round. Use it for reads+-- that may change between rounds without changing which questions are+-- asked.+--+-- Derived handlers ("MCP.Server.Derive") may return t'Ask' instead of+-- 'IO', and 'MCP.Server.Derive.deriveForm' derives t'Form' instances from+-- records.+module MCP.Server.Ask+  ( -- * Handlers that ask+    Ask+  , runAsk+  , askContext+    -- * Questions+  , Answer(..)+  , Form(..)+  , elicit+  , elicitUrl+    -- * Journaled IO+  , step+    -- * Derived handlers+  , HandlerMonad(..)+  ) where++import           Control.Monad            (ap, liftM)+import           Control.Monad.IO.Class   (MonadIO (..))+import           Data.Aeson+import qualified Data.Aeson.KeyMap        as KM+import           Data.Aeson.Types         (parseEither)+import qualified Data.ByteString.Lazy     as BSL+import           Data.Map                 (Map)+import qualified Data.Map                 as Map+import           Data.Proxy               (Proxy (..))+import           Data.Text                (Text)+import qualified Data.Text                as T+import qualified Data.Text.Encoding       as TE++import           MCP.Server.Internal.Json (jsonDigest)+import           MCP.Server.Types++-- | How the user answered a question.+data Answer a+  = Accepted a+    -- ^ The user submitted the form (for 'elicitUrl': completed the+    --   interaction).+  | Declined+    -- ^ The user explicitly declined.+  | Cancelled+    -- ^ The user dismissed the question without choosing.+  | Unavailable+    -- ^ The client cannot ask: it speaks a protocol revision without+    --   multi round-trip requests, or did not declare the elicitation+    --   mode. No round trip took place.+  deriving (Show, Eq, Functor)++-- | A form to elicit: an object of strings, numbers, booleans and+-- enumerations, as elicitation allows, and how to read what the user+-- submitted. 'formParse' defaults to the type's 'FromJSON' instance.+--+-- > data Confirm = Confirm { proceed :: Bool } deriving Generic+-- > instance FromJSON Confirm+-- > instance Form Confirm where+-- >   formSchema _ = schema $ SchemaObject [("proceed", schema SchemaBoolean)] ["proceed"]+class Form a where+  -- | The requested schema.+  formSchema :: Proxy a -> Schema+  -- | Read the submitted content, or say why it does not fit the form.+  formParse :: Map Text Value -> Either Text a+  default formParse :: FromJSON a => Map Text Value -> Either Text a+  formParse content = either (Left . T.pack) Right (parseEither parseJSON (toJSON content))++-- | A handler that can ask the client for input. Run it with 'runAsk'.+newtype Ask a = Ask (ClientContext -> Run -> IO (Round a))++-- Where a run is in the journal.+data Run = Run+  { runReplay   :: [Entry]     -- entries from earlier rounds not yet reached+  , runPending  :: Maybe Text  -- fingerprint of the question the last round asked+  , runPosition :: Int+  , runWritten  :: [Entry]     -- the journal so far, newest first+  }++data Round a+  = Done a Run+  | Suspended Int Text InputRequest [Entry]  -- position, fingerprint, request, journal+  | Failed Error++instance Functor Ask where+  fmap = liftM++instance Applicative Ask where+  pure a = Ask $ \_ run -> pure (Done a run)+  (<*>) = ap++instance Monad Ask where+  Ask m >>= k = Ask $ \ctx run -> do+    result <- m ctx run+    case result of+      Done a run'                -> let Ask m' = k a in m' ctx run'+      Suspended pos fp req entries -> pure (Suspended pos fp req entries)+      Failed err                 -> pure (Failed err)++-- | Runs on every round; not journaled.+instance MonadIO Ask where+  liftIO io = Ask $ \_ run -> (\a -> Done a run) <$> io++-- | The context of the current round's request.+askContext :: Ask ClientContext+askContext = Ask $ \ctx run -> pure (Done ctx run)++-- | Run a handler for one round: 'Complete' when it finishes, or+-- 'InputRequired' with its next question and its journal as the state.+-- Use it in a low-level call handler; derived handlers are run with it+-- for you (see t'HandlerMonad').+runAsk :: Ask a -> ClientContext -> IO (Either Error (Outcome a))+runAsk (Ask m) ctx = case readJournal (clientRequestState ctx) of+  Left err -> pure (Left (InternalError err))+  Right (Journal entries pending) -> do+    result <- m ctx Run+      { runReplay = entries+      , runPending = pending+      , runPosition = 0+      , runWritten = []+      }+    pure $ case result of+      Done a run+        | null (runReplay run), Nothing <- runPending run -> Right (Complete a)+        | otherwise -> Left $ mismatch (runPosition run)+            "the handler finished before reaching it"+      Suspended pos fp request written -> Right $ InputRequired+        (Map.singleton (positionKey pos) request)+        (Just (writeJournal (Journal written (Just fp))))+      Failed err -> Left err++-- | The monads a derived handler can run in: 'IO' for handlers that never+-- ask, and t'Ask' for handlers that do. The @derive*Handler@ splices run+-- the handler through this class, so either return type works and a handler+-- switches by changing its type alone.+class Monad m => HandlerMonad m where+  -- | Run a handler for one round of a request.+  runHandler :: ClientContext -> m a -> IO (Either Error (Outcome a))++instance HandlerMonad IO where+  runHandler _ action = Right . Complete <$> action++instance HandlerMonad Ask where+  runHandler ctx handler = runAsk handler ctx++-- | Ask the user to fill in the form for @a@, with a message.+elicit :: Form a => Text -> Ask (Answer a)+elicit message = result+  where+    result = question (ElicitForm message (formSchema (proxyOf result))) parse+    parse (Just content) = formParse content+    parse Nothing        = Left "accepted without content"+    proxyOf :: Ask (Answer a) -> Proxy a+    proxyOf _ = Proxy++-- | Send the user to a URL to complete an interaction out of band, with a+-- message. 'Accepted' means the user agreed to go; the interaction's+-- result reaches the server by other means.+elicitUrl :: Text -> URI -> Ask (Answer ())+elicitUrl message url = question (ElicitUrl message url) (const (Right ()))++-- | Run an action once, and replay its result on later rounds. The result+-- is stored in the request state, so it must survive a JSON round trip; it+-- is returned decoded on every round, the first included.+step :: (ToJSON a, FromJSON a) => IO a -> Ask a+step action = Ask $ \_ run -> case (runReplay run, runPending run) of+  (Stepped v : rest, _) -> pure $ case fromJSON v of+    Success a -> Done a (advance (Stepped v) run { runReplay = rest })+    Error err -> Failed $ InternalError $+      "the step result at position " <> showT (runPosition run)+        <> " no longer decodes: " <> T.pack err+  (_ : _, _) -> pure $ Failed $ mismatch (runPosition run) "the handler ran a step instead"+  ([], Just _) -> pure $ Failed $ mismatch (runPosition run) "the handler ran a step instead"+  ([], Nothing) -> do+    v <- toJSON <$> action+    pure $ case fromJSON v of+      Success a -> Done a (advance (Stepped v) run)+      Error err -> Failed $ InternalError $+        "the step result at position " <> showT (runPosition run)+          <> " does not decode from its own JSON: " <> T.pack err++-- A question at the next position: the request, and how to read an+-- accepted answer's content.+question :: InputRequest -> (Maybe (Map Text Value) -> Either Text a) -> Ask (Answer a)+question request parse = Ask $ \ctx run ->+  let pos = runPosition run+      key = positionKey pos+      fp = jsonDigest (toJSON request)+      record recorded = advance (Asked fp recorded) run+      suspend = Suspended pos fp request (reverse (runWritten run))+      supported = clientSupportsInput ctx request+  in pure $ case (runReplay run, runPending run) of+    (Asked fp' recorded : rest, _)+      | fp' == fp -> case answerOf parse recorded of+          Right a  -> Done a (record recorded) { runReplay = rest }+          Left err -> Failed $ InternalError $+            "the answer at position " <> key <> " no longer parses: " <> err+    (_ : _, _) -> Failed $ mismatch pos "the handler asked a different question"+    ([], Just fp')+      | fp' /= fp -> Failed $ mismatch pos "the handler asked a different question"+      | otherwise -> case Map.lookup key (clientInputResponses ctx) of+          Nothing+            | supported -> suspend+            | otherwise -> Done Unavailable (record Unavailable') { runPending = Nothing }+          Just response -> case recordResponse response >>= \r -> (,) r <$> answerOf parse r of+            Right (recorded, a) -> Done a (record recorded) { runPending = Nothing }+            Left err -> Failed $ InvalidParams $ "inputResponses: " <> key <> ": " <> err+    ([], Nothing)+      | supported -> suspend+      | otherwise -> Done Unavailable (record Unavailable')++advance :: Entry -> Run -> Run+advance entry run = run+  { runPosition = runPosition run + 1+  , runWritten = entry : runWritten run+  }++mismatch :: Int -> Text -> Error+mismatch pos what = InternalError $+  "the handler does not match its journal at position " <> showT pos <> ": "+    <> what <> ". Ask handlers must ask the same questions and run the same steps"+    <> " in the same order on every round"++positionKey :: Int -> Text+positionKey = showT++showT :: Show a => a -> Text+showT = T.pack . show++-- The journal ------------------------------------------------------------++data Journal = Journal [Entry] (Maybe Text)++data Entry+  = Asked Text Recorded  -- the question's fingerprint, and its answer+  | Stepped Value++data Recorded+  = Accepted' (Maybe (Map Text Value))+  | Declined'+  | Cancelled'+  | Unavailable'++recordResponse :: InputResponse -> Either Text Recorded+recordResponse (ElicitResponse action content) = Right $ case action of+  ElicitAccept  -> Accepted' content+  ElicitDecline -> Declined'+  ElicitCancel  -> Cancelled'+recordResponse (RawInputResponse _) = Left "expected an elicitation result"++answerOf :: (Maybe (Map Text Value) -> Either Text a) -> Recorded -> Either Text (Answer a)+answerOf parse (Accepted' content) = Accepted <$> parse content+answerOf _ Declined'               = Right Declined+answerOf _ Cancelled'              = Right Cancelled+answerOf _ Unavailable'            = Right Unavailable++instance ToJSON Entry where+  toJSON (Asked fp recorded) = object $ ("q" .= fp) : case recorded of+    Accepted' content -> ["a" .= ("accept" :: Text), "c" .= content]+    Declined'         -> ["a" .= ("decline" :: Text)]+    Cancelled'        -> ["a" .= ("cancel" :: Text)]+    Unavailable'      -> ["a" .= ("unavailable" :: Text)]+  toJSON (Stepped v) = object ["s" .= v]++instance FromJSON Entry where+  parseJSON = withObject "Entry" $ \o -> do+    -- By presence: a step's result may itself be null.+    case KM.lookup "s" o of+      Just v -> pure (Stepped v)+      Nothing -> do+        fp <- o .: "q"+        action <- o .: "a"+        Asked fp <$> case action :: Text of+          "accept"      -> Accepted' <$> o .:? "c"+          "decline"     -> pure Declined'+          "cancel"      -> pure Cancelled'+          "unavailable" -> pure Unavailable'+          _             -> fail "unknown answer"++writeJournal :: Journal -> Text+writeJournal (Journal entries pending) = TE.decodeUtf8 $ BSL.toStrict $ encode $ object+  [ "v" .= (1 :: Int)+  , "j" .= entries+  , "p" .= pending+  ]++readJournal :: Maybe Text -> Either Text Journal+readJournal Nothing = Right (Journal [] Nothing)+readJournal (Just state) =+  either (\err -> Left ("the request state is not an Ask journal: " <> T.pack err)) Right $+    eitherDecodeStrict (TE.encodeUtf8 state) >>= parseEither parser+  where+    parser = withObject "Journal" $ \o -> do+      version <- o .: "v"+      if version /= (1 :: Int)+        then fail "unsupported journal version"+        else Journal <$> o .: "j" <*> o .:? "p"

@@ -6,11 +6,15 @@ -- -- 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+-- t'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.+--+-- Handlers may return 'IO' or 'MCP.Server.Ask.Ask' (see t'HandlerMonad'):+-- an t'MCP.Server.Ask.Ask' handler can ask the user questions part-way+-- through, with forms derived by 'deriveForm'. module MCP.Server.Derive   ( -- * Template Haskell Derivation     derivePromptHandler@@ -29,21 +33,34 @@   , deriveToolHandlerWithOutputDescription   , deriveToolHandlerWithOutputOptions +    -- * Forms for elicitation+  , deriveForm+  , deriveFormWithDescription+  , deriveFormWithOptions+  , FormFieldOptions(..)+  , defaultFormFieldOptions+  , Value(..)+     -- * Per-constructor customization   , DefinitionOptions(..)   , defaultDefinitionOptions   ) where  import           Control.Monad       (zipWithM)-import           Data.Aeson          (Value (..))+-- Names used inside quotes must be imported here, or the generated code+-- looks them up in the user's module instead.+import           Data.Aeson          (Value (..), encode, object, toJSON, (.=))+import qualified Data.ByteString.Lazy as BSL import           Data.List           (intercalate) import           Data.Maybe          (fromMaybe) import           Data.Text           (Text) import qualified Data.Text           as T+import qualified Data.Text.Encoding  as TE import           Language.Haskell.TH import           Language.Haskell.TH.Syntax (Lift, lift) import qualified Data.Char           as Char +import           MCP.Server.Ask      (Form (..), HandlerMonad (..)) import           MCP.Server.Derive.Internal import           MCP.Server.Types @@ -437,7 +454,7 @@ derivePromptHandlerWithDescription typeName handlerName descriptions =   derivePromptHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions --- | Derive prompt handlers with per-constructor 'DefinitionOptions'+-- | Derive prompt handlers with per-constructor t'DefinitionOptions' -- (title, icons, scoped argument descriptions). Usage: -- -- > $(derivePromptHandlerWithOptions ''MyPrompt 'handlePrompt@@ -515,21 +532,18 @@     ToolArgs ->       [| case $(return decoder) of            Left err -> pure (Left err)-           Right v  -> do-             r <- $(varE handlerName) $(varE ctxName) v-             pure (Right (toToolResult r)) |]+           Right v  -> fmap (fmap toToolResult) <$>+             runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |]     ToolArgsOutput builder ->       [| case $(return decoder) of            Left err -> pure (Left err)-           Right v  -> do-             r <- $(varE handlerName) $(varE ctxName) v-             pure (Right (resolveToolOutput $(return builder) r)) |]+           Right v  -> fmap (fmap (resolveToolOutput $(return builder))) <$>+             runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |]     PromptArgs ->       [| case $(return decoder) of            Left err -> pure (Left err)-           Right v  -> do-             r <- $(varE handlerName) $(varE ctxName) v-             pure (Right (toPromptResult r)) |]+           Right v  -> fmap (fmap toPromptResult) <$>+             runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) v) |]   clause [litP $ stringL sname] (normalB (return body)) []  -------------------------------------------------------------------------------@@ -553,7 +567,7 @@ deriveResourceHandlerWithDescription typeName handlerName descriptions =   deriveResourceHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) --- | Derive resource handlers with per-constructor 'DefinitionOptions'+-- | Derive resource handlers with per-constructor t'DefinitionOptions' -- (description, title, icons). deriveResourceHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp deriveResourceHandlerWithOptions typeName handlerName opts =@@ -597,7 +611,7 @@   deriveResourceTemplatesGeneric typeName (optionsFromDescriptions descriptions)  -- | Derive a 'ResourceTemplateListHandler' with per-constructor--- 'DefinitionOptions' (description, title, icons).+-- t'DefinitionOptions' (description, title, icons). deriveResourceTemplatesWithOptions :: Name -> [(String, DefinitionOptions)] -> Q Exp deriveResourceTemplatesWithOptions typeName opts =   deriveResourceTemplatesGeneric typeName (optionsFor opts)@@ -666,7 +680,7 @@   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)+         then runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) $(varE uriName) $(conE name))          else $restQ |]   RecC name [] ->     fail $ "Resource template constructors need at least one field: " ++ nameBase name@@ -676,7 +690,7 @@     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 |]+                    Right v  -> runHandler $(varE ctxName) ($(varE handlerName) $(varE ctxName) $(varE uriName) v) |]     rest <- restQ     matchExp <- [| matchTemplateSegments $(litE $ stringL prefix)                      $(litE $ integerL $ fromIntegral $ length fields)@@ -715,7 +729,7 @@ deriveToolHandlerWithDescription typeName handlerName descriptions =   deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions Nothing --- | Derive tool handlers with per-constructor 'DefinitionOptions'+-- | Derive tool handlers with per-constructor t'DefinitionOptions' -- (description, title, icons, behavioral annotations, scoped argument -- descriptions). Usage: --@@ -741,7 +755,7 @@ -- record type describing the tools' results. Its shape becomes the derived -- @outputSchema@ (same field rules as input derivation: primitives, -- 'Maybe', lists, all-nullary enums, nested records), and the handler--- returns @'ToolOutput' \<output\>@, whose typed values the derivation+-- returns @t'ToolOutput' \<output\>@, whose typed values the derivation -- serializes into @structuredContent@ — guaranteed to match the schema. -- -- > handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport)@@ -758,7 +772,7 @@   deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions (Just outputName)  -- | 'deriveToolHandlerWithOutput' with per-constructor--- 'DefinitionOptions'. An entry keyed by the output type's name supplies+-- t'DefinitionOptions'. An entry keyed by the output type's name supplies -- the @outputSchema@ field descriptions via 'optFieldDescriptions'. deriveToolHandlerWithOutputOptions :: Name -> Name -> Name -> [(String, DefinitionOptions)] -> Q Exp deriveToolHandlerWithOutputOptions typeName handlerName outputName opts =@@ -817,3 +831,150 @@       , toolDefinitionAnnotations = $(lift (optToolAnnotations opts))       , toolDefinitionIcons = $(lift (optIcons opts))       } |]++-------------------------------------------------------------------------------+-- Form derivation (elicitation)+-------------------------------------------------------------------------------++-- | How one field of a derived form is presented.+data FormFieldOptions = FormFieldOptions+  { formFieldTitle       :: Maybe Text+    -- ^ The label clients show (falls back to the field name)+  , formFieldDescription :: Maybe Text+    -- ^ Help text shown with the field+  , formFieldDefault     :: Maybe Value+    -- ^ The value the field starts with; checked against the field's type+    --   at compile time+  } deriving (Show, Eq)++-- | Nothing customized; record-update what you need.+defaultFormFieldOptions :: FormFieldOptions+defaultFormFieldOptions = FormFieldOptions+  { formFieldTitle = Nothing+  , formFieldDescription = Nothing+  , formFieldDefault = Nothing+  }++-- | Derive a t'Form' instance from a record, for 'MCP.Server.Ask.elicit':+--+-- > data Environment = Staging | Production+-- > data DeployTarget = DeployTarget { environment :: Environment, reason :: Text, notify :: Maybe Bool }+-- > $(deriveForm ''DeployTarget)+--+-- Elicitation forms are flat, so the fields may be 'Text', 'Int',+-- 'Integer', 'Double', 'Float', t'Bool', enumerations (data types whose+-- constructors are all nullary, offered as snake_cased choices), lists of+-- enumerations (several choices), and 'Maybe' of any of these for optional+-- fields. Anything else, such as a nested record, is a compile-time error+-- naming the field.+deriveForm :: Name -> Q [Dec]+deriveForm typeName = deriveFormWithOptions typeName []++-- | 'deriveForm' with field descriptions, keyed by field name.+--+-- > $(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")])+deriveFormWithDescription :: Name -> [(String, String)] -> Q [Dec]+deriveFormWithDescription typeName descriptions = deriveFormWithOptions typeName+  [ (field, defaultFormFieldOptions { formFieldDescription = Just (T.pack d) })+  | (field, d) <- descriptions ]++-- | 'deriveForm' with per-field t'FormFieldOptions', keyed by field name.+--+-- > $(deriveFormWithOptions ''DeployTarget+-- >     [ ("environment", defaultFormFieldOptions+-- >         { formFieldTitle = Just "Environment", formFieldDefault = Just "staging" }) ])+deriveFormWithOptions :: Name -> [(String, FormFieldOptions)] -> Q [Dec]+deriveFormWithOptions typeName opts = do+  cons <- reifyCons typeName+  (con, fields) <- case cons of+    Just [RecC con fields@(_ : _)] -> pure (con, fields)+    _ -> fail $ "deriveForm: " ++ nameBase typeName+           ++ " must be a record with a single constructor and at least one field"+  let known = [nameBase fn | (fn, _, _) <- fields]+  case [field | (field, _) <- opts, field `notElem` known] of+    [] -> pure ()+    unknown -> fail $ "deriveForm: " ++ nameBase typeName+                 ++ " has no field named " ++ intercalate ", " unknown+  props <- traverse (formProperty typeName opts) fields+  let reqd = listE [litE $ stringL fn | fn <- requiredFieldNames fields]+  parser <- mkObjectParser typeName con fields+  [d| instance Form $(conT typeName) where+        formSchema _ = Schema Nothing (SchemaObject $(return (ListE props)) $reqd)+        formParse content = $(return parser) (toJSON content) |]++-- One property of a form's schema, after checking the field can be in one.+formProperty :: Name -> [(String, FormFieldOptions)] -> (Name, Bang, Type) -> Q Exp+formProperty typeName opts (fieldName, _, fieldType) = do+  let field = nameBase fieldName+      (_, innerType) = unwrapMaybe fieldType+      fieldOpts = fromMaybe defaultFormFieldOptions (lookup field opts)+      unsupported why = fail $ "deriveForm: field '" ++ field ++ "' of " ++ nameBase typeName+        ++ " " ++ why ++ "; form fields are Text, numbers, Bool, enumerations,"+        ++ " lists of enumerations, or Maybe of these"+  kind <- formFieldKind innerType >>= either unsupported pure+  traverse_ (checkFormDefault typeName field kind) (formFieldDefault fieldOpts)+  shape <- mkSchemaShape [] innerType+  let defaultJson = jsonText <$> formFieldDefault fieldOpts+  [| ( $(litE (stringL field))+     , formFieldSchema $(lift (formFieldTitle fieldOpts))+                       $(lift (formFieldDescription fieldOpts))+                       $(lift defaultJson)+                       $(return shape)+     ) |]+  where+    traverse_ f = maybe (pure ()) f++-- What a form field holds, for checking defaults.+data FormFieldKind+  = FormText+  | FormNumber (Value -> Either Text ())  -- the field's own parser, discarding the value+  | FormBool+  | FormChoice [String]+  | FormChoices [String]++-- Classify a field type, or say why a form cannot hold it.+formFieldKind :: Type -> Q (Either String FormFieldKind)+formFieldKind ty = case ty of+  ConT n | nameBase n == "Text"                                    -> ok FormText+         | nameBase n == "Int"                                     -> number valueInt+         | nameBase n == "Integer"                                 -> number valueInteger+         | nameBase n == "Double"                                  -> number valueDouble+         | nameBase n == "Float"                                   -> number valueFloat+         | nameBase n == "Bool"                                    -> ok FormBool+  AppT ListT inner -> do+    kind <- formFieldKind inner+    pure $ case kind of+      Right (FormChoice choices) -> Right (FormChoices choices)+      _ -> Left "is a list of something other than an enumeration"+  ConT n -> do+    cons <- reifyCons n+    case cons of+      Just cs | not (null cs), all isNullary cs -> ok (FormChoice [snakeName (conName c) | c <- cs])+      Just [RecC _ _] -> pure (Left "is a record (forms cannot nest)")+      Just [NormalC _ [(_bang, inner)]] -> formFieldKind inner+      _ -> pure (Left ("has type " ++ nameBase n))+  AppT (ConT n) _ | nameBase n == "Maybe" -> pure (Left "is a nested Maybe")+  _ -> pure (Left ("has type " ++ pprint ty))+  where+    ok = pure . Right+    number parser = ok (FormNumber (fmap (const ()) . parser))++-- A default must be a value the field can hold.+checkFormDefault :: Name -> String -> FormFieldKind -> Value -> Q ()+checkFormDefault typeName field kind value+  | fits kind value = pure ()+  | otherwise = fail $ "deriveForm: the default for field '" ++ field ++ "' of "+      ++ nameBase typeName ++ " does not fit its type: " ++ T.unpack (jsonText value)+  where+    fits FormText (String _)              = True+    -- Numbers go through the field's parser, so an Int default must be a+    -- whole number in range, as the parsed answer would have to be.+    fits (FormNumber parse) v@(Number _)  = either (const False) (const True) (parse v)+    fits FormBool (Bool _)                = True+    fits (FormChoice cs) (String c)       = T.unpack c `elem` cs+    fits (FormChoices cs) (Array xs)      = all (fits (FormChoice cs)) xs+    fits _ _                              = False++-- JSON as text, decoded as UTF-8 (the encoding is always valid UTF-8).+jsonText :: Value -> Text+jsonText = TE.decodeUtf8 . BSL.toStrict . encode

@@ -38,9 +38,11 @@   , resolveToolOutput   , omitNothing   , canonicalJsonText+    -- * Forms+  , formFieldSchema   ) where -import           Data.Aeson           (ToJSON (..), Value (..), encode)+import           Data.Aeson           (Value (..), decodeStrict, encode, toJSON) import qualified Data.Aeson.Key       as Key import qualified Data.Aeson.KeyMap    as KM import           Data.Aeson.Types     (Pair)@@ -56,7 +58,9 @@ import           Network.URI          (unEscapeString) import           Text.Read            (readMaybe) -import           MCP.Server.Types     (Content (..), Error (..),+import           MCP.Server.Internal.Json (canonicalJsonText)+import           MCP.Server.Types     (Content (..), Error (..), Schema (..),+                                       SchemaType (..),                                        ToolOutput (..), ToolResult (..),                                        toolError, toolResult) @@ -225,8 +229,8 @@ -- Structured output -- --------------------------------------------------------------------------- --- | Turn a 'ToolOutput' into the 'ToolResult' that goes on the wire, given--- the generated serializer for the output type. A plain 'ToolOutput' also+-- | Turn a t'ToolOutput' into the t'ToolResult' that goes on the wire, given+-- the generated serializer for the output type. A plain v'ToolOutput' also -- carries the serialized JSON as a text content block, per the spec's -- recommendation for clients that predate structured output. resolveToolOutput :: (o -> Value) -> ToolOutput o -> ToolResult@@ -239,28 +243,26 @@   ToolOutputError msg -> toolError msg   ToolOutputRaw result -> result --- | Compact JSON with objects in sorted-key order, independent of the--- aeson\/hashable pair in the build plan. Used wherever JSON ends up--- /inside a string/ (the structured-output text block): structural--- comparison cannot see through a string, so those bytes must be--- deterministic — which also keeps repeated tool results stable for client--- prompt caching.-canonicalJsonText :: Value -> Text-canonicalJsonText = TE.decodeUtf8 . BSL.toStrict . encode . Canonical---- Encoding-only wrapper: objects are emitted via a sorted 'Map', arrays--- and atoms recurse. 'encode' uses 'toEncoding', so no KeyMap is rebuilt.-newtype Canonical = Canonical Value--instance ToJSON Canonical where-  toJSON (Canonical v) = v-  toEncoding (Canonical (Object o)) =-    toEncoding (Map.fromList [(Key.toText k, Canonical v) | (k, v) <- KM.toList o])-  toEncoding (Canonical (Array xs)) = toEncoding (fmap Canonical xs)-  toEncoding (Canonical v) = toEncoding v- -- | A record field for the generated serializers: absent when 'Nothing', -- mirroring how the generated schema marks 'Maybe' fields optional. omitNothing :: Text -> (a -> Value) -> Maybe a -> [Pair] omitNothing _ _ Nothing        = [] omitNothing name f (Just x)    = [(Key.fromText name, f x)]++-- ---------------------------------------------------------------------------+-- Forms+-- ---------------------------------------------------------------------------++-- | One property of a derived form: its shape, with a title and a default+-- (JSON, checked when the form was derived) added as raw keywords, since+-- t'Schema' has no place for them.+formFieldSchema :: Maybe Text -> Maybe Text -> Maybe Text -> SchemaType -> Schema+formFieldSchema title description defaultJson shape+  | null extras = Schema description shape+  | otherwise = Schema description (SchemaRaw (KM.union (KM.fromList extras) base))+  where+    base = case toJSON (Schema Nothing shape) of+      Object o -> o+      _        -> KM.empty+    extras = [("title", String t) | Just t <- [title]]+          ++ [("default", v) | Just j <- [defaultJson], Just v <- [decodeStrict (TE.encodeUtf8 j)]]

@@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Protocol dispatch: routes each JSON-RPC message to the matching+-- user handler and builds the response for the request's protocol era.+-- The transports call 'handleMcpMessage'; the per-method handlers are+-- exported for testing and custom transports. module MCP.Server.Handlers   ( -- * Core Message Handling     handleMcpMessage@@ -43,8 +47,11 @@ import qualified Data.Text              as T import           System.IO              (hPutStrLn, stderr) +import           MCP.Server.Internal.InputRound (beginRound,+                                                 inputRequiredResult) import           MCP.Server.JsonRpc import           MCP.Server.Protocol+import           MCP.Server.RequestState        (StateCodec) import           MCP.Server.Types  -- | Convert JSON Value to Text representation suitable for handlers@@ -152,15 +159,19 @@             }  -- | 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.+-- @resultType: \"complete\"@ (unless the result already carries one, as+-- an @input_required@ result does), the server's identity in result+-- @_meta@, and (for complete results of 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+    decorate o = case KM.lookup "resultType" o of+      Just _  -> insertMeta o+      Nothing -> insertCache $ KM.insert "resultType" (String "complete") $ insertMeta o     insertMeta o = KM.insert "_meta" (Object meta) o       where meta = case KM.lookup "_meta" o of               Just (Object m) -> KM.insert serverInfoKey serverInfoVal m@@ -184,19 +195,23 @@ -- result envelope; a request that does not is served exactly as before -- under the revision negotiated by @initialize@. --+-- @codec@ seals and opens the @requestState@ of multi round-trip requests+-- (see "MCP.Server.RequestState").+-- -- @emit@ is the transport's request-scoped notification sink: progress and -- client-log notifications for /this request/ are delivered through it, -- interleaved before the response (stdio's shared channel, or the -- request's SSE response stream on HTTP). handleMcpMessage :: McpServerInfo                  -> CacheHints+                 -> StateCodec                  -> NotificationSupport                  -> (JsonRpcNotification -> IO ())                  -> McpServerHandlers                  -> ClientContext                  -> JsonRpcMessage                  -> IO (Maybe JsonRpcMessage)-handleMcpMessage serverInfo hints notifSupport emit handlers ctx0 (JsonRpcMessageRequest req) = do+handleMcpMessage serverInfo hints codec notifSupport emit handlers ctx0 (JsonRpcMessageRequest req) = do   let params = requestParams req       declaredVersion = metaProtocolVersion params   case declaredVersion of@@ -231,12 +246,12 @@         "ping" -> handlePing req         "server/discover" -> handleServerDiscover serverInfo notifSupport handlers req         "prompts/list" -> handlePromptsList handlers ctx req-        "prompts/get" -> handlePromptsGet handlers ctx req+        "prompts/get" -> handlePromptsGet codec handlers ctx req         "resources/list" -> handleResourcesList handlers ctx req-        "resources/read" -> handleResourcesRead handlers ctx req+        "resources/read" -> handleResourcesRead codec handlers ctx req         "resources/templates/list" -> handleResourcesTemplatesList handlers ctx req         "tools/list" -> handleToolsList handlers ctx req-        "tools/call" -> handleToolsCall handlers ctx req+        "tools/call" -> handleToolsCall codec handlers ctx req         "completion/complete" -> handleCompletionComplete handlers ctx req         method -> return $ makeErrorResponse (requestId req) $ JsonRpcError           { errorCode = -32601@@ -248,7 +263,7 @@             else response       return $ Just $ JsonRpcMessageResponse response' -handleMcpMessage _ _ _ _ _ _ (JsonRpcMessageNotification notif) = do+handleMcpMessage _ _ _ _ _ _ _ (JsonRpcMessageNotification notif) = do   case notificationMethod notif of     "notifications/initialized" ->       hPutStrLn stderr "Received initialized notification - server is ready for operation"@@ -256,7 +271,7 @@       hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)   return Nothing -handleMcpMessage _ _ _ _ _ _ (JsonRpcMessageResponse _) =+handleMcpMessage _ _ _ _ _ _ _ (JsonRpcMessageResponse _) =   return Nothing  -- | The 'reportProgress' action for a request: emits@@ -362,7 +377,7 @@ -- 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'.+-- 'handleMcpMessage'. handleServerDiscover :: McpServerInfo -> NotificationSupport -> McpServerHandlers -> JsonRpcRequest -> IO JsonRpcResponse handleServerDiscover serverInfo notifSupport handlers req = do   -- Modern clients receive notifications via subscriptions/listen, so both@@ -393,8 +408,8 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle prompts/get request-handlePromptsGet :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse-handlePromptsGet handlers ctx req =+handlePromptsGet :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse+handlePromptsGet codec handlers ctx req =   case prompts handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -419,20 +434,13 @@               -- 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-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right promptRes -> do-                  let response = PromptsGetResponse-                        { promptsGetDescription = promptResultDescription promptRes-                        , promptsGetMessages = promptResultMessages promptRes-                        , promptsGetMeta = Nothing-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)+              runRound codec ctx req+                (\c -> getHandler c (promptsGetName getReq) args)+                (\promptRes -> toJSON PromptsGetResponse+                    { promptsGetDescription = promptResultDescription promptRes+                    , promptsGetMessages = promptResultMessages promptRes+                    , promptsGetMeta = Nothing+                    })  -- | Handle resources/list request handleResourcesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse@@ -457,8 +465,8 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle resources/read request-handleResourcesRead :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse-handleResourcesRead handlers ctx req =+handleResourcesRead :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse+handleResourcesRead codec handlers ctx req =   case resources handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -479,19 +487,12 @@               , errorMessage = "Invalid parameters: " <> T.pack err               , errorData = Nothing               }-            Success readReq -> do-              result <- readHandler ctx (resourcesReadUri readReq)-              case result of-                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right resourceContent -> do-                  let response = ResourcesReadResponse-                        { resourcesReadContents = [resourceContent]-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)+            Success readReq ->+              runRound codec ctx req+                (\c -> readHandler c (resourcesReadUri readReq))+                (\resourceContent -> toJSON ResourcesReadResponse+                    { resourcesReadContents = [resourceContent]+                    })  -- | Handle resources/templates/list request handleResourcesTemplatesList :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse@@ -564,8 +565,8 @@       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle tools/call request-handleToolsCall :: McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse-handleToolsCall handlers ctx req =+handleToolsCall :: StateCodec -> McpServerHandlers -> ClientContext -> JsonRpcRequest -> IO JsonRpcResponse+handleToolsCall codec handlers ctx req =   case tools handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -589,21 +590,44 @@             Success callReq -> do               -- 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-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right toolRes -> do-                  let response = ToolsCallResponse-                        { toolsCallContent = toolResultContent toolRes-                        , toolsCallIsError = if toolResultIsError toolRes then Just True else Nothing-                        , toolsCallStructuredContent = toolResultStructured toolRes-                        , toolsCallMeta = toolResultMeta toolRes-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)+              runRound codec ctx req+                (\c -> callHandler c (toolsCallName callReq) args)+                (\toolRes -> toJSON ToolsCallResponse+                    { toolsCallContent = toolResultContent toolRes+                    , toolsCallIsError = if toolResultIsError toolRes then Just True else Nothing+                    , toolsCallStructuredContent = toolResultStructured toolRes+                    , toolsCallMeta = toolResultMeta toolRes+                    })++-- | Run a handler that may ask the client for input (multi round-trip+-- requests): read a retry's answers and verified state into the context,+-- run the handler, and answer with its result, its error, or an+-- @input_required@ result.+runRound :: StateCodec+         -> ClientContext+         -> JsonRpcRequest+         -> (ClientContext -> IO (Either Error (Outcome a)))+         -> (a -> Value)+         -> IO JsonRpcResponse+runRound codec ctx0 req run render = do+  let rid = requestId req+      method = requestMethod req+      params = requestParams req+  prepared <- beginRound codec method params ctx0+  case prepared of+    Left err -> pure (makeErrorResponse rid err)+    Right ctx -> do+      result <- run ctx+      case result of+        Left err -> pure $ makeErrorResponse rid JsonRpcError+          { errorCode = errorCodeFromMcpError err+          , errorMessage = errorMessageFromMcpError err+          , errorData = Nothing+          }+        Right (Complete a) -> pure (makeSuccessResponse rid (render a))+        Right (InputRequired requests state) -> do+          answer <- inputRequiredResult codec method params ctx requests state+          pure (either (makeErrorResponse rid) (makeSuccessResponse rid) answer)  -- | Convert MCP error to JSON-RPC error code errorCodeFromMcpError :: Error -> Int

@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}++-- | The library's side of multi round-trip requests: reading a retry's+-- @inputResponses@ and @requestState@ into the handler's context, and+-- turning a handler's 'InputRequired' into an @input_required@ result.+--+-- The sealed state carries, besides the handler's own state, what the spec+-- asks servers to bind it to: the caller (a digest of the principal), the+-- originating request (the method and a digest of its parameters) and an+-- expiry. All four are checked before the handler runs again.+module MCP.Server.Internal.InputRound+  ( beginRound+  , inputRequiredResult+  ) where++import           Control.Monad            (unless, when)+import           Data.Aeson+import qualified Data.Aeson.Key           as Key+import qualified Data.Aeson.KeyMap        as KM+import           Data.Aeson.Types         (parseEither)+import qualified Data.ByteString.Lazy     as BSL+import           Data.Map                 (Map)+import qualified Data.Map                 as Map+import           Data.Text                (Text)+import qualified Data.Text                as T+import           Data.Time.Clock.POSIX    (getPOSIXTime)+import           System.IO                (hPutStrLn, stderr)++import           MCP.Server.Internal.Json (jsonDigest)+import           MCP.Server.JsonRpc       (JsonRpcError (..))+import           MCP.Server.RequestState+import           MCP.Server.Types++-- | What is sealed into a request state.+data Payload = Payload+  { payloadMethod    :: Text+  , payloadParams    :: Text        -- ^ Digest of the request parameters+  , payloadPrincipal :: Text        -- ^ Digest of the caller's principal+  , payloadExpires   :: Integer     -- ^ POSIX seconds+  , payloadKeys      :: [Text]      -- ^ The keys of the requests issued+  , payloadState     :: Maybe Text  -- ^ The handler's own state+  }++instance ToJSON Payload where+  toJSON p = object+    [ "v" .= (1 :: Int)+    , "m" .= payloadMethod p+    , "d" .= payloadParams p+    , "p" .= payloadPrincipal p+    , "e" .= payloadExpires p+    , "k" .= payloadKeys p+    , "s" .= payloadState p+    ]++instance FromJSON Payload where+  parseJSON = withObject "Payload" $ \o -> do+    version <- o .: "v"+    unless (version == (1 :: Int)) $ fail "unsupported state version"+    Payload <$> o .: "m" <*> o .: "d" <*> o .: "p" <*> o .: "e" <*> o .: "k" <*> o .:? "s"++-- | Prepare the context for a call that may be a retry. Legacy requests+-- have no multi round-trip semantics, so their context is left alone.+--+-- Answers are only taken from a retry that carries the state of the round+-- that asked, and only for the keys that round issued: anything else in+-- @inputResponses@ is ignored, as the spec asks, so a client cannot+-- volunteer answers the handler never requested. A retry's state is+-- verified before anything else; a failure is a @-32602@ the handler never+-- sees.+beginRound :: StateCodec -> Text -> Maybe Value -> ClientContext+           -> IO (Either JsonRpcError ClientContext)+beginRound codec method params ctx+  | Nothing <- clientProtocolVersion ctx = pure (Right ctx)+  | otherwise = case field "requestState" of+      Nothing -> pure (Right ctx)+      Just (String sealed) -> do+        opened <- openPayload codec method params ctx sealed+        pure $ do+          (keys, state) <- opened+          responses <- issuedResponses keys+          Right ctx { clientInputResponses = responses, clientRequestState = state }+      Just _ -> pure $ Left $ invalidParams "Invalid requestState: expected a string"+  where+    field key = case params of+      Just (Object o) -> KM.lookup key o+      _               -> Nothing+    issuedResponses keys = case field "inputResponses" of+      Nothing          -> Right Map.empty+      Just (Object rs) -> Map.fromList <$> traverse parseIssued+        [ (key, v) | key <- keys, Just v <- [KM.lookup (Key.fromText key) rs] ]+      Just _           -> Left $ invalidParams "Invalid inputResponses: expected an object"+    parseIssued (key, v) = case parseEither parseJSON v of+      Right response -> Right (key, response)+      Left err -> Left $ invalidParams $ "Invalid inputResponses: " <> key <> ": " <> T.pack err++-- | The @input_required@ result for a handler's requests and state, or a+-- @-32603@ when the handler asked for input this client cannot provide+-- (a server bug: handlers should check 'clientSupportsInput').+inputRequiredResult :: StateCodec -> Text -> Maybe Value -> ClientContext+                    -> Map Text InputRequest -> Maybe Text+                    -> IO (Either JsonRpcError Value)+inputRequiredResult codec method params ctx requests state+  | Nothing <- clientProtocolVersion ctx =+      pure $ Left $ internalError+        "the handler requested input, which the client's protocol revision does not support"+  | unsupported@(_ : _) <- [key | (key, request) <- Map.toList requests+                                , not (clientSupportsInput ctx request)] =+      pure $ Left $ internalError $+        "the handler requested input the client cannot provide ("+          <> T.intercalate ", " unsupported <> ")"+  | otherwise = do+      now <- getPOSIXTime+      let payload = Payload+            { payloadMethod = method+            , payloadParams = paramsDigest params+            , payloadPrincipal = principalDigest ctx+            , payloadExpires = floor (now + stateLifetime codec)+            , payloadKeys = Map.keys requests+            , payloadState = state+            }+      sealed <- sealState codec (BSL.toStrict (encode payload))+      pure $ Right $ object+        [ "resultType" .= ("input_required" :: Text)+        , "inputRequests" .= requests+        , "requestState" .= sealed+        ]+  where+    internalError message = JsonRpcError+      { errorCode = -32603+      , errorMessage = "Internal error: " <> message+      , errorData = Nothing+      }++openPayload :: StateCodec -> Text -> Maybe Value -> ClientContext -> Text+            -> IO (Either JsonRpcError ([Text], Maybe Text))+openPayload codec method params ctx sealed = do+  opened <- openState codec sealed+  now <- getPOSIXTime+  let check = do+        bytes <- case opened of+          Left StateUnknownKey -> Left (unknownKey, "unknown key id")+          Left StateInvalid    -> Left (invalid, "could not be opened")+          Right b              -> Right b+        payload <- either (\e -> Left (invalid, "bad payload: " <> T.pack e)) Right $+          eitherDecodeStrict bytes+        when (payloadMethod payload /= method) $+          Left (invalid, "issued for " <> payloadMethod payload <> ", presented on " <> method)+        when (payloadParams payload /= paramsDigest params) $+          Left (invalid, "issued for different request parameters")+        when (payloadPrincipal payload /= principalDigest ctx) $+          Left (invalid, "issued to a different principal")+        when (fromInteger (payloadExpires payload) < now) $+          Left (expired, "expired")+        pure (payloadKeys payload, payloadState payload)+  case check of+    Right issued -> pure (Right issued)+    Left (err, reason) -> do+      hPutStrLn stderr $ "Rejected requestState on " <> T.unpack method <> ": " <> T.unpack reason+      pure (Left err)+  where+    invalid = invalidParams "Invalid requestState"+    expired = invalidParams "requestState has expired: retry the request without it"+    unknownKey = invalidParams+      "requestState was issued by another server instance or under a retired key"++invalidParams :: Text -> JsonRpcError+invalidParams message = JsonRpcError+  { errorCode = -32602+  , errorMessage = message+  , errorData = Nothing+  }++-- | Digest of the request parameters that define the request: everything+-- but the round's own fields and @_meta@.+paramsDigest :: Maybe Value -> Text+paramsDigest params = jsonDigest $ case params of+  Just (Object o) -> Object (foldr KM.delete o ["inputResponses", "requestState", "_meta"])+  Just v          -> v+  Nothing         -> Null++principalDigest :: ClientContext -> Text+principalDigest = jsonDigest . maybe Null id . clientPrincipal

@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Deterministic JSON encoding, for JSON that ends up inside a string or a+-- digest, where structural comparison cannot see through the bytes.+module MCP.Server.Internal.Json+  ( canonicalJson+  , canonicalJsonText+  , jsonDigest+  ) where++import qualified Crypto.Hash          as Hash++import           Data.Aeson           (ToJSON (..), Value (..), encode)+import qualified Data.Aeson.Key       as Key+import qualified Data.Aeson.KeyMap    as KM+import qualified Data.ByteArray       as BA+import qualified Data.ByteString.Base64.URL as B64+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map             as Map+import           Data.Text            (Text)+import qualified Data.Text.Encoding   as TE++-- | Compact JSON with objects in sorted-key order, independent of the+-- aeson\/hashable pair in the build plan.+canonicalJson :: Value -> BSL.ByteString+canonicalJson = encode . Canonical++-- | 'canonicalJson' as text. Used wherever JSON ends up /inside a string/+-- (the structured-output text block): structural comparison cannot see+-- through a string, so those bytes must be deterministic — which also+-- keeps repeated tool results stable for client prompt caching.+canonicalJsonText :: Value -> Text+canonicalJsonText = TE.decodeUtf8 . BSL.toStrict . canonicalJson++-- | SHA-256 of 'canonicalJson', base64url-encoded: equal for structurally+-- equal values.+jsonDigest :: Value -> Text+jsonDigest v = TE.decodeUtf8 $ B64.encode $ BA.convert+  (Hash.hashlazy (canonicalJson v) :: Hash.Digest Hash.SHA256)++-- Encoding-only wrapper: objects are emitted via a sorted 'Map', arrays+-- and atoms recurse. 'encode' uses 'toEncoding', so no KeyMap is rebuilt.+newtype Canonical = Canonical Value++instance ToJSON Canonical where+  toJSON (Canonical v) = v+  toEncoding (Canonical (Object o)) =+    toEncoding (Map.fromList [(Key.toText k, Canonical v) | (k, v) <- KM.toList o])+  toEncoding (Canonical (Array xs)) = toEncoding (fmap Canonical xs)+  toEncoding (Canonical v) = toEncoding v

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | JSON-RPC 2.0 messages: requests, responses, errors and notifications,+-- with parsing and encoding. module MCP.Server.JsonRpc   ( -- * JSON-RPC Types     JsonRpcRequest(..)

@@ -2,9 +2,9 @@  -- | Server-initiated change notifications. ----- Create a notifier with 'newMcpNotifier', hand the 'NotificationSource' to+-- Create a notifier with 'newMcpNotifier', hand the t'NotificationSource' to -- a transport via its configuration ('MCP.Server.Transport.Stdio.StdioConfig'--- \/ 'MCP.Server.Transport.Http.HttpConfig'), keep the 'McpNotifier', and+-- \/ 'MCP.Server.Transport.Http.HttpConfig'), keep the t'McpNotifier', and -- call its actions whenever your tool\/prompt\/resource lists (or a specific -- resource) change: --

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} +-- | Request and response payloads for each MCP method, and the protocol+-- revisions this library supports. module MCP.Server.Protocol   ( -- * MCP Protocol Messages     InitializeRequest(..)@@ -85,7 +87,7 @@   ]  -- | Every revision this library implements, newest first — what--- @server\/discover@ and 'UnsupportedProtocolVersionError' report.+-- @server\/discover@ and @UnsupportedProtocolVersionError@ report. allVersions :: [Text] allVersions = modernVersions ++ supportedVersions 

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Protection for the @requestState@ of multi round-trip requests.+--+-- When a handler answers with 'MCP.Server.Types.InputRequired', the+-- client must echo the request state back on its retry. The specification+-- treats that state as attacker-controlled, so the library never hands it+-- to the client in the clear: it binds the state to the caller, the+-- original request and an expiry, then seals it with a t'StateCodec'.+--+-- The default codec, 'ephemeralStateCodec', encrypts with a random key+-- created when the transport starts. That is right for stdio and for a+-- single HTTP instance. Deployments with several instances behind a load+-- balancer must share a key, with 'aeadStateCodec':+--+-- > Just key = stateKey "2026-10" keyBytes   -- 32 secret bytes+-- > config = defaultHttpConfig { httpStateCodec = Just (aeadStateCodec key []) }+--+-- To rotate keys, seal with the new key and keep accepting the old one+-- until its states have expired: @aeadStateCodec newKey [oldKey]@.+module MCP.Server.RequestState+  ( -- * Codecs+    StateCodec(..)+  , StateError(..)+  , defaultStateLifetime+  , aeadStateCodec+  , ephemeralStateCodec+    -- * Keys+  , StateKey+  , stateKey+  , stateKeyId+  ) where++import           Crypto.Cipher.ChaChaPoly1305 (aeadChacha20poly1305Init)+import           Crypto.Cipher.Types          (AuthTag (..), aeadSimpleDecrypt,+                                               aeadSimpleEncrypt)+import           Crypto.Error                 (maybeCryptoError)+import           Crypto.Random                (getRandomBytes)+import qualified Data.ByteArray               as BA+import           Data.ByteString              (ByteString)+import qualified Data.ByteString              as BS+import qualified Data.ByteString.Base64.URL   as B64+import           Data.Char                    (isAsciiLower, isAsciiUpper,+                                               isDigit)+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import qualified Data.Text.Encoding           as TE+import           Data.Time.Clock              (NominalDiffTime)+import           Numeric                      (showHex)++-- | How sealed request state is produced and checked. The library builds+-- the plaintext (the caller, the request, the expiry and the handler's+-- state) and verifies it after 'openState'; a codec only has to keep it+-- confidential and tamper-evident.+--+-- Replace the codec to manage keys elsewhere, or to keep states on the+-- server and hand the client only a reference.+data StateCodec = StateCodec+  { sealState :: ByteString -> IO Text+    -- ^ Seal plaintext into the opaque string sent to the client.+  , openState :: Text -> IO (Either StateError ByteString)+    -- ^ Recover the plaintext from a string the client sent back.+  , stateLifetime :: NominalDiffTime+    -- ^ How long a state stays valid after it is issued.+  }++-- | Why a state could not be opened.+data StateError+  = StateUnknownKey+    -- ^ Sealed under a key this codec does not have: issued by another+    --   server instance, or under a key that has since been retired.+  | StateInvalid+    -- ^ Malformed, or altered after it was sealed.+  deriving (Show, Eq)++-- | 60 minutes: long enough for a user to fill in a form.+defaultStateLifetime :: NominalDiffTime+defaultStateLifetime = 3600++-- | A 256-bit key for 'aeadStateCodec', with an id that is stored next to+-- each sealed state so the right key is used to open it.+data StateKey = StateKey Text ByteString++-- | A key from its id and 32 secret bytes. The id is 1–32 characters of+-- ASCII letters, digits, @-@ and @_@; it is visible to clients, so it+-- should not reveal anything. 'Nothing' if either is invalid.+stateKey :: Text -> ByteString -> Maybe StateKey+stateKey kid secret+  | validId && BS.length secret == 32 = Just (StateKey kid secret)+  | otherwise = Nothing+  where+    validId = not (T.null kid) && T.length kid <= 32 && T.all idChar kid+    idChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '-' || c == '_'++-- | The id of a key.+stateKeyId :: StateKey -> Text+stateKeyId (StateKey kid _) = kid++-- | Seal with ChaCha20-Poly1305 under the first key, with a random nonce+-- for every state; open with that key or any of the others. States last+-- 'defaultStateLifetime'; set 'stateLifetime' to change that.+aeadStateCodec :: StateKey -> [StateKey] -> StateCodec+aeadStateCodec current older = StateCodec+  { sealState = sealWith current+  , openState = pure . openWith (current : older)+  , stateLifetime = defaultStateLifetime+  }++-- | 'aeadStateCodec' with a random key, created afresh by each call. States+-- cannot be opened by another process, or after a restart.+ephemeralStateCodec :: IO StateCodec+ephemeralStateCodec = do+  secret <- getRandomBytes 32+  idBytes <- getRandomBytes 6 :: IO ByteString+  let kid = "ephemeral-" <> T.pack (concatMap hex (BS.unpack idBytes))+      hex b = let s = showHex b "" in if length s < 2 then '0' : s else s+  case stateKey kid secret of+    Just key -> pure (aeadStateCodec key [])+    Nothing  -> error "ephemeralStateCodec: generated an invalid key"++-- Wire format: @<key id>.<base64url(nonce || ciphertext || tag)>@. The key+-- id and a format version are authenticated as associated data.++nonceSize, tagSize :: Int+nonceSize = 12+tagSize = 16++associatedData :: Text -> ByteString+associatedData kid = "mcp-server/requestState/v1:" <> TE.encodeUtf8 kid++sealWith :: StateKey -> ByteString -> IO Text+sealWith (StateKey kid secret) plaintext = do+  nonce <- getRandomBytes nonceSize :: IO ByteString+  case maybeCryptoError (aeadChacha20poly1305Init secret nonce) of+    Nothing   -> error "aeadStateCodec: invalid key or nonce"+    Just aead -> do+      let (AuthTag tag, ciphertext) =+            aeadSimpleEncrypt aead (associatedData kid) plaintext tagSize+          blob = nonce <> ciphertext <> BA.convert tag+      pure (kid <> "." <> TE.decodeUtf8 (B64.encode blob))++openWith :: [StateKey] -> Text -> Either StateError ByteString+openWith keys sealed = do+  let (kid, rest) = T.breakOn "." sealed+  StateKey _ secret <- maybe (Left StateUnknownKey) Right $+    lookup kid [(k, key) | key@(StateKey k _) <- keys]+  blob <- either (const (Left StateInvalid)) Right $+    B64.decode (TE.encodeUtf8 (T.drop 1 rest))+  if BS.length blob < nonceSize + tagSize+    then Left StateInvalid+    else do+      let (nonce, body) = BS.splitAt nonceSize blob+          (ciphertext, tag) = BS.splitAt (BS.length body - tagSize) body+      aead <- maybe (Left StateInvalid) Right $+        maybeCryptoError (aeadChacha20poly1305Init secret nonce)+      maybe (Left StateInvalid) Right $+        aeadSimpleDecrypt aead (associatedData kid) ciphertext (AuthTag (BA.convert tag))

@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | The Streamable HTTP transport, as a standalone Warp server+-- ('transportRunHttp') or a WAI application to mount in an existing one+-- ('mcpApplication'). module MCP.Server.Transport.Http   ( -- * HTTP Transport     HttpConfig(..)@@ -44,13 +47,14 @@ import           MCP.Server.Handlers import           MCP.Server.JsonRpc import           MCP.Server.Notifications+import           MCP.Server.RequestState (StateCodec, ephemeralStateCodec) import           MCP.Server.Protocol (allVersions, modernVersions,                                       supportedVersions) import           MCP.Server.Types  -- | HTTP transport configuration following the MCP Streamable HTTP specification ----- Note: 'HttpConfig' has no 'Show'/'Eq' instances because 'httpAuthorize' is a+-- Note: t'HttpConfig' has no 'Show'/'Eq' instances because 'httpAuthorize' is a -- function. data HttpConfig = HttpConfig   { httpPort      :: Int      -- ^ Port to listen on@@ -63,7 +67,7 @@       --   'Nothing' when absent / not a Bearer credential) is passed to       --   @check@, which returns the caller's principal: @'Just' principal@       --   authorizes the request — the principal (e.g. a role) is placed in the-      --   handler 'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects+      --   handler t'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects       --   the request with @401@. Validation and principal assignment are left       --   entirely to the caller.   , httpAllowedOrigins :: Maybe [Text]@@ -78,6 +82,12 @@   , httpCacheHints :: CacheHints       -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read       --   results.+  , httpStateCodec :: Maybe StateCodec+      -- ^ Seals the @requestState@ of multi round-trip requests (see+      --   "MCP.Server.RequestState"). 'Nothing' uses a random key created+      --   by 'mcpApplication', which only that application can open: a+      --   deployment with several instances must configure a shared key+      --   with 'MCP.Server.RequestState.aeadStateCodec'.   , httpNotifications :: Maybe NotificationSource       -- ^ When configured, @subscriptions\/listen@ (2026-07-28) is served as       --   a long-lived SSE stream delivering the change notifications the@@ -97,6 +107,7 @@   , httpAuthorize = Nothing   , httpAllowedOrigins = Nothing   , httpCacheHints = defaultCacheHints+  , httpStateCodec = Nothing   , httpNotifications = Nothing   } @@ -144,7 +155,8 @@                  Warp.defaultSettings    putStrLn $ "Starting MCP HTTP server on " ++ httpHost config ++ ":" ++ show (httpPort config) ++ httpEndpoint config-  Warp.runSettings settings (mcpApplication config serverInfo handlers)+  app <- mcpApplication config serverInfo handlers+  Warp.runSettings settings app  -- | The MCP endpoint as a plain WAI 'Wai.Application', for embedding into -- an existing WAI stack (your own Warp settings, TLS, middleware, or a@@ -157,8 +169,17 @@ -- Origin validation and bearer authentication run per 'httpAllowedOrigins' -- and 'httpAuthorize', and @subscriptions\/listen@ streams work as long as -- the surrounding stack does not buffer streaming responses.-mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> Wai.Application-mcpApplication config serverInfo handlers req respond0 = do+--+-- Building the application creates the 'httpStateCodec' default (a random+-- key) when none is configured, so build it once and serve every request+-- with the same application.+mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO Wai.Application+mcpApplication config serverInfo handlers = do+  codec <- maybe ephemeralStateCodec pure (httpStateCodec config)+  pure (mcpApplicationWith codec config serverInfo handlers)++mcpApplicationWith :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> Wai.Application+mcpApplicationWith codec config serverInfo handlers req respond0 = do   -- Log the request   logVerbose config $ "HTTP " ++ show (Wai.requestMethod req) ++ " " ++ T.unpack (TE.decodeUtf8 $ Wai.rawPathInfo req) @@ -203,7 +224,7 @@           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+            then handleMcpRequest codec 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@@ -228,8 +249,8 @@     else Nothing  -- | Handle MCP requests according to Streamable HTTP specification-handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleMcpRequest config serverInfo handlers ctx req respond = do+handleMcpRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleMcpRequest codec config serverInfo handlers ctx req respond = do   -- 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,@@ -261,10 +282,10 @@           -- but only for dispatchable request methods, so unknown methods           -- keep their 404 and notification bodies keep their 202           | wantsStreamingResponse peek-          -> handleStreamingRequest config serverInfo handlers ctx body respond+          -> handleStreamingRequest codec config serverInfo handlers ctx body respond           | otherwise -> do               logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)-              handleJsonRpcRequest config serverInfo handlers ctx modern body respond+              handleJsonRpcRequest codec config serverInfo handlers ctx modern body respond      -- OPTIONS for CORS preflight     "OPTIONS" -> respond $ Wai.responseLBS@@ -324,6 +345,8 @@ peekIsModern peek =   peekMetaVersion peek /= Nothing || peekMethod peek == Just "server/discover" +-- | Extract the t'BodyPeek' fields from a raw request body. A body that is+-- not a JSON object yields a peek with every field empty. peekBody :: BSL.ByteString -> BodyPeek peekBody body = case decode body of   Just (Object o) -> BodyPeek@@ -465,8 +488,8 @@ -- doubles as the disconnect detector: when the client closes the stream the -- next keep-alive write throws, the race cancels the handler task, and -- nothing further is produced for the request.-handleStreamingRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleStreamingRequest config serverInfo handlers ctx body respond =+handleStreamingRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleStreamingRequest codec config serverInfo handlers ctx body respond =   respond $ Wai.responseStream status200 sseHeaders $ \write flush -> do     -- One writer at a time, and a cancellation arriving mid-write cannot     -- split an event in half@@ -496,7 +519,7 @@                 threadDelay 5000000                 sendChunk $ B.byteString ": keep-alive\n\n"           outcome <- race-            (handleMcpMessage serverInfo (httpCacheHints config)+            (handleMcpMessage serverInfo (httpCacheHints config) codec               (httpNotifSupport config) emit handlers ctx message)             keepAlive           case outcome of@@ -505,8 +528,8 @@             Right ()                -> pure ()  -- | Handle JSON-RPC request from HTTP body-handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleJsonRpcRequest config serverInfo handlers ctx modern body respond = do+handleJsonRpcRequest :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleJsonRpcRequest codec config serverInfo handlers ctx modern body respond = do   case eitherDecode body of     Left err -> do       hPutStrLn stderr $ "JSON parse error: " ++ err@@ -519,11 +542,11 @@           , errorData = Nothing           }) -    Right jsonValue -> handleSingleJsonRpc config serverInfo handlers ctx modern jsonValue respond+    Right jsonValue -> handleSingleJsonRpc codec config serverInfo handlers ctx modern jsonValue respond  -- | Handle a single JSON-RPC message-handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleSingleJsonRpc config serverInfo handlers ctx modern jsonValue respond = do+handleSingleJsonRpc :: StateCodec -> HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleSingleJsonRpc codec config serverInfo handlers ctx modern jsonValue respond = do   case parseJsonRpcMessage jsonValue of     Left err -> do       hPutStrLn stderr $ "JSON-RPC parse error: " ++ err@@ -540,7 +563,7 @@       logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message)       -- Single-JSON responses have no channel for request-scoped       -- notifications; requests that want them take the streaming path.-      maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config)+      maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config) codec         (httpNotifSupport config) (\_ -> pure ()) handlers ctx message        case maybeResponse of

@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | The stdio transport: newline-delimited JSON-RPC on stdin and stdout,+-- with logging on stderr. module MCP.Server.Transport.Stdio   ( -- * STDIO Transport     transportRunStdio@@ -32,6 +34,7 @@ import           MCP.Server.JsonRpc import           MCP.Server.Notifications import           MCP.Server.Protocol    (modernVersions)+import           MCP.Server.RequestState (StateCodec, ephemeralStateCodec) import           MCP.Server.Types  -- | STDIO transport configuration@@ -43,6 +46,10 @@   , stdioCacheHints :: CacheHints     -- ^ Cacheability hints stamped onto modern (2026-07-28+) list/read     -- results.+  , stdioStateCodec :: Maybe StateCodec+    -- ^ Seals the @requestState@ of multi round-trip requests (see+    -- "MCP.Server.RequestState"). 'Nothing' uses a random key created when+    -- the transport starts, which is all a single stdio process needs.   , stdioNotifications :: Maybe NotificationSource     -- ^ When configured, change notifications are delivered: modern clients     -- via @subscriptions\/listen@, legacy clients as spontaneous@@ -56,6 +63,7 @@ defaultStdioConfig = StdioConfig   { stdioVerbose = False   , stdioCacheHints = defaultCacheHints+  , stdioStateCodec = Nothing   , stdioNotifications = Nothing   } @@ -81,6 +89,8 @@   hSetEncoding stderr utf8   hSetEncoding stdout utf8 +  codec <- maybe ephemeralStateCodec pure (stdioStateCodec config)+   -- Subscription threads, request tasks and the main loop share stdout:   -- one line at a time.   writeLock <- newMVar ()@@ -169,7 +179,7 @@     dispatchMessage message = do       -- Request-scoped notifications (progress, client logs) share the       -- locked stdout channel, interleaved before the response-      response <- handleMcpMessage serverInfo (stdioCacheHints config) notifSupport sendNotification handlers anonymousContext message+      response <- handleMcpMessage serverInfo (stdioCacheHints config) codec notifSupport sendNotification handlers anonymousContext message       case response of         Just responseMsg -> do           logLine $ "Sending response for: " <> T.pack (show (getMessageSummary message))

@@ -1,7 +1,11 @@+{-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE DeriveLift        #-} {-# LANGUAGE OverloadedStrings #-} +-- | The library's core types: the content, results, definitions and JSON+-- Schemas that handlers produce, the handler signatures themselves, and the+-- server information and capabilities advertised to clients. module MCP.Server.Types   ( -- * Content Types     Content(..)@@ -75,6 +79,13 @@   , CompletionCapabilities(..)   , LoggingCapabilities(..) +    -- * Asking the client for input+  , Outcome(..)+  , InputRequest(..)+  , InputResponse(..)+  , ElicitAction(..)+  , clientSupportsInput+     -- * Handler Types   , PromptListHandler   , PromptGetHandler@@ -104,9 +115,13 @@ import           Language.Haskell.TH.Syntax (Lift) import           Network.URI      (URI, parseURI) +-- | The name of a prompt, as in @prompts\/get@. type PromptName = Text+-- | The name of a tool, as in @tools\/call@. type ToolName = Text+-- | The name of a prompt or tool argument. type ArgumentName = Text+-- | A prompt argument's value; prompt arguments are always strings. type ArgumentValue = Text  -- | Content that can be returned by prompts, resources, and tools@@ -119,7 +134,7 @@   | ContentResourceLink ResourceDefinition     -- ^ A reference to a resource the client can read separately   | ContentAnnotated Annotations Content-    -- ^ A content block carrying 'Annotations'; the annotations are merged+    -- ^ A content block carrying t'Annotations'; the annotations are merged     -- into the inner block's JSON object. Do not nest.   deriving (Show, Eq, Generic) @@ -202,11 +217,13 @@     <*> o .:? "priority"     <*> o .:? "lastModified" +-- | The payload of an image content block. data ContentImageData = ContentImageData   { contentImageData     :: Text  -- ^ base64-encoded image data   , contentImageMimeType :: Text   } deriving (Show, Eq, Generic) +-- | The payload of an audio content block. data ContentAudioData = ContentAudioData   { contentAudioData     :: Text  -- ^ base64-encoded audio data   , contentAudioMimeType :: Text@@ -394,7 +411,7 @@ 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+-- keeps simple handlers simple; return a full t'ToolResult' for multiple -- content blocks, structured content, or execution errors. class ToToolResult a where   toToolResult :: a -> ToolResult@@ -406,7 +423,7 @@   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'+-- ('toolResultIsError' is OR-ed), and the first present @structuredContent@ -- and @_meta@ are kept. instance ToToolResult a => ToToolResult [a] where   toToolResult xs = ToolResult@@ -438,7 +455,7 @@   | ToolOutputError Text     -- ^ An execution failure, reported with @isError@ (see 'toolError').   | ToolOutputRaw ToolResult-    -- ^ Full control: return this 'ToolResult' as-is, with no structured+    -- ^ Full control: return this t'ToolResult' as-is, with no structured     -- content implied.   deriving (Show, Eq) @@ -450,7 +467,7 @@   } deriving (Show, Eq, Generic)  -- | Types a prompt handler may return. Plain 'Content' (or 'Text') becomes a--- single user message; return 'PromptResult' or @['PromptMessage']@ for+-- single user message; return t'PromptResult' or @[t'PromptMessage']@ for -- multi-message conversations or assistant roles. class ToPromptResult a where   toPromptResult :: a -> PromptResult@@ -577,7 +594,7 @@   } deriving (Show, Eq, Generic)  -- | A prompt definition with only the required fields set; record-update--- the optional ones (constructing 'PromptDefinition' directly breaks when+-- the optional ones (constructing t'PromptDefinition' directly breaks when -- fields are added). mkPromptDefinition :: Text -> Text -> [ArgumentDefinition] -> PromptDefinition mkPromptDefinition name description args = PromptDefinition@@ -756,6 +773,8 @@     [ fmap ("listChanged" .=) (promptListChanged caps)     ] +-- | The @resources@ capability: whether the server supports subscriptions+-- and list-change notifications. data ResourceCapabilities = ResourceCapabilities   { resourceSubscribe   :: Maybe Bool   , resourceListChanged :: Maybe Bool@@ -767,6 +786,8 @@     , fmap ("listChanged" .=) (resourceListChanged caps)     ] +-- | The @tools@ capability: whether the server sends list-change+-- notifications. data ToolCapabilities = ToolCapabilities   { toolListChanged :: Maybe Bool   } deriving (Show, Eq, Generic)@@ -776,6 +797,7 @@     [ fmap ("listChanged" .=) (toolListChanged caps)     ] +-- | The @completions@ capability, which has no options. data CompletionCapabilities = CompletionCapabilities   { -- No sub-capabilities defined   } deriving (Show, Eq, Generic)@@ -783,6 +805,7 @@ instance ToJSON CompletionCapabilities where   toJSON _ = object [] +-- | The @logging@ capability, which has no options. data LoggingCapabilities = LoggingCapabilities   { -- No specific sub-capabilities for logging yet   } deriving (Show, Eq, Generic)@@ -838,6 +861,15 @@       --   (@notifications\/message@). A no-op unless the request declared       --   @io.modelcontextprotocol\/logLevel@ (the spec forbids emitting       --   otherwise); messages below the declared level are dropped.+  , clientInputResponses :: Map Text InputResponse+      -- ^ On a retry after 'InputRequired': the client's answers, keyed as+      --   the handler keyed its requests. Only answers to the requests that+      --   round issued are passed on; anything else the client sends is+      --   ignored. Empty otherwise. Only the latest round's answers arrive;+      --   carry earlier ones in the state.+  , clientRequestState :: Maybe Text+      -- ^ On a retry after 'InputRequired': the state the handler returned,+      --   verified and decrypted by the library. 'Nothing' otherwise.   }  -- | A context carrying no transport- or request-level information: what@@ -851,6 +883,8 @@   , clientCapabilities = Nothing   , reportProgress = \_ _ _ -> pure ()   , logToClient = \_ _ -> pure ()+  , clientInputResponses = mempty+  , clientRequestState = Nothing   }  -- | Cacheability hints stamped onto modern (2026-07-28+) list/read results,@@ -888,20 +922,143 @@   , supportsListen = False   } --- | Handler type definitions. Every handler receives the request's--- 'ClientContext' as its first argument.+-- | What a handler that may ask the client for input produces+-- (@tools\/call@, @prompts\/get@ and @resources\/read@, the requests the+-- specification allows to do so). --+-- 'InputRequired' answers the request with an @input_required@ result:+-- the client gathers the requested input and retries the request, and the+-- handler then sees the answers in 'clientInputResponses' and its state in+-- 'clientRequestState'. The library protects the state (see+-- "MCP.Server.RequestState"), so a handler can put anything in it.+data Outcome a+  = Complete a+    -- ^ The request is done.+  | InputRequired (Map Text InputRequest) (Maybe Text)+    -- ^ Requests for the client, keyed by ids the handler chooses (the+    --   same keys come back in 'clientInputResponses'), and state to+    --   receive back in 'clientRequestState' on the retry.+  deriving (Show, Eq, Functor)++-- | A request for the client to fulfil before retrying.+data InputRequest+  = ElicitForm Text Schema+    -- ^ Ask the user to fill in a form (@elicitation\/create@ in @form@+    --   mode): the message, and the schema of an object whose properties+    --   are strings, numbers, booleans or enumerations.+  | ElicitUrl Text URI+    -- ^ Send the user to a URL to complete an interaction out of band+    --   (@elicitation\/create@ in @url@ mode): the message and the URL.+  | RawInputRequest Text Value+    -- ^ Any other request, by method and params, such as+    --   @sampling\/createMessage@ or @roots\/list@ (both deprecated in+    --   2026-07-28).+  deriving (Show, Eq)++instance ToJSON InputRequest where+  toJSON (ElicitForm message requested) = object+    [ "method" .= ("elicitation/create" :: Text)+    , "params" .= object+        [ "mode" .= ("form" :: Text)+        , "message" .= message+        , "requestedSchema" .= requested+        ]+    ]+  toJSON (ElicitUrl message url) = object+    [ "method" .= ("elicitation/create" :: Text)+    , "params" .= object+        [ "mode" .= ("url" :: Text)+        , "message" .= message+        , "url" .= show url+        ]+    ]+  toJSON (RawInputRequest method params) = object+    [ "method" .= method+    , "params" .= params+    ]++-- | The client's answer to an 'InputRequest'.+data InputResponse+  = ElicitResponse ElicitAction (Maybe (Map Text Value))+    -- ^ The user's action, and the submitted form content when they+    --   accepted a form.+  | RawInputResponse Value+    -- ^ Any other result, such as a sampling or roots result.+  deriving (Show, Eq)++-- | How the user responded to an elicitation.+data ElicitAction+  = ElicitAccept   -- ^ Submitted the form, or confirmed the action+  | ElicitDecline  -- ^ Explicitly declined+  | ElicitCancel   -- ^ Dismissed without choosing+  deriving (Show, Eq, Ord, Enum, Bounded)++instance FromJSON InputResponse where+  parseJSON = withObject "InputResponse" $ \o ->+    case KM.lookup "action" o of+      Just (String a) | Just action <- lookup a actions ->+        ElicitResponse action <$> o .:? "content"+      _ -> pure (RawInputResponse (Object o))+    where+      actions =+        [ ("accept", ElicitAccept)+        , ("decline", ElicitDecline)+        , ("cancel", ElicitCancel)+        ]++-- | Whether the client making this request can fulfil an input request:+-- it must speak a revision with multi round-trip requests (2026-07-28+)+-- and have declared the matching capability. Elicitation is declared per+-- mode; an empty @elicitation@ capability means @form@ only.+clientSupportsInput :: ClientContext -> InputRequest -> Bool+clientSupportsInput ctx request = case clientProtocolVersion ctx of+  Nothing -> False+  Just _  -> case request of+    ElicitForm _ _ -> elicitForm+    ElicitUrl _ _  -> elicitUrl+    RawInputRequest "elicitation/create" params+      | modeOf params == Just "url" -> elicitUrl+      | otherwise                   -> elicitForm+    RawInputRequest "sampling/createMessage" _ -> declared "sampling"+    RawInputRequest "roots/list" _             -> declared "roots"+    RawInputRequest _ _                        -> False+  where+    caps = case clientCapabilities ctx of+      Just (Object o) -> o+      _               -> KM.empty+    declared key = KM.member key caps+    elicitation = case KM.lookup "elicitation" caps of+      Just (Object e) -> Just e+      _               -> Nothing+    elicitForm = case elicitation of+      Just e -> KM.member "form" e || not (KM.member "url" e)+      Nothing -> False+    elicitUrl = maybe False (KM.member "url") elicitation+    modeOf (Object p) = case KM.lookup "mode" p of+      Just (String m) -> Just m+      _               -> Nothing+    modeOf _ = Nothing++-- | List the available prompts (@prompts\/list@). Every handler receives+-- the request's t'ClientContext' as its first argument.+-- -- 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)+-- | Render a prompt from its name and arguments (@prompts\/get@).+type PromptGetHandler = ClientContext -> PromptName -> Map Text Text -> IO (Either Error (Outcome PromptResult)) +-- | List the available resources (@resources\/list@). type ResourceListHandler = ClientContext -> IO [ResourceDefinition]-type ResourceReadHandler = ClientContext -> URI -> IO (Either Error ResourceContent)+-- | Read a resource by URI (@resources\/read@).+type ResourceReadHandler = ClientContext -> URI -> IO (Either Error (Outcome ResourceContent))+-- | List the resource templates (@resources\/templates\/list@). type ResourceTemplateListHandler = ClientContext -> IO [ResourceTemplateDefinition] +-- | List the available tools (@tools\/list@). type ToolListHandler = ClientContext -> IO [ToolDefinition]-type ToolCallHandler = ClientContext -> ToolName -> Map Text Value -> IO (Either Error ToolResult)+-- | Call a tool by name with its JSON arguments (@tools\/call@).+type ToolCallHandler = ClientContext -> ToolName -> Map Text Value -> IO (Either Error (Outcome ToolResult))  -- | Completion handler: given what is being completed ('CompletionRef'), the -- argument name, the partial value typed so far, and any already-resolved

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Forms and handlers for the derived-interface tests of 'Ask' (ADR 0009,+-- phase 3). Splices that derive handlers live in "Spec.DerivedAsk".+module AskTypes where++import           Control.Monad.IO.Class (liftIO)+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Language.Haskell.TH    (recover)+import           MCP.Server+import           MCP.Server.Derive++data Environment = Staging | Production+  deriving (Show, Eq)++data Tag = Urgent | Routine+  deriving (Show, Eq)++newtype Ticket = Ticket Text+  deriving (Show, Eq)++data DeployTarget = DeployTarget+  { environment :: Environment+  , reason      :: Text+  , notify      :: Maybe Bool+  , replicas    :: Int+  , tags        :: [Tag]+  , ticket      :: Maybe Ticket+  } deriving (Show, Eq)++newtype Confirm = Confirm { proceed :: Bool }+  deriving (Show, Eq)++data Styled = Styled { size :: Double, label :: Text, mode :: Environment }+  deriving (Show, Eq)++data Counted = Counted { count :: Int, greeting :: Text }+  deriving (Show, Eq)++$(deriveFormWithDescription ''DeployTarget [("reason", "Why deploy now?")])+$(deriveForm ''Confirm)+$(deriveFormWithOptions ''Styled+    [ ("size", defaultFormFieldOptions { formFieldTitle = Just "Size", formFieldDefault = Just (Number 1.5) })+    , ("mode", defaultFormFieldOptions { formFieldDefault = Just "production", formFieldDescription = Just "Where" })+    ])++$(deriveFormWithOptions ''Counted+    [ ("count", defaultFormFieldOptions { formFieldDefault = Just (Number 3) })+    , ("greeting", defaultFormFieldOptions { formFieldDefault = Just "café 東京" })+    ])++-- Types a form cannot hold, for the compile-time rejection tests.+data Inner = Inner { innerName :: Text } deriving (Show, Eq)+data Nested = Nested { inner :: Inner } deriving (Show, Eq)+data TextList = TextList { names :: [Text] } deriving (Show, Eq)+data Unit = Unit deriving (Show, Eq)++-- | Which derivations were rejected at compile time.+rejectedNested, rejectedTextList, rejectedUnit, rejectedUnknownField, rejectedBadDefault, rejectedBadChoice,+  rejectedFractionalInt, rejectedOutOfRangeInt :: Bool+rejectedNested = $(recover [| True |] (deriveForm ''Nested >> [| False |]))+rejectedTextList = $(recover [| True |] (deriveForm ''TextList >> [| False |]))+rejectedUnit = $(recover [| True |] (deriveForm ''Unit >> [| False |]))+rejectedUnknownField = $(recover [| True |]+  (deriveFormWithDescription ''Confirm [("procede", "typo")] >> [| False |]))+rejectedBadDefault = $(recover [| True |]+  (deriveFormWithOptions ''Confirm [("proceed", defaultFormFieldOptions { formFieldDefault = Just "yes" })] >> [| False |]))+rejectedFractionalInt = $(recover [| True |]+  (deriveFormWithOptions ''Counted [("count", defaultFormFieldOptions { formFieldDefault = Just (Number 1.5) })] >> [| False |]))+rejectedOutOfRangeInt = $(recover [| True |]+  (deriveFormWithOptions ''Counted [("count", defaultFormFieldOptions { formFieldDefault = Just (Number 1e30) })] >> [| False |]))+rejectedBadChoice = $(recover [| True |]+  (deriveFormWithOptions ''Styled [("mode", defaultFormFieldOptions { formFieldDefault = Just "prod" })] >> [| False |]))++-- Tools: one asks, one never does.+data OpsTool+  = Deploy { service :: Text }+  | Status { service :: Text }+  deriving (Show, Eq)++handleOps :: ClientContext -> OpsTool -> Ask Content+handleOps _ (Deploy svc) = do+  target <- elicit ("Where should " <> svc <> " deploy to?")+  case target of+    Accepted t -> do+      plan <- step (pure (T.pack (show (environment t)) <> " x" <> T.pack (show (replicas t))))+      ok <- elicit ("Apply " <> plan <> "?")+      pure $ ContentText $ case ok of+        Accepted (Confirm True) -> "deployed " <> svc <> ": " <> plan+        _                       -> "cancelled"+    other -> pure (ContentText ("no target: " <> T.pack (show (() <$ other))))+handleOps _ (Status svc) = ContentText <$> liftIO (pure (svc <> " is up"))++-- An IO handler still derives unchanged.+handleOpsIO :: ClientContext -> OpsTool -> IO Content+handleOpsIO _ (Deploy svc) = pure (ContentText ("deployed " <> svc))+handleOpsIO _ (Status svc) = pure (ContentText (svc <> " is up"))++-- Structured output from an asking handler.+newtype DeployReport = DeployReport { deployed :: Bool }++handleOpsOutput :: ClientContext -> OpsTool -> Ask (ToolOutput DeployReport)+handleOpsOutput _ _ = do+  ok <- elicit "Go?"+  pure $ ToolOutput $ DeployReport $ case ok of+    Accepted (Confirm b) -> b+    _                    -> False++-- Derived here, where only 'Value' is imported from aeson: the generated+-- serializer must not rely on names from the user's imports.+$(pure [])++outputTools :: (ToolListHandler, ToolCallHandler)+outputTools = $(deriveToolHandlerWithOutput ''OpsTool 'handleOpsOutput ''DeployReport)++-- Prompts and resources can ask too.+newtype OpsPrompt = Briefing { team :: Text }++handlePrompt :: ClientContext -> OpsPrompt -> Ask Content+handlePrompt _ (Briefing t) = do+  ok <- elicit ("Include incidents for " <> t <> "?")+  pure $ ContentText $ case ok of+    Accepted (Confirm True) -> "briefing with incidents"+    _                       -> "briefing"++data OpsResource = Secrets++handleResource :: ClientContext -> URI -> OpsResource -> Ask ResourceContent+handleResource _ uri Secrets = do+  ok <- elicit "Reveal secrets?"+  pure $ ResourceText uri "text/plain" $ case ok of+    Accepted (Confirm True) -> "s3cret"+    _                       -> "hidden"

@@ -7,13 +7,16 @@ import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation+import qualified Spec.AskMonad import qualified Spec.Cancellation import qualified Spec.UnicodeHandling import qualified Spec.DefinitionMetadata+import qualified Spec.DerivedAsk import qualified Spec.DerivedOutput import qualified Spec.GoldenWire import qualified Spec.HandlerExceptions import qualified Spec.HttpTransport+import qualified Spec.InputRequired import qualified Spec.ModernEra import qualified Spec.Progress import qualified Spec.ProtocolVersionNegotiation@@ -30,13 +33,16 @@     Spec.BasicDerivation.spec     Spec.SchemaValidation.spec     Spec.AdvancedDerivation.spec+    Spec.AskMonad.spec     Spec.Cancellation.spec     Spec.UnicodeHandling.spec     Spec.DefinitionMetadata.spec+    Spec.DerivedAsk.spec     Spec.DerivedOutput.spec     Spec.GoldenWire.spec     Spec.HandlerExceptions.spec     Spec.HttpTransport.spec+    Spec.InputRequired.spec     Spec.ModernEra.spec     Spec.Progress.spec     Spec.ProtocolVersionNegotiation.spec

@@ -0,0 +1,258 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Coverage for the 'Ask' monad (ADR 0009, phase 2): handlers replayed+-- against a journal across rounds, through the real dispatcher and state+-- codec.+module Spec.AskMonad (spec) where++import           Control.Monad.IO.Class (liftIO)+import           Data.Aeson+import qualified Data.Aeson.KeyMap      as KM+import           Data.Aeson.Types       (Pair)+import           Data.IORef+import           Data.Text              (Text)+import qualified Data.Text              as T+import           GHC.Generics           (Generic)+import           MCP.Server+import           MCP.Server.Handlers    (handleMcpMessage)+import           MCP.Server.JsonRpc+import           Test.Hspec+import           TestHelpers            (testStateCodec)++newtype Target = Target { environment :: Text } deriving (Show, Eq, Generic)+instance FromJSON Target+instance Form Target where+  formSchema _ = schema $ SchemaObject+    [("environment", schema (SchemaString (Just ["staging", "production"])))]+    ["environment"]++newtype Confirm = Confirm { ok :: Bool } deriving (Show, Eq, Generic)+instance FromJSON Confirm+instance Form Confirm where+  formSchema _ = schema $ SchemaObject [("ok", schema SchemaBoolean)] ["ok"]++-- | Counters for what ran: the journaled planning step, and every round.+data Counters = Counters { planRuns :: IORef Int, rounds :: IORef Int }++-- | Ask for a target, plan once, ask for confirmation.+deploy :: Counters -> Ask Text+deploy counters = do+  liftIO (modifyIORef (rounds counters) (+ 1))+  target <- elicit "Where to?"+  case target of+    Accepted (Target env) -> do+      plan <- step $ do+        modifyIORef (planRuns counters) (+ 1)+        pure ("plan-" <> env)+      confirmed <- elicit ("Apply " <> plan <> "?")+      pure $ case confirmed of+        Accepted (Confirm True) -> "applied " <> plan+        other                   -> "not applied: " <> T.pack (show other)+    other -> pure ("no target: " <> T.pack (show other))++-- | Asks a question that changes every round, which replay must refuse.+fickle :: IORef Int -> Ask Text+fickle counter = do+  n <- liftIO (atomicModifyIORef counter (\c -> (c + 1, c)))+  reply <- elicit ("Question " <> T.pack (show n))+  pure (T.pack (show (reply :: Answer Confirm)))++-- | A step whose result is JSON null, a question, and a step after it.+nullStep :: Ask Text+nullStep = do+  nothing <- step (pure (Nothing :: Maybe Text))+  reply <- elicit "Still there?"+  later <- step (pure (2 :: Int))+  pure (T.pack (show (nothing, reply :: Answer Confirm, later)))++handlersFor :: Counters -> IORef Int -> McpServerHandlers+handlersFor counters fickleCounter = noHandlers+  { tools = Just+      ( \_ -> pure []+      , \ctx name _ -> fmap (fmap (\t -> toolResult [ContentText t])) <$>+          runAsk (case name of+                    "fickle" -> fickle fickleCounter+                    "null"   -> nullStep+                    _        -> deploy counters) ctx+      )+  }++newCounters :: IO (Counters, IORef Int)+newCounters = (,) <$> (Counters <$> newIORef 0 <*> newIORef 0) <*> newIORef 0++call :: (Counters, IORef Int) -> Text -> Value -> [Pair] -> IO Value+call (counters, fickleCounter) name caps extra = do+  response <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec+    noNotificationSupport (\_ -> pure ()) (handlersFor counters fickleCounter) anonymousContext $+      JsonRpcMessageRequest JsonRpcRequest+        { requestJsonrpc = "2.0"+        , requestId = RequestIdNumber 1+        , requestMethod = "tools/call"+        , requestParams = Just $ object $ extra +++            [ "name" .= name+            , "arguments" .= object []+            , "_meta" .= object+                [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)+                , "io.modelcontextprotocol/clientCapabilities" .= caps+                ]+            ]+        }+  case response of+    Just (JsonRpcMessageResponse r) -> pure (toJSON r)+    other -> fail ("expected a response, got " ++ show other)++formCaps, noCaps :: Value+formCaps = object ["elicitation" .= object ["form" .= object []]]+noCaps = object []++at :: [Key] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KM.lookup k o >>= at ks+at _ _ = Nothing++stateOf :: Value -> Text+stateOf v = case at ["result", "requestState"] v of+  Just (String s) -> s+  _               -> error ("no requestState in " ++ show v)++-- | The keys of an @input_required@ result's requests, and their messages.+questionsOf :: Value -> [(Key, Value)]+questionsOf v = case at ["result", "inputRequests"] v of+  Just (Object rs) -> [(k, m) | (k, r) <- KM.toList rs, Just m <- [at ["params", "message"] r]]+  _                -> []++textOf :: Value -> Maybe Value+textOf v = case at ["result", "content"] v of+  Just (Array xs) | [c] <- foldr (:) [] xs -> at ["text"] c+  _                                       -> Nothing++errorOf :: Value -> Maybe (Int, Text)+errorOf v = do+  Number code <- at ["error", "code"] v+  String msg <- at ["error", "message"] v+  pure (round code, msg)++answer :: Key -> Value -> Pair+answer key response = "inputResponses" .= object [key .= response]++accepted :: [Pair] -> Value+accepted content = object ["action" .= ("accept" :: Text), "content" .= object content]++retrying :: Value -> [Pair]+retrying previous = ["requestState" .= stateOf previous]++spec :: Spec+spec = describe "The Ask monad" $ do+  it "asks, replays answers and steps, and completes" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    questionsOf r1 `shouldBe` [("0", String "Where to?")]+    r2 <- call env "deploy" formCaps $+      answer "0" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1+    questionsOf r2 `shouldBe` [("2", String "Apply plan-staging?")]+    r3 <- call env "deploy" formCaps $+      answer "2" (accepted ["ok" .= True]) : retrying r2+    textOf r3 `shouldBe` Just (String "applied plan-staging")+    readIORef (planRuns (fst env)) `shouldReturn` 1+    readIORef (rounds (fst env)) `shouldReturn` 3++  it "keeps earlier answers in the journal, not in the retry" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    r2 <- call env "deploy" formCaps $+      answer "0" (accepted ["environment" .= ("production" :: Text)]) : retrying r1+    -- The last round's answers only: the first answer comes from the state.+    r3 <- call env "deploy" formCaps $ answer "2" (accepted ["ok" .= False]) : retrying r2+    textOf r3 `shouldBe` Just (String "not applied: Accepted (Confirm {ok = False})")++  it "asks again when the retry carries no answer" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    r2 <- call env "deploy" formCaps (retrying r1)+    questionsOf r2 `shouldBe` [("0", String "Where to?")]++  it "returns a declined or cancelled answer to the handler" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    declined <- call env "deploy" formCaps $+      answer "0" (object ["action" .= ("decline" :: Text)]) : retrying r1+    textOf declined `shouldBe` Just (String "no target: Declined")+    cancelled <- call env "deploy" formCaps $+      answer "0" (object ["action" .= ("cancel" :: Text)]) : retrying r1+    textOf cancelled `shouldBe` Just (String "no target: Cancelled")++  it "answers Unavailable without a round trip when the client cannot ask" $ do+    env <- newCounters+    r <- call env "deploy" noCaps []+    textOf r `shouldBe` Just (String "no target: Unavailable")+    legacy <- runAsk (deploy (fst env)) anonymousContext+    legacy `shouldBe` Right (Complete "no target: Unavailable")++  it "runs a step again when a round is retried from an earlier state" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    let staging = answer "0" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1+    _ <- call env "deploy" formCaps staging+    _ <- call env "deploy" formCaps staging+    readIORef (planRuns (fst env)) `shouldReturn` 2++  it "refuses a handler whose questions change between rounds" $ do+    env <- newCounters+    r1 <- call env "fickle" formCaps []+    questionsOf r1 `shouldBe` [("0", String "Question 0")]+    r2 <- call env "fickle" formCaps $ answer "0" (accepted ["ok" .= True]) : retrying r1+    fmap fst (errorOf r2) `shouldBe` Just (-32603)+    fmap (T.isInfixOf "position 0" . snd) (errorOf r2) `shouldBe` Just True++  it "rejects content that does not fit the form" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    r2 <- call env "deploy" formCaps $+      answer "0" (accepted ["environment" .= (3 :: Int)]) : retrying r1+    fmap fst (errorOf r2) `shouldBe` Just (-32602)++  it "rejects an answer that is not an elicitation result" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    r2 <- call env "deploy" formCaps $+      answer "0" (object ["roots" .= ([] :: [Value])]) : retrying r1+    fmap fst (errorOf r2) `shouldBe` Just (-32602)++  it "completes without state when nothing is asked" $ do+    result <- runAsk (step (pure (42 :: Int))) anonymousContext+    result `shouldBe` Right (Complete 42)++  it "fails a run whose journal belongs to a different handler" $ do+    env <- newCounters+    Right (InputRequired _ journal) <- runAsk (deploy (fst env)) anonymousContext+      { clientProtocolVersion = Just "2026-07-28"+      , clientCapabilities = Just formCaps+      }+    result <- runAsk (step (pure (1 :: Int))) anonymousContext { clientRequestState = journal }+    case result of+      Left (InternalError msg) -> msg `shouldSatisfy` T.isInfixOf "position 0"+      other -> expectationFailure ("expected a mismatch, got " ++ show other)++  it "keeps the pending question's key stable across unrelated rounds" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    let unrelated = answer "1" (accepted ["environment" .= ("staging" :: Text)]) : retrying r1+    r2 <- call env "deploy" formCaps unrelated+    questionsOf r2 `shouldBe` [("0", String "Where to?")]++  it "replays a step whose result is null" $ do+    env <- newCounters+    r1 <- call env "null" formCaps []+    questionsOf r1 `shouldBe` [("1", String "Still there?")]+    r2 <- call env "null" formCaps $ answer "1" (accepted ["ok" .= True]) : retrying r1+    textOf r2 `shouldBe` Just (String "(Nothing,Accepted (Confirm {ok = True}),2)")++  it "settles a pending question as Unavailable when the client can no longer ask" $ do+    env <- newCounters+    r1 <- call env "deploy" formCaps []+    r2 <- call env "deploy" noCaps (retrying r1)+    textOf r2 `shouldBe` Just (String "no target: Unavailable")+    r3 <- call env "null" formCaps []+    r4 <- call env "null" noCaps (retrying r3)+    textOf r4 `shouldBe` Just (String "(Nothing,Unavailable,2)")

@@ -33,7 +33,7 @@   case parseURI uriString of     Just uri -> do       result <- handler anonCtx uri-      case result of+      case completed result of         Right (ResourceText _ _ content) -> content `shouldBe` expected         Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob"         Left err -> expectationFailure $ "Expected success but got error: " ++ show err@@ -64,7 +64,7 @@             if useSubstringMatch testCase               then do                 result <- readHandler anonCtx uri-                case result of+                case completed result of                   Right (ResourceText _ _ content) ->                     T.isInfixOf (resourceExpectedContent testCase) content `shouldBe` True                   Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob"

@@ -19,11 +19,14 @@ import MCP.Server.Handlers (handleMcpMessage) import MCP.Server.JsonRpc import Test.Hspec+import TestHelpers (testStateCodec)  -- A slow tools/call carrying a progressToken (so emissions are live),--- driven from an async that the test cancels once the handler signals--- it has started.-runCancelled :: (ClientContext -> IO ()) -> IO [JsonRpcNotification]+-- driven from an async that the test cancels once the handler body signals+-- it is ready: the body gets the signal as an action, and calls it once it+-- has reached the point the test is about (inside a bracket, say), so+-- cancellation cannot arrive earlier.+runCancelled :: (IO () -> ClientContext -> IO ()) -> IO [JsonRpcNotification] runCancelled handlerBody = do   sink <- newIORef []   started <- newEmptyMVar@@ -33,9 +36,8 @@             ( \_ -> pure []             , \ctx _ _ -> do                 reportProgress ctx 0 (Just 1) Nothing-                putMVar started ()-                handlerBody ctx-                pure $ Right $ toToolResult ("done" :: Text)+                handlerBody (putMVar started ()) ctx+                pure $ Right $ Complete $ toToolResult ("done" :: Text)             )         }       params = object@@ -44,7 +46,7 @@         , "_meta" .= object ["progressToken" .= ("t" :: Text)]         ]   task <- async $ do-    resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints+    resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec       noNotificationSupport (\n -> modifyIORef' sink (++ [n]))       handlers anonymousContext       (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params)))@@ -62,7 +64,8 @@    it "a cancelled handler stops emitting and never yields a response" $ do     lateEmit <- newIORef False-    ns <- runCancelled $ \ctx -> do+    ns <- runCancelled $ \ready ctx -> do+      ready       threadDelay 5000000       writeIORef lateEmit True       reportProgress ctx 1 (Just 1) Nothing@@ -73,8 +76,9 @@   it "bracket releases handler resources on cancellation" $ do     acquired <- newIORef False     released <- newIORef False-    _ <- runCancelled $ \_ ->-      bracket_ (writeIORef acquired True) (writeIORef released True) $+    _ <- runCancelled $ \ready _ ->+      bracket_ (writeIORef acquired True) (writeIORef released True) $ do+        ready         threadDelay 5000000     readIORef acquired `shouldReturn` True     readIORef released `shouldReturn` True

@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Coverage for the derived interface of multi round-trip requests (ADR+-- 0009, phase 3): derived forms, and derived handlers that return 'Ask'.+module Spec.DerivedAsk (spec) where++import           Data.Aeson+import qualified Data.Aeson.KeyMap   as KM+import           Data.Aeson.Types    (Pair)+import qualified Data.Map            as Map+import           Data.Proxy          (Proxy (..))+import           Data.Text           (Text)+import           MCP.Server+import           MCP.Server.Derive+import           MCP.Server.Handlers (handleMcpMessage)+import           MCP.Server.JsonRpc+import           Test.Hspec+import           TestHelpers         (testStateCodec)++import           AskTypes++handlers :: McpServerHandlers+handlers = noHandlers+  { tools = Just $(deriveToolHandler ''OpsTool 'handleOps)+  , prompts = Just $(derivePromptHandler ''OpsPrompt 'handlePrompt)+  , resources = Just $(deriveResourceHandler ''OpsResource 'handleResource)+  }++ioTools :: (ToolListHandler, ToolCallHandler)+ioTools = $(deriveToolHandler ''OpsTool 'handleOpsIO)++request :: McpServerHandlers -> Text -> Value -> [Pair] -> IO Value+request hs method caps params = do+  response <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec+    noNotificationSupport (\_ -> pure ()) hs anonymousContext $+      JsonRpcMessageRequest JsonRpcRequest+        { requestJsonrpc = "2.0"+        , requestId = RequestIdNumber 1+        , requestMethod = method+        , requestParams = Just $ object $ params +++            [ "_meta" .= object+                [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)+                , "io.modelcontextprotocol/clientCapabilities" .= caps+                ]+            ]+        }+  case response of+    Just (JsonRpcMessageResponse r) -> pure (toJSON r)+    other -> fail ("expected a response, got " ++ show other)++formCaps, noCaps :: Value+formCaps = object ["elicitation" .= object ["form" .= object []]]+noCaps = object []++at :: [Key] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KM.lookup k o >>= at ks+at _ _ = Nothing++-- | The single request of an @input_required@ result: its key and params.+questionOf :: Value -> Maybe (Key, Value)+questionOf v = case at ["result", "inputRequests"] v of+  Just (Object rs) | [(k, r)] <- KM.toList rs -> (,) k <$> at ["params"] r+  _ -> Nothing++-- | The params of a retry answering the given result's question.+answering :: Value -> [Pair] -> [Pair]+answering previous content = case (questionOf previous, at ["result", "requestState"] previous) of+  (Just (key, _), Just st) ->+    [ "inputResponses" .= object [key .= object ["action" .= ("accept" :: Text), "content" .= object content]]+    , "requestState" .= st+    ]+  _ -> error ("not an input_required result: " ++ show previous)++firstText :: Value -> Maybe Value+firstText v = case at ["result", "content"] v of+  Just (Array xs) | (c : _) <- foldr (:) [] xs -> at ["text"] c+  _ -> case at ["result", "messages"] v of+    Just (Array xs) | (m : _) <- foldr (:) [] xs -> at ["content", "text"] m+    _ -> case at ["result", "contents"] v of+      Just (Array xs) | (c : _) <- foldr (:) [] xs -> at ["text"] c+      _ -> Nothing++callDeploy :: [Pair] -> [Pair]+callDeploy extra = ["name" .= ("deploy" :: Text), "arguments" .= object ["service" .= ("billing" :: Text)]] ++ extra++spec :: Spec+spec = describe "Derived handlers that ask" $ do+  describe "deriveForm" $ do+    it "derives a flat schema from a record" $+      toJSON (formSchema (Proxy :: Proxy DeployTarget)) `shouldBe` object+        [ "type" .= ("object" :: Text)+        , "properties" .= object+            [ "environment" .= object ["type" .= ("string" :: Text), "enum" .= (["staging", "production"] :: [Text])]+            , "reason" .= object ["type" .= ("string" :: Text), "description" .= ("Why deploy now?" :: Text)]+            , "notify" .= object ["type" .= ("boolean" :: Text)]+            , "replicas" .= object ["type" .= ("integer" :: Text)]+            , "tags" .= object+                [ "type" .= ("array" :: Text)+                , "items" .= object ["type" .= ("string" :: Text), "enum" .= (["urgent", "routine"] :: [Text])]+                ]+            , "ticket" .= object ["type" .= ("string" :: Text)]+            ]+        , "required" .= (["environment", "reason", "replicas", "tags"] :: [Text])+        ]++    it "adds titles and defaults from the options" $+      toJSON (formSchema (Proxy :: Proxy Styled)) `shouldBe` object+        [ "type" .= ("object" :: Text)+        , "properties" .= object+            [ "size" .= object ["type" .= ("number" :: Text), "title" .= ("Size" :: Text), "default" .= (1.5 :: Double)]+            , "label" .= object ["type" .= ("string" :: Text)]+            , "mode" .= object+                [ "type" .= ("string" :: Text), "enum" .= (["staging", "production"] :: [Text])+                , "default" .= ("production" :: Text), "description" .= ("Where" :: Text)+                ]+            ]+        , "required" .= (["size", "label", "mode"] :: [Text])+        ]++    it "parses submitted content" $+      formParse (Map.fromList+        [ ("environment", "production"), ("reason", "hotfix"), ("replicas", Number 3)+        , ("tags", toJSON ["urgent" :: Text]), ("ticket", "OPS-1") ])+        `shouldBe` Right (DeployTarget Production "hotfix" Nothing 3 [Urgent] (Just (Ticket "OPS-1")))++    it "names the field when content does not fit" $+      (formParse (Map.fromList [("proceed", "maybe")]) :: Either Text Confirm)+        `shouldBe` Left "field 'proceed': Failed to parse Bool from: maybe"++    it "rejects types a form cannot hold at compile time" $ do+      rejectedNested `shouldBe` True+      rejectedTextList `shouldBe` True+      rejectedUnit `shouldBe` True+      rejectedUnknownField `shouldBe` True+      rejectedBadDefault `shouldBe` True+      rejectedBadChoice `shouldBe` True+      rejectedFractionalInt `shouldBe` True+      rejectedOutOfRangeInt `shouldBe` True++    it "keeps whole-number and non-ASCII defaults intact" $+      toJSON (formSchema (Proxy :: Proxy Counted)) `shouldBe` object+        [ "type" .= ("object" :: Text)+        , "properties" .= object+            [ "count" .= object ["type" .= ("integer" :: Text), "default" .= (3 :: Int)]+            , "greeting" .= object ["type" .= ("string" :: Text), "default" .= ("café 東京" :: Text)]+            ]+        , "required" .= (["count", "greeting"] :: [Text])+        ]++  describe "derive*Handler with Ask" $ do+    it "runs a derived tool across rounds" $ do+      r1 <- request handlers "tools/call" formCaps (callDeploy [])+      fmap fst (questionOf r1) `shouldBe` Just "0"+      fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Where should billing deploy to?")+      fmap (at ["requestedSchema", "required"] . snd) (questionOf r1)+        `shouldBe` Just (Just (toJSON (["environment", "reason", "replicas", "tags"] :: [Text])))+      r2 <- request handlers "tools/call" formCaps $ callDeploy $ answering r1+        [ "environment" .= ("staging" :: Text), "reason" .= ("fix" :: Text)+        , "replicas" .= (2 :: Int), "tags" .= ([] :: [Text]) ]+      fmap (at ["message"] . snd) (questionOf r2) `shouldBe` Just (Just "Apply Staging x2?")+      r3 <- request handlers "tools/call" formCaps $ callDeploy $ answering r2 ["proceed" .= True]+      firstText r3 `shouldBe` Just "deployed billing: Staging x2"++    it "answers a tool that never asks in one round" $ do+      r <- request handlers "tools/call" formCaps+        ["name" .= ("status" :: Text), "arguments" .= object ["service" .= ("billing" :: Text)]]+      firstText r `shouldBe` Just "billing is up"++    it "falls back without a round trip when the client cannot ask" $ do+      r <- request handlers "tools/call" noCaps (callDeploy [])+      firstText r `shouldBe` Just "no target: Unavailable"++    it "still derives IO handlers" $ do+      r <- request noHandlers { tools = Just ioTools } "tools/call" formCaps (callDeploy [])+      firstText r `shouldBe` Just "deployed billing"++    it "asks from a handler with structured output" $ do+      let hs = noHandlers { tools = Just outputTools }+      r1 <- request hs "tools/call" formCaps (callDeploy [])+      fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Go?")+      r2 <- request hs "tools/call" formCaps $ callDeploy $ answering r1 ["proceed" .= True]+      at ["result", "structuredContent"] r2 `shouldBe` Just (object ["deployed" .= True])++    it "asks from a derived prompt" $ do+      let get extra = request handlers "prompts/get" formCaps $+            ["name" .= ("briefing" :: Text), "arguments" .= object ["team" .= ("ops" :: Text)]] ++ extra+      r1 <- get []+      fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Include incidents for ops?")+      r2 <- get (answering r1 ["proceed" .= True])+      firstText r2 `shouldBe` Just "briefing with incidents"++    it "asks from a derived resource" $ do+      let readIt extra = request handlers "resources/read" formCaps $+            ["uri" .= ("resource://secrets" :: Text)] ++ extra+      r1 <- readIt []+      fmap (at ["message"] . snd) (questionOf r1) `shouldBe` Just (Just "Reveal secrets?")+      r2 <- readIt (answering r1 ["proceed" .= False])+      firstText r2 `shouldBe` Just "hidden"

@@ -19,7 +19,7 @@ weatherHandlers = $(deriveToolHandlerWithOutputDescription ''WeatherTool 'handleWeatherTool ''WeatherReport   [ ("GetWeather", "Current weather"), ("wrTemperature", "Degrees Celsius") ]) -callWeather :: Text -> [(Text, Value)] -> IO (Either Error ToolResult)+callWeather :: Text -> [(Text, Value)] -> IO (Either Error (Outcome ToolResult)) callWeather name args = snd weatherHandlers anonCtx name (valueArgs args)  -- The serialized form the derivation guarantees for 'sampleReport'@@ -64,7 +64,7 @@   describe "ToolOutput results" $ do     it "serializes the typed value into structuredContent with a matching text block" $ do       result <- callWeather "get_weather" [("wtCity", String "Cape Town")]-      case result of+      case completed result of         Right tr -> do           toolResultIsError tr `shouldBe` False           toolResultStructured tr `shouldBe` Just (expectedReport "Cape Town" (Just 60))@@ -77,26 +77,26 @@      it "renders the text block canonically (sorted keys, build-plan independent)" $ do       result <- callWeather "get_weather" [("wtCity", String "Cape Town")]-      case result of+      case completed result of         Right tr -> toolResultContent tr `shouldBe`           [ContentText "{\"wrAlerts\":[\"wind advisory for Cape Town\"],\"wrHumidity\":60,\"wrSky\":\"sky_cloudy\",\"wrTemperature\":21,\"wrWind\":{\"windGusting\":false,\"windSpeedKph\":12.5}}"]         Left err -> expectationFailure $ "expected result, got error: " ++ show err      it "omits Nothing fields from the serialized value" $ do       result <- callWeather "custom_report" [("wtRegion", String "Karoo")]-      case result of+      case completed result of         Right tr -> toolResultStructured tr `shouldBe` Just (expectedReport "Karoo" Nothing)         Left err -> expectationFailure $ "expected result, got error: " ++ show err      it "keeps caller-supplied content blocks with ToolOutputWith" $ do       result <- callWeather "custom_report" [("wtRegion", String "Karoo")]-      case result of+      case completed result of         Right tr -> toolResultContent tr `shouldBe` [ContentText "Report for Karoo"]         Left err -> expectationFailure $ "expected result, got error: " ++ show err      it "reports ToolOutputError as an isError result" $ do       result <- callWeather "broken_station" [("wtStation", String "X1")]-      case result of+      case completed result of         Right tr -> do           toolResultIsError tr `shouldBe` True           toolResultStructured tr `shouldBe` Nothing@@ -105,7 +105,7 @@      it "passes ToolOutputRaw through untouched" $ do       result <- callWeather "plain_forecast" [("wtNote", String "sunny")]-      case result of+      case completed result of         Right tr -> do           toolResultStructured tr `shouldBe` Nothing           toolResultContent tr `shouldBe` [ContentText "sunny"]

@@ -30,7 +30,9 @@  import Control.Monad (forM_) import Data.Aeson+import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (toList) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T@@ -41,6 +43,7 @@ import System.Directory (doesFileExist) import System.Environment (lookupEnv) import Test.Hspec+import TestHelpers (testStateCodec)  goldenServerInfo :: McpServerInfo goldenServerInfo = McpServerInfo@@ -64,7 +67,7 @@           [ArgumentDefinition "name" "Who to greet" True]       ]     promptGet _ name args = case name of-      "greet" -> pure $ Right $ PromptResult (Just "A greeting")+      "greet" -> pure $ Right $ Complete $ PromptResult (Just "A greeting")         [PromptMessage RoleUser (ContentText ("Hello, " <> Map.findWithDefault "?" "name" args <> "!"))]       _ -> pure $ Left $ InvalidPromptName name @@ -75,7 +78,7 @@           }       ]     resourceRead _ uri-      | show uri == "resource://info" = pure $ Right $ ResourceText uri "text/plain" "The golden info"+      | show uri == "resource://info" = pure $ Right $ Complete $ ResourceText uri "text/plain" "The golden info"       | otherwise = pure $ Left $ ResourceNotFound $ T.pack $ show uri      toolList _ = pure@@ -85,9 +88,9 @@       ]     toolCall _ name args = case name of       "echo" -> case Map.lookup "text" args of-        Just (String t) -> pure $ Right $ toolResult [ContentText ("echo: " <> t)]+        Just (String t) -> pure $ Right $ Complete $ toolResult [ContentText ("echo: " <> t)]         _               -> pure $ Left $ MissingRequiredParams "field 'text' is missing"-      "boom" -> pure $ Right $ toolError "kaboom"+      "boom" -> pure $ Right $ Complete $ toolError "kaboom"       _      -> pure $ Left $ UnknownTool name  -- The extended set's structured-output tool, derived so the corpus pins@@ -174,11 +177,37 @@            )   } +-- | 'goldenHandlers' with one tool that asks for input (multi round-trip+-- requests): @confirm@ asks for a boolean @ok@ under the key @proceed@,+-- with a request state, until it receives an answer.+mrtrHandlers :: McpServerHandlers+mrtrHandlers = goldenHandlers+  { tools = Just+      ( \_ -> pure []+      , \ctx _name _args -> pure $ Right $+          case Map.lookup "proceed" (clientInputResponses ctx) of+            Nothing -> InputRequired+              (Map.singleton "proceed" (ElicitForm "Proceed?"+                (schema (SchemaObject [("ok", schema SchemaBoolean)] ["ok"]))))+              (Just "confirming")+            Just _ -> Complete (toolResult [ContentText "confirmed"])+      )+  }++-- | A fixture value of @"<opaque>"@ matches any string: used for values a+-- server generates afresh, such as a sealed @requestState@. Returns the+-- actual value with those strings replaced, ready for an equality check.+matchOpaque :: Value -> Value -> Value+matchOpaque (String "<opaque>") (String _) = String "<opaque>"+matchOpaque (Object f) (Object a) = Object (KM.mapWithKey (\k v -> maybe v (`matchOpaque` v) (KM.lookup k f)) a)+matchOpaque (Array f) (Array a) | length f == length a = toJSON (zipWith matchOpaque (toList f) (toList a))+matchOpaque _ actual = actual+ -- | One manifest entry: which case, and which reference-server variant -- answers it. data GoldenCase = GoldenCase   { caseName          :: FilePath-  , caseHandlers      :: Text  -- ^ "base" or "extended"+  , caseHandlers      :: Text  -- ^ "base", "extended" or "mrtr"   , caseNotifications :: Bool   } @@ -205,11 +234,14 @@ runCase gc raw = do   jsonValue <- either (fail . ("request does not parse: " ++)) pure (eitherDecode raw)   message <- either (fail . ("request is not JSON-RPC: " ++)) pure (parseJsonRpcMessage jsonValue)-  let handlers = if caseHandlers gc == "extended" then extendedHandlers else goldenHandlers+  let handlers = case caseHandlers gc of+        "extended" -> extendedHandlers+        "mrtr"     -> mrtrHandlers+        _          -> goldenHandlers       support = if caseNotifications gc         then NotificationSupport { supportsLegacyPush = True, supportsListen = True }         else noNotificationSupport-  maybeResponse <- handleMcpMessage goldenServerInfo defaultCacheHints support (\_ -> pure ()) handlers anonymousContext message+  maybeResponse <- handleMcpMessage goldenServerInfo defaultCacheHints testStateCodec support (\_ -> pure ()) handlers anonymousContext message   case maybeResponse of     Just responseMsg -> pure $ encodeJsonRpcMessage responseMsg     Nothing          -> fail "expected a response"@@ -229,7 +261,7 @@         fixtureBytes <- BSL.readFile responsePath         case eitherDecode fixtureBytes :: Either String Value of           Left err      -> expectationFailure $ "fixture does not parse: " ++ err-          Right fixture -> actual `shouldBe` fixture+          Right fixture -> matchOpaque fixture actual `shouldBe` fixture  spec :: Spec spec = describe "Golden wire-format fixtures" $ do

@@ -14,6 +14,7 @@ import MCP.Server.Handlers (handleMcpMessage) import MCP.Server.JsonRpc import Test.Hspec+import TestHelpers (testStateCodec)  throwingServer :: McpServerHandlers throwingServer = noHandlers@@ -29,7 +30,7 @@  call :: T.Text -> Value -> IO (Maybe JsonRpcMessage) call method params =-  handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints+  handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec     noNotificationSupport (\_ -> pure ()) throwingServer anonymousContext     (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 7) method (Just params))) 

@@ -17,25 +17,37 @@ import Data.IORef import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import MCP.Server import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import Network.Wai.Internal (ResponseReceived (..)) import Test.Hspec+import TestHelpers (testStateCodec)+import qualified Data.Map as Map  server :: McpServerHandlers server = noHandlers   { tools = Just       ( \_ -> pure []-      , \_ name _ -> case name of+      , \ctx name _ -> case name of           "boom" -> throwIO (ErrorCall "tool exploded")-          "ok"   -> pure $ Right $ toToolResult ("fine" :: Text)+          "ok"   -> pure $ Right $ Complete $ toToolResult ("fine" :: Text)+          "ask"  -> pure $ Right $ case Map.lookup "q" (clientInputResponses ctx) of+            Nothing -> InputRequired+              (Map.singleton "q" (ElicitForm "Sure?" (schema (SchemaObject [] []))))+              (Just "asked")+            Just _ -> Complete $ toToolResult+              ("answered after " <> maybe "nothing" id (clientRequestState ctx))           _      -> pure $ Left $ UnknownTool name       )   } -app :: Wai.Application-app = mcpApplication defaultHttpConfig { httpAllowedOrigins = Nothing }+app :: IO Wai.Application+app = mcpApplication defaultHttpConfig+        { httpAllowedOrigins = Nothing+        , httpStateCodec = Just testStateCodec  -- shared across 'post's+        }         (McpServerInfo "T" "1" "") server  -- | POST a JSON body to /mcp and collect the full response, whether it was@@ -57,7 +69,8 @@         }   out <- newIORef mempty   result <- newIORef Nothing-  _ <- app req $ \resp -> do+  application <- app+  _ <- application req $ \resp -> do     let (status, headers, withBody) = Wai.responseToStream resp     withBody $ \streamingBody ->       streamingBody (\b -> modifyIORef' out (<> b)) (pure ())@@ -90,8 +103,49 @@   String m <- KM.lookup "message" e   pure (round c, m) +-- | A modern tools/call of the "ask" tool, with extra params.+askCall :: [(Key, Value)] -> Value+askCall extra = object+  [ "jsonrpc" .= ("2.0" :: Text)+  , "id" .= (8 :: Int)+  , "method" .= ("tools/call" :: Text)+  , "params" .= object (+      [ "name" .= ("ask" :: Text)+      , "_meta" .= object+          [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)+          , "io.modelcontextprotocol/clientCapabilities" .= object ["elicitation" .= object []]+          ]+      ] ++ extra)+  ]++modernHeaders :: Text -> [HTTP.Header]+modernHeaders name =+  [ ("MCP-Protocol-Version", "2026-07-28")+  , ("Mcp-Method", "tools/call")+  , ("Mcp-Name", TE.encodeUtf8 name)+  ]++resultIn :: BS.ByteString -> Maybe Object+resultIn raw = do+  Object o <- decodeStrict raw+  Object r <- KM.lookup "result" o+  pure r+ spec :: Spec spec = describe "HTTP transport (in-process WAI)" $ do+  it "carries a multi round-trip request across two POSTs" $ do+    (status1, _, body1) <- post (modernHeaders "ask") (askCall [])+    HTTP.statusCode status1 `shouldBe` 200+    let first = resultIn body1+    (first >>= KM.lookup "resultType") `shouldBe` Just (String "input_required")+    Just (String sealed) <- pure (first >>= KM.lookup "requestState")+    (status2, _, body2) <- post (modernHeaders "ask") $ askCall+      [ "inputResponses" .= object ["q" .= object ["action" .= ("accept" :: Text), "content" .= object []]]+      , "requestState" .= sealed+      ]+    HTTP.statusCode status2 `shouldBe` 200+    body2 `shouldSatisfy` ("answered after asked" `BS.isInfixOf`)+   it "answers a normal tool call with 200 and a result" $ do     (status, _, body) <- post [] (toolCall "ok" [])     HTTP.statusCode status `shouldBe` 200

@@ -0,0 +1,369 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Coverage for multi round-trip requests (ADR 0009, phase 1): the+-- request-state codec, and dispatch of 'InputRequired' outcomes — the+-- @input_required@ result, verified retries, and every way a retry's state+-- is rejected.+module Spec.InputRequired (spec) where++import           Data.Aeson+import qualified Data.Aeson.KeyMap   as KM+import           Data.Aeson.Types    (Pair)+import qualified Data.ByteString     as BS+import qualified Data.Map            as Map+import           Data.Maybe          (fromMaybe)+import           Data.Text           (Text)+import qualified Data.Text           as T+import           MCP.Server+import           MCP.Server.Handlers (handleMcpMessage)+import           MCP.Server.JsonRpc+import           Test.Hspec+import           TestHelpers         (testStateCodec)++-- | A tool that asks for confirmation, then reports what it was given.+confirmTool :: ToolCallHandler+confirmTool ctx _name args = pure $ Right $+  case Map.lookup "proceed" (clientInputResponses ctx) of+    Nothing -> InputRequired+      (Map.singleton "proceed" (ElicitForm ("Deploy " <> target <> "?") confirmSchema))+      (Just ("planned:" <> target))+    Just (ElicitResponse ElicitAccept (Just content)) -> Complete $ toolResult+      [ ContentText $ "state=" <> fromMaybe "none" (clientRequestState ctx)+          <> " answer=" <> T.pack (show (Map.lookup "ok" content))+      ]+    Just other -> Complete $ toolError ("not confirmed: " <> T.pack (show other))+  where+    target = case Map.lookup "target" args of+      Just (String t) -> t+      _               -> "nowhere"++-- | A tool that sends the user to a URL.+linkTool :: ToolCallHandler+linkTool _ _ _ = pure $ Right $+  InputRequired (Map.singleton "login" (ElicitUrl "Sign in" loginUri)) Nothing+  where+    loginUri = fromMaybe (error "bad URI") (parseURI "https://example.com/login")++confirmSchema :: Schema+confirmSchema = schema $ SchemaObject [("ok", schema SchemaBoolean)] ["ok"]++handlers :: McpServerHandlers+handlers = noHandlers+  { tools = Just+      ( \_ -> pure []+      , \ctx name args -> case name of+          "link" -> linkTool ctx name args+          _      -> confirmTool ctx name args+      )+  , resources = Just+      ( \_ -> pure []+      , \ctx uri -> pure $ Right $+          if Map.null (clientInputResponses ctx)+            then InputRequired (Map.singleton "q" (ElicitForm "Which?" confirmSchema)) Nothing+            else Complete (ResourceText uri "text/plain" "read after asking")+      )+  , prompts = Just+      ( \_ -> pure []+      , \ctx _ _ -> pure $ Right $+          if Map.null (clientInputResponses ctx)+            then InputRequired (Map.singleton "q" (ElicitForm "Tone?" confirmSchema)) (Just "p")+            else Complete (PromptResult Nothing [PromptMessage RoleUser (ContentText "asked")])+      )+  }++serverInfo :: McpServerInfo+serverInfo = McpServerInfo "T" "1" ""++-- | Dispatch one request through the given codec and context.+runWith :: StateCodec -> ClientContext -> Text -> Value -> IO Value+runWith codec ctx method params = do+  response <- handleMcpMessage serverInfo defaultCacheHints codec noNotificationSupport+    (\_ -> pure ()) handlers ctx $ JsonRpcMessageRequest JsonRpcRequest+      { requestJsonrpc = "2.0"+      , requestId = RequestIdNumber 1+      , requestMethod = method+      , requestParams = Just params+      }+  case response of+    Just (JsonRpcMessageResponse r) -> pure (toJSON r)+    other -> fail ("expected a response, got " ++ show other)++run :: Text -> Value -> IO Value+run = runWith testStateCodec anonymousContext++-- | Modern params with the given client capabilities.+withCaps :: Value -> [Pair] -> Value+withCaps caps extra = object $ extra +++  [ "_meta" .= object+      [ "io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)+      , "io.modelcontextprotocol/clientCapabilities" .= caps+      ]+  ]++formCaps, urlCaps, noCaps :: Value+formCaps = object ["elicitation" .= object ["form" .= object []]]+urlCaps = object ["elicitation" .= object ["url" .= object []]]+noCaps = object []++callParams :: Value -> Text -> [Pair] -> Value+callParams caps target extra = withCaps caps $+  [ "name" .= ("deploy" :: Text)+  , "arguments" .= object ["target" .= target]+  ] ++ extra++at :: [Key] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KM.lookup k o >>= at ks+at _ _ = Nothing++stateOf :: Value -> Text+stateOf v = case at ["result", "requestState"] v of+  Just (String s) -> s+  _               -> error ("no requestState in " ++ show v)++errorOf :: Value -> Maybe (Int, Text)+errorOf v = do+  Number code <- at ["error", "code"] v+  String msg <- at ["error", "message"] v+  pure (round code, msg)++accept :: Value+accept = object ["proceed" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]]]++-- | The first round, then the retry with the given answers and state.+retry :: Value -> Text -> [Pair] -> IO Value+retry caps target extra = run "tools/call" (callParams caps target extra)++spec :: Spec+spec = describe "Multi round-trip requests" $ do+  describe "The AEAD state codec" $ do+    let key kid n = fromMaybe (error "bad key") (stateKey kid (BS.replicate 32 n))+        keyA = key "a" 1+        keyB = key "b" 2++    it "opens what it sealed" $ do+      let codec = aeadStateCodec keyA []+      sealed <- sealState codec "hello"+      openState codec sealed `shouldReturn` Right "hello"++    it "uses a fresh nonce for every state" $ do+      let codec = aeadStateCodec keyA []+      s1 <- sealState codec "same"+      s2 <- sealState codec "same"+      s1 `shouldNotBe` s2++    it "rejects a state altered after sealing" $ do+      let codec = aeadStateCodec keyA []+      sealed <- sealState codec "hello"+      -- Change one base64 character well inside the payload+      let (prefix, rest) = T.splitAt (T.length (fst (T.breakOn "." sealed)) + 10) sealed+          swapped = if T.head rest == 'A' then 'B' else 'A'+          tampered = prefix <> T.cons swapped (T.tail rest)+      openState codec tampered `shouldReturn` Left StateInvalid++    it "reports a state sealed under a key it does not have" $ do+      sealed <- sealState (aeadStateCodec keyA []) "hello"+      openState (aeadStateCodec keyB []) sealed `shouldReturn` Left StateUnknownKey++    it "opens states sealed under a retired key during rotation" $ do+      sealed <- sealState (aeadStateCodec keyA []) "hello"+      openState (aeadStateCodec keyB [keyA]) sealed `shouldReturn` Right "hello"++    it "gives each ephemeral codec its own key" $ do+      c1 <- ephemeralStateCodec+      c2 <- ephemeralStateCodec+      sealed <- sealState c1 "hello"+      openState c1 sealed `shouldReturn` Right "hello"+      openState c2 sealed `shouldReturn` Left StateUnknownKey++    it "validates keys and key ids" $ do+      fmap stateKeyId (stateKey "k-1_x" (BS.replicate 32 0)) `shouldBe` Just "k-1_x"+      fmap stateKeyId (stateKey "k" (BS.replicate 31 0)) `shouldBe` Nothing+      fmap stateKeyId (stateKey "has.dot" (BS.replicate 32 0)) `shouldBe` Nothing+      fmap stateKeyId (stateKey "" (BS.replicate 32 0)) `shouldBe` Nothing++  describe "clientSupportsInput" $ do+    let modern caps = anonymousContext+          { clientProtocolVersion = Just "2026-07-28", clientCapabilities = Just caps }+        form = ElicitForm "?" confirmSchema+        url = ElicitUrl "?" (fromMaybe (error "bad URI") (parseURI "https://example.com"))+    it "requires a modern client" $+      clientSupportsInput anonymousContext { clientCapabilities = Just formCaps } form `shouldBe` False+    it "treats an empty elicitation capability as form only" $ do+      let ctx = modern (object ["elicitation" .= object []])+      clientSupportsInput ctx form `shouldBe` True+      clientSupportsInput ctx url `shouldBe` False+    it "checks each elicitation mode" $ do+      clientSupportsInput (modern urlCaps) url `shouldBe` True+      clientSupportsInput (modern urlCaps) form `shouldBe` False+    it "checks sampling and roots, and refuses other methods" $ do+      let ctx = modern (object ["sampling" .= object [], "roots" .= object []])+      clientSupportsInput ctx (RawInputRequest "sampling/createMessage" Null) `shouldBe` True+      clientSupportsInput ctx (RawInputRequest "roots/list" Null) `shouldBe` True+      clientSupportsInput ctx (RawInputRequest "tools/call" Null) `shouldBe` False+      clientSupportsInput (modern noCaps) (RawInputRequest "roots/list" Null) `shouldBe` False++  describe "The first round" $ do+    it "answers with an input_required result" $ do+      v <- run "tools/call" (callParams formCaps "prod" [])+      at ["result", "resultType"] v `shouldBe` Just (String "input_required")+      at ["result", "inputRequests", "proceed"] v `shouldBe` Just (object+        [ "method" .= ("elicitation/create" :: Text)+        , "params" .= object+            [ "mode" .= ("form" :: Text)+            , "message" .= ("Deploy prod?" :: Text)+            , "requestedSchema" .= confirmSchema+            ]+        ])+      stateOf v `shouldSatisfy` T.isPrefixOf "test."+      at ["result", "_meta", "io.modelcontextprotocol/serverInfo", "name"] v+        `shouldBe` Just (String "T")++    it "does not reveal the handler's state" $ do+      v <- run "tools/call" (callParams formCaps "prod" [])+      stateOf v `shouldNotSatisfy` T.isInfixOf "planned"++    it "sends URL-mode elicitation" $ do+      v <- run "tools/call" (withCaps urlCaps ["name" .= ("link" :: Text)])+      at ["result", "inputRequests", "login", "params"] v `shouldBe` Just (object+        [ "mode" .= ("url" :: Text)+        , "message" .= ("Sign in" :: Text)+        , "url" .= ("https://example.com/login" :: Text)+        ])++    it "omits cacheability fields from input_required results" $ do+      v <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)])+      at ["result", "resultType"] v `shouldBe` Just (String "input_required")+      at ["result", "ttlMs"] v `shouldBe` Nothing+      at ["result", "cacheScope"] v `shouldBe` Nothing++    it "works for prompts/get" $ do+      v <- run "prompts/get" (withCaps formCaps ["name" .= ("p" :: Text)])+      at ["result", "resultType"] v `shouldBe` Just (String "input_required")++  describe "The retry" $ do+    it "completes with the answers and the handler's own state" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first]+      at ["result", "resultType"] v `shouldBe` Just (String "complete")+      at ["result", "content"] v `shouldBe` Just (toJSON+        [ContentText "state=planned:prod answer=Just (Bool True)"])++    it "passes declined answers to the handler" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod"+        [ "inputResponses" .= object ["proceed" .= object ["action" .= ("decline" :: Text)]]+        , "requestState" .= stateOf first+        ]+      at ["result", "isError"] v `shouldBe` Just (Bool True)++    it "completes a resource read after asking" $ do+      first <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)])+      v <- run "resources/read" $ withCaps formCaps+        [ "uri" .= ("resource://x" :: Text)+        , "inputResponses" .= object ["q" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]]]+        , "requestState" .= stateOf first+        ]+      at ["result", "resultType"] v `shouldBe` Just (String "complete")+      at ["result", "ttlMs"] v `shouldSatisfy` (/= Nothing)++  describe "Rejected state" $ do+    it "rejects a state presented with different arguments" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "staging" ["inputResponses" .= accept, "requestState" .= stateOf first]+      errorOf v `shouldBe` Just (-32602, "Invalid requestState")++    it "rejects a state presented on another method" $ do+      first <- run "prompts/get" (withCaps formCaps ["name" .= ("p" :: Text)])+      v <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text), "requestState" .= stateOf first])+      errorOf v `shouldBe` Just (-32602, "Invalid requestState")++    it "rejects a state presented by another principal" $ do+      let alice = anonymousContext { clientPrincipal = Just (String "alice") }+          bob = anonymousContext { clientPrincipal = Just (String "bob") }+      first <- runWith testStateCodec alice "tools/call" (callParams formCaps "prod" [])+      v <- runWith testStateCodec bob "tools/call"+        (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first])+      errorOf v `shouldBe` Just (-32602, "Invalid requestState")+      ok <- runWith testStateCodec alice "tools/call"+        (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first])+      at ["result", "resultType"] ok `shouldBe` Just (String "complete")++    it "rejects an expired state" $ do+      let shortLived = testStateCodec { stateLifetime = -1 }+      first <- runWith shortLived anonymousContext "tools/call" (callParams formCaps "prod" [])+      v <- runWith shortLived anonymousContext "tools/call"+        (callParams formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first])+      fmap fst (errorOf v) `shouldBe` Just (-32602)+      fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "expired")++    it "explains a state from another instance" $ do+      other <- ephemeralStateCodec+      first <- runWith other anonymousContext "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod" ["inputResponses" .= accept, "requestState" .= stateOf first]+      fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "another server instance")++    it "rejects a state that is not a string" $ do+      v <- retry formCaps "prod" ["requestState" .= (42 :: Int)]+      fmap fst (errorOf v) `shouldBe` Just (-32602)++    it "rejects a malformed answer to an issued request" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod"+        ["inputResponses" .= object ["proceed" .= (1 :: Int)], "requestState" .= stateOf first]+      fmap fst (errorOf v) `shouldBe` Just (-32602)+      fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "proceed")++    it "rejects inputResponses that are not an object" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod" ["inputResponses" .= (1 :: Int), "requestState" .= stateOf first]+      fmap fst (errorOf v) `shouldBe` Just (-32602)++  describe "Answers the handler did not ask for" $ do+    it "ignores answers sent without a request state" $ do+      v <- retry formCaps "prod" ["inputResponses" .= accept]+      at ["result", "resultType"] v `shouldBe` Just (String "input_required")++    it "ignores keys the previous round did not issue" $ do+      first <- run "resources/read" (withCaps formCaps ["uri" .= ("resource://x" :: Text)])+      v <- run "resources/read" $ withCaps formCaps+        [ "uri" .= ("resource://x" :: Text)+        , "inputResponses" .= object ["sneaky" .= object ["action" .= ("accept" :: Text)]]+        , "requestState" .= stateOf first+        ]+      -- The handler saw no answers, so it asked again.+      at ["result", "resultType"] v `shouldBe` Just (String "input_required")++    it "ignores unknown keys whatever their value" $ do+      first <- run "tools/call" (callParams formCaps "prod" [])+      v <- retry formCaps "prod"+        [ "inputResponses" .= object+            [ "proceed" .= object ["action" .= ("accept" :: Text), "content" .= object ["ok" .= True]]+            , "extra" .= (42 :: Int)+            ]+        , "requestState" .= stateOf first+        ]+      at ["result", "resultType"] v `shouldBe` Just (String "complete")++  describe "Clients that cannot answer" $ do+    it "is a server error to ask a client without the capability" $ do+      v <- run "tools/call" (callParams noCaps "prod" [])+      fmap fst (errorOf v) `shouldBe` Just (-32603)+      fmap snd (errorOf v) `shouldSatisfy` maybe False (T.isInfixOf "proceed")++    it "is a server error to ask for a mode the client lacks" $ do+      v <- run "tools/call" (withCaps formCaps ["name" .= ("link" :: Text)])+      fmap fst (errorOf v) `shouldBe` Just (-32603)++    it "is a server error to ask a legacy client" $ do+      v <- run "tools/call" (object ["name" .= ("deploy" :: Text)])+      fmap fst (errorOf v) `shouldBe` Just (-32603)++    it "ignores round fields on legacy requests" $ do+      v <- run "tools/call" (object+        [ "name" .= ("deploy" :: Text)+        , "inputResponses" .= accept+        , "requestState" .= ("anything" :: Text)+        ])+      -- The handler saw no answers, so it asked, which legacy cannot carry.+      fmap fst (errorOf v) `shouldBe` Just (-32603)

@@ -18,6 +18,7 @@                                   wantsStreamingResponse) import qualified Network.Wai as Wai import Test.Hspec+import TestHelpers (testStateCodec)  testServerInfo :: McpServerInfo testServerInfo = McpServerInfo@@ -32,13 +33,13 @@ testHandlers = noHandlers   { tools = Just       ( \_ctx -> pure []-      , \ctx _name _args -> pure $ Right $ toToolResult+      , \ctx _name _args -> pure $ Right $ Complete $ toToolResult           ("version=" <> maybe "none" id (clientProtocolVersion ctx))       )   }  run :: JsonRpcMessage -> IO (Maybe JsonRpcMessage)-run = handleMcpMessage testServerInfo defaultCacheHints noNotificationSupport (\_ -> pure ()) testHandlers anonymousContext+run = handleMcpMessage testServerInfo defaultCacheHints testStateCodec noNotificationSupport (\_ -> pure ()) testHandlers anonymousContext  request :: Text -> Maybe Value -> JsonRpcMessage request method params = JsonRpcMessageRequest $ JsonRpcRequest

@@ -14,6 +14,7 @@ import MCP.Server.Handlers (handleMcpMessage) import MCP.Server.JsonRpc import Test.Hspec+import TestHelpers (testStateCodec)  progressServer :: McpServerHandlers progressServer = noHandlers@@ -23,11 +24,11 @@           "work" -> do             reportProgress ctx 0.2 (Just 1.0) (Just "starting")             reportProgress ctx 0.9 Nothing Nothing-            pure $ Right $ toToolResult ("done" :: Text)+            pure $ Right $ Complete $ toToolResult ("done" :: Text)           "chatty" -> do             logToClient ctx LogInfo (String "fyi")             logToClient ctx LogError (String "bad")-            pure $ Right $ toToolResult ("ok" :: Text)+            pure $ Right $ Complete $ toToolResult ("ok" :: Text)           _ -> pure $ Left $ UnknownTool name       )   }@@ -41,7 +42,7 @@       params = object $         ["name" .= tool, "arguments" .= object []]           ++ (if null metaFields then [] else ["_meta" .= object metaFields])-  resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints+  resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints testStateCodec     noNotificationSupport emit progressServer anonymousContext     (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params)))   notifications <- readIORef sink

@@ -13,6 +13,7 @@ import MCP.Server.JsonRpc import MCP.Server.Notifications import Test.Hspec+import TestHelpers (testStateCodec)  subId :: RequestId subId = RequestIdNumber 7@@ -119,7 +120,7 @@           }         run support method params = handleMcpMessage           (McpServerInfo "T" "1" "")-          defaultCacheHints+          defaultCacheHints testStateCodec           support           (\_ -> pure ())           toolsServer

@@ -15,6 +15,7 @@ import MCP.Server.Handlers (handleMcpMessage) import MCP.Server.JsonRpc import Test.Hspec+import TestHelpers (testStateCodec) import TestTypes  templResourceHandlers :: (ResourceListHandler, ResourceReadHandler)@@ -24,13 +25,13 @@ templTemplates = $(deriveResourceTemplatesWithDescription ''TemplResource   [("MemberProfile", "A member's profile"), ("OrderItem", "One item of an order")]) -readUri :: String -> IO (Either Error ResourceContent)+readUri :: String -> IO (Either Error (Outcome 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 :: Either Error (Outcome ResourceContent) -> Text -> Expectation+expectText (Right (Complete (ResourceText _ _ content))) expected = content `shouldBe` expected expectText other expected =   expectationFailure $ "Expected ResourceText '" ++ T.unpack expected ++ "' but got: " ++ show other @@ -51,7 +52,7 @@ runReq handlers method params =   handleMcpMessage     (McpServerInfo "T" "1" "")-    defaultCacheHints+    defaultCacheHints testStateCodec     noNotificationSupport     (\_ -> pure ())     handlers

@@ -3,7 +3,6 @@  module Spec.ToolCallParsing (spec) where -import Data.Aeson (Value (..)) import Data.Text (Text) import qualified Data.Text as T import MCP.Server@@ -15,15 +14,15 @@ allTypesHandlers :: (ToolListHandler, ToolCallHandler) allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool) -callTool :: Text -> [(Text, Text)] -> IO (Either Error ToolResult)+callTool :: Text -> [(Text, Text)] -> IO (Either Error (Outcome ToolResult)) callTool name args = snd allTypesHandlers anonCtx name (stringArgs args) -shouldBeRight :: IO (Either Error ToolResult) -> Text -> IO ()+shouldBeRight :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeRight action expected = do   result <- action   result `shouldBeTextResult` expected -shouldBeInvalidParams :: IO (Either Error ToolResult) -> Text -> IO ()+shouldBeInvalidParams :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeInvalidParams action expectedSubstring = do   result <- action   case result of@@ -31,7 +30,7 @@       T.isInfixOf expectedSubstring msg `shouldBe` True     other -> expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other -shouldBeMissingParams :: IO (Either Error ToolResult) -> Text -> IO ()+shouldBeMissingParams :: IO (Either Error (Outcome ToolResult)) -> Text -> IO () shouldBeMissingParams action expectedSubstring = do   result <- action   case result of

@@ -6,7 +6,7 @@ -- prompts. module Spec.TypedArgs (spec) where -import Data.Aeson (Value (..), object, toJSON, (.=))+import Data.Aeson (object, toJSON, (.=)) import Data.Text (Text) import qualified Data.Text as T import MCP.Server@@ -21,7 +21,7 @@ convHandlers :: (PromptListHandler, PromptGetHandler) convHandlers = $(derivePromptHandler ''ConvPrompt 'handleConvPrompt) -callTyped :: Text -> [(Text, Value)] -> IO (Either Error ToolResult)+callTyped :: Text -> [(Text, Value)] -> IO (Either Error (Outcome ToolResult)) callTyped name args = snd typedHandlers anonCtx name (valueArgs args)  toolNamed :: Text -> [ToolDefinition] -> ToolDefinition@@ -29,7 +29,7 @@   (d:_) -> d   []    -> error $ "tool not found: " ++ T.unpack n -expectInvalidParams :: Either Error ToolResult -> Text -> Expectation+expectInvalidParams :: Either Error (Outcome ToolResult) -> Text -> Expectation expectInvalidParams (Left (InvalidParams msg)) expectedSubstring =   msg `shouldSatisfy` T.isInfixOf expectedSubstring expectInvalidParams other expectedSubstring =@@ -113,7 +113,7 @@   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+      case completed result of         Right tr -> do           toolResultIsError tr `shouldBe` True           toolResultContent tr `shouldBe` [ContentText "boom"]@@ -128,7 +128,7 @@   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+      case completed result of         Right (PromptResult desc msgs) -> do           desc `shouldBe` Just "About haskell"           map promptMessageRole msgs `shouldBe` [RoleUser, RoleAssistant]

@@ -178,7 +178,7 @@        let promptGetHandler name args = case name of             "math_formula" -> case Map.lookup "formula" args of-              Just formula -> return $ Right $ toPromptResult $ ContentText $ "Formula: " <> formula <> " → √(solution)"+              Just formula -> return $ Right $ Complete $ toPromptResult $ ContentText $ "Formula: " <> formula <> " → √(solution)"               Nothing -> return $ Left $ MissingRequiredParams "formula"             _ -> return $ Left $ InvalidPromptName name @@ -191,7 +191,7 @@        let resourceReadHandler uri =             if show uri == "resource://unicode_symbols"-              then return $ Right $ ResourceText uri "text/plain" "Symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅"+              then return $ Right $ Complete $ ResourceText uri "text/plain" "Symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅"               else return $ Left $ ResourceNotFound $ T.pack $ show uri        let toolListHandler = return [@@ -203,7 +203,7 @@        let toolCallHandler name args = case name of             "calculate" -> case Map.lookup "expression" args of-              Just (String expr) -> return $ Right $ toToolResult $ ContentText $ "Result: " <> expr <> " → √answer"+              Just (String expr) -> return $ Right $ Complete $ toToolResult $ ContentText $ "Result: " <> expr <> " → √answer"               _ -> return $ Left $ MissingRequiredParams "expression"             _ -> return $ Left $ UnknownTool name @@ -228,7 +228,7 @@       -- Test actual Unicode handling       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 (PromptResult _ [PromptMessage _ (ContentText txt)]) -> txt `shouldSatisfy` T.isInfixOf "√"+        Right (Complete (PromptResult _ [PromptMessage _ (ContentText txt)])) -> txt `shouldSatisfy` T.isInfixOf "√"         _ -> expectationFailure "Expected successful prompt result"        uri <- case parseURI "resource://unicode_symbols" of@@ -236,12 +236,12 @@         Nothing -> fail "Invalid URI"       resourceResult <- snd (case resources handlers of Just h -> h; Nothing -> error "No resources") ctx uri       case resourceResult of-        Right (ResourceText _ _ txt) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"+        Right (Complete (ResourceText _ _ txt)) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"         _ -> expectationFailure "Expected successful resource result"        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+        Right (Complete tr) | [ContentText txt] <- toolResultContent tr -> do           txt `shouldSatisfy` T.isInfixOf "√"           txt `shouldSatisfy` T.isInfixOf "∫"         _ -> expectationFailure "Expected successful tool result"

@@ -7,9 +7,12 @@   , valueArgs   , promptArgsMap     -- * Result expectations+  , completed   , shouldBeTextResult   , shouldBeTextResultContaining   , shouldBePromptText+    -- * Request state+  , testStateCodec     -- * Schema access   , schemaTypeName   , schemaProps@@ -18,6 +21,7 @@   ) where  import           Data.Aeson (Value (..))+import qualified Data.ByteString as BS import qualified Data.Aeson.KeyMap as KM import           Data.Map   (Map) import qualified Data.Map   as Map@@ -39,17 +43,24 @@ promptArgsMap :: [(Text, Text)] -> Map Text Text promptArgsMap = Map.fromList +-- | A handler result that should be complete, with an unexpected request+-- for input turned into an error so that a @case@ on it stays exhaustive.+completed :: Either Error (Outcome a) -> Either Error a+completed (Right (Complete a))        = Right a+completed (Right (InputRequired _ _)) = Left (InternalError "unexpected request for input")+completed (Left err)                  = Left err+ -- | Expect a successful, non-error tool result with exactly one text block.-shouldBeTextResult :: Either Error ToolResult -> Text -> Expectation-shouldBeTextResult (Right tr) expected+shouldBeTextResult :: Either Error (Outcome ToolResult) -> Text -> Expectation+shouldBeTextResult (Right (Complete 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+shouldBeTextResultContaining :: Either Error (Outcome ToolResult) -> Text -> Expectation+shouldBeTextResultContaining (Right (Complete tr)) expected   | not (toolResultIsError tr)   , [ContentText content] <- toolResultContent tr =       content `shouldSatisfy` T.isInfixOf expected@@ -57,11 +68,18 @@   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 =+shouldBePromptText :: Either Error (Outcome PromptResult) -> Text -> Expectation+shouldBePromptText (Right (Complete (PromptResult _ [PromptMessage RoleUser (ContentText content)]))) expected =   content `shouldBe` expected shouldBePromptText other expected =   expectationFailure $ "Expected prompt text '" ++ T.unpack expected ++ "' but got: " ++ show other++-- | A request-state codec with a fixed key, so tests need no IO to build+-- one and can open what the server sealed.+testStateCodec :: StateCodec+testStateCodec = case stateKey "test" (BS.replicate 32 7) of+  Just key -> aeadStateCodec key []+  Nothing  -> error "testStateCodec: invalid key"  -- | The JSON Schema type keyword for a schema. schemaTypeName :: Schema -> Text

@@ -12,7 +12,9 @@ compared as **parsed JSON** (structural equality), not raw bytes, so object key order never matters — with one deliberate exception: JSON embedded *inside a string* (the structured-output text block) is compared as part of-the string, so those bytes are canonical: compact, object keys sorted.+the string, so those bytes are canonical: compact, object keys sorted. A+fixture string `"<opaque>"` matches any string: it stands for values a+server generates afresh, such as a sealed `requestState`.  The corpus is deliberately **API-agnostic**: nothing in it refers to this library's types or Haskell at all. Any MCP server implementation that@@ -55,6 +57,13 @@ | Completions | any ref/argument | values = `["alpha", "beta"]` filtered by prefix of the partial value | | Tool `echo_structured` | input schema: object, required `input` (string, "The text"); output schema: object, required `echoedText` (string, "The echoed text") and `echoedLength` (integer, "Its length"); description `Echo with structured output` | returns `structuredContent` `{"echoedText": <input>, "echoedLength": <length>}` plus one text content block containing the same JSON | | Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: <probe>` annotated with audience `["user"]`, priority `0.5` |++The `mrtr` handler set is the `base` set with one tool, which asks for+input (multi round-trip requests, 2026-07-28):++| Feature | Definition | Behavior |+|---|---|---|+| Tool `confirm` | not listed | without an answer under `proceed`: an `input_required` result asking, under the key `proceed`, for an `elicitation/create` form (message `Proceed?`, schema: object, required boolean `ok`), with a request state; with one: one text block `confirmed` |  Cases with `"notifications": true` are answered as if the transport can deliver change notifications (stdio with a configured notifier: legacy push

@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":43,"method":"tools/call","params":{"name":"confirm","arguments":{}}}

@@ -0,0 +1,1 @@+{"error":{"code":-32603,"message":"Internal error: the handler requested input, which the client's protocol revision does not support"},"id":43,"jsonrpc":"2.0"}

@@ -63,6 +63,11 @@       "notifications": false     },     {+      "name": "legacy/tools-call-input-required",+      "handlers": "mrtr",+      "notifications": false+    },+    {       "name": "legacy/tools-call-structured",       "handlers": "extended",       "notifications": false@@ -130,6 +135,21 @@     {       "name": "modern/tools-call-echo",       "handlers": "base",+      "notifications": false+    },+    {+      "name": "modern/tools-call-input-required",+      "handlers": "mrtr",+      "notifications": false+    },+    {+      "name": "modern/tools-call-input-unsupported",+      "handlers": "mrtr",+      "notifications": false+    },+    {+      "name": "modern/tools-call-invalid-request-state",+      "handlers": "mrtr",       "notifications": false     },     {

@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":40,"method":"tools/call","params":{"name":"confirm","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{"elicitation":{}}}}}

@@ -0,0 +1,1 @@+{"id":40,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"inputRequests":{"proceed":{"method":"elicitation/create","params":{"message":"Proceed?","mode":"form","requestedSchema":{"properties":{"ok":{"type":"boolean"}},"required":["ok"],"type":"object"}}}},"requestState":"<opaque>","resultType":"input_required"}}

@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":42,"method":"tools/call","params":{"name":"confirm","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}}

@@ -0,0 +1,1 @@+{"error":{"code":-32603,"message":"Internal error: the handler requested input the client cannot provide (proceed)"},"id":42,"jsonrpc":"2.0"}

@@ -0,0 +1,1 @@+{"jsonrpc":"2.0","id":41,"method":"tools/call","params":{"name":"confirm","arguments":{},"inputResponses":{"proceed":{"action":"accept","content":{"ok":true}}},"requestState":"test.not-a-sealed-state","_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{"elicitation":{}}}}}

@@ -0,0 +1,1 @@+{"error":{"code":-32602,"message":"Invalid requestState"},"id":41,"jsonrpc":"2.0"}