diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/examples/Ask/Main.hs b/examples/Ask/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Ask/Main.hs @@ -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 } }) + ]) + } diff --git a/examples/Ask/Types.hs b/examples/Ask/Types.hs new file mode 100644 --- /dev/null +++ b/examples/Ask/Types.hs @@ -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")]) diff --git a/examples/Complete/Types.hs b/examples/Complete/Types.hs --- a/examples/Complete/Types.hs +++ b/examples/Complete/Types.hs @@ -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 } diff --git a/examples/HttpSimple/Main.hs b/examples/HttpSimple/Main.hs --- a/examples/HttpSimple/Main.hs +++ b/examples/HttpSimple/Main.hs @@ -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 diff --git a/examples/Simple/Main.hs b/examples/Simple/Main.hs --- a/examples/Simple/Main.hs +++ b/examples/Simple/Main.hs @@ -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 diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.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, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -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 diff --git a/src/MCP/Server/Ask.hs b/src/MCP/Server/Ask.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Ask.hs @@ -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" diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -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' \@, whose typed values the derivation +-- returns @t'ToolOutput' \@, 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 diff --git a/src/MCP/Server/Derive/Internal.hs b/src/MCP/Server/Derive/Internal.hs --- a/src/MCP/Server/Derive/Internal.hs +++ b/src/MCP/Server/Derive/Internal.hs @@ -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)]] diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs --- a/src/MCP/Server/Handlers.hs +++ b/src/MCP/Server/Handlers.hs @@ -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 diff --git a/src/MCP/Server/Internal/InputRound.hs b/src/MCP/Server/Internal/InputRound.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Internal/InputRound.hs @@ -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 diff --git a/src/MCP/Server/Internal/Json.hs b/src/MCP/Server/Internal/Json.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Internal/Json.hs @@ -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 diff --git a/src/MCP/Server/JsonRpc.hs b/src/MCP/Server/JsonRpc.hs --- a/src/MCP/Server/JsonRpc.hs +++ b/src/MCP/Server/JsonRpc.hs @@ -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(..) diff --git a/src/MCP/Server/Notifications.hs b/src/MCP/Server/Notifications.hs --- a/src/MCP/Server/Notifications.hs +++ b/src/MCP/Server/Notifications.hs @@ -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: -- diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -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 diff --git a/src/MCP/Server/RequestState.hs b/src/MCP/Server/RequestState.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/RequestState.hs @@ -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: @.@. 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)) diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -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 diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -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)) diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -1,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 diff --git a/test/AskTypes.hs b/test/AskTypes.hs new file mode 100644 --- /dev/null +++ b/test/AskTypes.hs @@ -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" diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -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 diff --git a/test/Spec/AskMonad.hs b/test/Spec/AskMonad.hs new file mode 100644 --- /dev/null +++ b/test/Spec/AskMonad.hs @@ -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)") diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -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" diff --git a/test/Spec/Cancellation.hs b/test/Spec/Cancellation.hs --- a/test/Spec/Cancellation.hs +++ b/test/Spec/Cancellation.hs @@ -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 diff --git a/test/Spec/DerivedAsk.hs b/test/Spec/DerivedAsk.hs new file mode 100644 --- /dev/null +++ b/test/Spec/DerivedAsk.hs @@ -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" diff --git a/test/Spec/DerivedOutput.hs b/test/Spec/DerivedOutput.hs --- a/test/Spec/DerivedOutput.hs +++ b/test/Spec/DerivedOutput.hs @@ -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"] diff --git a/test/Spec/GoldenWire.hs b/test/Spec/GoldenWire.hs --- a/test/Spec/GoldenWire.hs +++ b/test/Spec/GoldenWire.hs @@ -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 @""@ 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 "") (String _) = String "" +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 diff --git a/test/Spec/HandlerExceptions.hs b/test/Spec/HandlerExceptions.hs --- a/test/Spec/HandlerExceptions.hs +++ b/test/Spec/HandlerExceptions.hs @@ -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))) diff --git a/test/Spec/HttpTransport.hs b/test/Spec/HttpTransport.hs --- a/test/Spec/HttpTransport.hs +++ b/test/Spec/HttpTransport.hs @@ -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 diff --git a/test/Spec/InputRequired.hs b/test/Spec/InputRequired.hs new file mode 100644 --- /dev/null +++ b/test/Spec/InputRequired.hs @@ -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) diff --git a/test/Spec/ModernEra.hs b/test/Spec/ModernEra.hs --- a/test/Spec/ModernEra.hs +++ b/test/Spec/ModernEra.hs @@ -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 diff --git a/test/Spec/Progress.hs b/test/Spec/Progress.hs --- a/test/Spec/Progress.hs +++ b/test/Spec/Progress.hs @@ -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 diff --git a/test/Spec/Subscriptions.hs b/test/Spec/Subscriptions.hs --- a/test/Spec/Subscriptions.hs +++ b/test/Spec/Subscriptions.hs @@ -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 diff --git a/test/Spec/TemplatesCompletions.hs b/test/Spec/TemplatesCompletions.hs --- a/test/Spec/TemplatesCompletions.hs +++ b/test/Spec/TemplatesCompletions.hs @@ -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 diff --git a/test/Spec/ToolCallParsing.hs b/test/Spec/ToolCallParsing.hs --- a/test/Spec/ToolCallParsing.hs +++ b/test/Spec/ToolCallParsing.hs @@ -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 diff --git a/test/Spec/TypedArgs.hs b/test/Spec/TypedArgs.hs --- a/test/Spec/TypedArgs.hs +++ b/test/Spec/TypedArgs.hs @@ -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] diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -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" diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs --- a/test/TestHelpers.hs +++ b/test/TestHelpers.hs @@ -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 diff --git a/test/golden/README.md b/test/golden/README.md --- a/test/golden/README.md +++ b/test/golden/README.md @@ -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 `""` 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": , "echoedLength": }` plus one text content block containing the same JSON | | Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: ` annotated with audience `["user"]`, priority `0.5` | + +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 diff --git a/test/golden/legacy/tools-call-input-required.request.json b/test/golden/legacy/tools-call-input-required.request.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-input-required.request.json @@ -0,0 +1,1 @@ +{"jsonrpc":"2.0","id":43,"method":"tools/call","params":{"name":"confirm","arguments":{}}} diff --git a/test/golden/legacy/tools-call-input-required.response.json b/test/golden/legacy/tools-call-input-required.response.json new file mode 100644 --- /dev/null +++ b/test/golden/legacy/tools-call-input-required.response.json @@ -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"} diff --git a/test/golden/manifest.json b/test/golden/manifest.json --- a/test/golden/manifest.json +++ b/test/golden/manifest.json @@ -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 }, { diff --git a/test/golden/modern/tools-call-input-required.request.json b/test/golden/modern/tools-call-input-required.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-required.request.json @@ -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":{}}}}} diff --git a/test/golden/modern/tools-call-input-required.response.json b/test/golden/modern/tools-call-input-required.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-required.response.json @@ -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":"","resultType":"input_required"}} diff --git a/test/golden/modern/tools-call-input-unsupported.request.json b/test/golden/modern/tools-call-input-unsupported.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-unsupported.request.json @@ -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":{}}}} diff --git a/test/golden/modern/tools-call-input-unsupported.response.json b/test/golden/modern/tools-call-input-unsupported.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-input-unsupported.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32603,"message":"Internal error: the handler requested input the client cannot provide (proceed)"},"id":42,"jsonrpc":"2.0"} diff --git a/test/golden/modern/tools-call-invalid-request-state.request.json b/test/golden/modern/tools-call-invalid-request-state.request.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-invalid-request-state.request.json @@ -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":{}}}}} diff --git a/test/golden/modern/tools-call-invalid-request-state.response.json b/test/golden/modern/tools-call-invalid-request-state.response.json new file mode 100644 --- /dev/null +++ b/test/golden/modern/tools-call-invalid-request-state.response.json @@ -0,0 +1,1 @@ +{"error":{"code":-32602,"message":"Invalid requestState"},"id":41,"jsonrpc":"2.0"}