diff --git a/.gitignore b/.gitignore index 5de0fe5..bb9bcf7 100644 --- a/.gitignore +++ b/.gitignore @@ -91,6 +91,10 @@ backup/ *.temp ~$* -# Claude Code specific - # Dependencies +node_modules/ +package-lock.json + +# Test and conformance output +tests/results/ +results/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..a76333f --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,379 @@ +# Changelog + +All notable changes to this project are documented in this file. The format +follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). + +## [Unreleased] + +### Added + +- Prompts: `MCPServer.Prompt.Base` (`IMCPPrompt`, `TMCPPromptBase`, + `TMCPPromptBase` with RTTI-derived arguments, `TMCPPromptMessages` for + text/image/audio/resource-link/embedded-resource content) and + `MCPServer.PromptsManager` (`prompts/list` with pagination and modern cache + hints, `prompts/get` with `-32602` for an unknown prompt or a missing + required argument). `MCPServer.Prompt.SummarizeLogs` (an example that + embeds `logs://recent` and offers level completion) and + `MCPServer.Prompt.ContentSamples` (`test_simple_prompt` and friends, the + conformance fixtures for prompts). +- Resource templates: `IMCPResourceTemplate`, `TMCPResourceTemplateBase` + (RFC 6570 level 1 and a level 2 subset, `{var}` and `{+var}`), + `TMCPRegistry.RegisterResourceTemplate`; `resources/templates/list` lists + them and `resources/read` resolves a URI against them when no exact + resource matches. `logs://{level}` (`MCPServer.Resource.Logs`) and + `test://template/{id}/data` (`MCPServer.Resource.Samples`, the conformance + fixture) are the examples. +- Completion: `MCPServer.CompletionManager` (`completion/complete` for + `ref/prompt` and `ref/resource`, capped at 100 values with `hasMore`), + `IMCPCompletable` and `TMCPCompletion`, implemented optionally by a prompt + or resource template; a target without it answers an empty `values` array. +- `MCPServer.Schema.Validator`: a JSON Schema 2020-12 subset validator (type, + enum, const, required, properties, items, additionalProperties, minimum, + maximum, minLength, maxLength, pattern, a same-document `$ref`, a depth + cap) used by `TMCPToolBase`'s own argument validation and, in DEBUG builds, + to warn when a tool's `structuredContent` does not match its + `outputSchema`. +- Schema attributes `SchemaMinLength`, `SchemaMaxLength`, `SchemaPattern`, + `SchemaDefault`, `SchemaName` (overrides the wire name, honoured by the + serializer too) and the class-level `SchemaAdditionalProperties` and + `SchemaDialect` (root schema only). +- `json_schema_2020_12_tool`: a hand-written schema exercising `$schema`, + `$defs`, `$anchor`, `$ref`, `allOf`/`anyOf` and `if`/`then`/`else`, the + conformance fixture for schema-keyword preservation. +- `MCPServer.ContentBlocks`: the text/image/audio/resource-link/embedded- + resource block builders shared by `TMCPToolResult` and + `TMCPPromptMessages`, so both produce byte-identical content blocks. +- Rewritten stdio transport (`MCPServer.StdioTransport`, `MCPServer.StdioChannel`): + UTF-8 byte framing on the standard handles instead of Text I/O (`é` and + other non-ASCII input used to come back mangled), a reader thread that + answers notifications, client responses and legacy `ping` inline, and + `[Server] MaxConcurrentRequests` (default 1) worker threads for everything + else, so responses keep arriving in request order by default. +- `notifications/cancelled` over stdio: the named request stops and gets no + response (`IMCPRequestContext.IsCancelled`, `CheckCancelled`, `Cancel`, + `IMCPRequestTracker`). `_meta.progressToken` on a request gets + `notifications/progress` before its response + (`IMCPRequestContext.ReportProgress`, monotonic and throttled to one every + 50 ms except the notification that reaches the total). + `test_tool_with_progress` (`MCPServer.Tool.ContentSamples`) exercises both. +- On EOF, stdin closing drains in-flight work for `ShutdownDrainMs` (2 s + default) before cancelling what is left; the process no longer waits on a + request that never finishes. +- A stdio server never writes `settings.ini` next to the executable; the + Windows console-control handler and the POSIX `SIGINT`/`SIGTERM` handlers, + and the debug memory-leak report, are skipped in stdio mode. +- Streamable HTTP for both eras in `MCPServer.IdHTTPServer`: the processor's + HTTP status is answered (400 for modern protocol errors, 404 for an unknown + method in the modern era, 200 for every legacy JSON-RPC error); `Mcp-Method` + and `Mcp-Name` are validated against the body for modern requests + (`MCPServer.HttpHeaders`: strict Base64 sentinel decoding, Accept parsing, + Origin policy, JSON depth scanner); every 4xx carries a JSON-RPC error body. +- `settings.ini`: `[Server] BindAddress`, `EndpointInfoPath`, + `MaxRequestBodyBytes`, `MaxJsonDepth`, `MaxConnections`; + `[Security] AllowedOrigins`. +- `TMCPIdHTTPServer.BoundAddresses`; a `Port` of 0 lets the system choose. +- `TLogger.RedactJson`; request and response bodies are logged at Debug level + with `_meta`, `requestState`, `inputResponses` and token-like members + redacted. +- `MIGRATION.md` with the behaviour changes and how to configure them. +- In-process HTTP transport tests (`TIdHTTP` against an ephemeral port) and + header tests; HTTP golden cases for the modern requests. + +- MCP 2026-07-28 at the JSON-RPC layer, on both transports, next to the + initialize-based revisions 2025-06-18 and 2025-11-25. The era is decided per + request in `TMCPJsonRpcProcessor.BuildRequestContext`: `initialize` is always + legacy, a `params._meta` with `io.modelcontextprotocol/protocolVersion` is + modern, everything else is legacy. +- `server/discover` (`MCPServer.CoreManager`): supported versions, + capabilities, `_meta.serverInfo`, optional `instructions`, `ttlMs` and + `cacheScope: "public"`. +- Modern requests: `_meta` validation (`clientCapabilities` required, + `logLevel` checked, `-32602`), `-32022` with `data.supported` and + `data.requested` for an unknown revision, `-32020` when the HTTP header and + the body disagree, `-32601` for the legacy-only methods `ping`, + `logging/setLevel`, `resources/subscribe` and `resources/unsubscribe`. +- Modern results carry `resultType: "complete"`, + `_meta.io.modelcontextprotocol/serverInfo` and, for the cacheable methods, + `ttlMs` and `cacheScope` when the handler did not set them. +- `MCPServer.Errors` (`EMCPError` with code, data and HTTP status, plus + factories), `MCPServer.RequestContext` (`IMCPRequestContext`, thread-local + `TMCPRequestContext.Current`, `TMCPTransportHints`), `MCPServer.Capabilities` + (`TMCPCapabilityBuilder` derives the capabilities from the registered + managers), and the interfaces `IMCPCapabilityManagerEx`, + `IMCPCapabilityProvider`, `IMCPManagerEnumerator` and `IMCPRegistryAware` in + `MCPServer.Types`. +- `TMCPJsonRpcProcessor.ProcessRequestEx` returns body, HTTP status and era; + `Create(Registry, Settings)` overload; `TMCPStdioTransport.Settings`. +- `settings.ini`: `[Server] Title`, `Description`, `WebsiteUrl`, + `Instructions`; `[Protocol] LenientModernPing`, + `DiscoverListsLegacyVersions`, `DiscoverTtlMs`. +- DUnitX test project `tests\MCPServerTests.dpr` (Win32 and Win64) with an + in-process harness that builds the same registry as `MCPServer.dpr` and + drives the JSON-RPC processor; era-detection, processor, capability-builder + and concurrency tests. +- Golden files that pin the wire behaviour: JSON-RPC cases for the legacy and + the modern era in `tests\golden\legacy` and `tests\golden\modern`, and HTTP + transport cases (status line, headers, body) in `tests\golden\http`. +- `build-tests.bat` and `scripts\run-tests.ps1` (build and run, `-Record` + to re-record goldens), `scripts\capture-http-goldens.ps1`. +- `scripts\run-conformance.ps1` for the official conformance CLI with one + expected-failures baseline per requirement set + (`conformance-baseline-2026-07-28.yml`, `conformance-baseline-2025-11-25.yml`), + `scripts\run-inspector-smoke.ps1` with `ci-servers.json` (legacy, auto and + modern eras plus stdio) and `scripts\run-stdio-smoke.ps1`. +- `package.json` pinning the Node tooling (`@modelcontextprotocol/conformance` + 0.2.0-alpha.11, `@modelcontextprotocol/inspector` 2.5.0). +- Protocol constants in `MCPServer.Types`: revision names and sets + (`MCP_PROTOCOL_VERSION_*`, `MCP_LATEST_PROTOCOL_VERSION`, + `MCP_LEGACY_PROTOCOL_VERSIONS`, `MCP_MODERN_PROTOCOL_VERSIONS`), the MCP + error codes `MCP_ERROR_HEADER_MISMATCH` (-32020), + `MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY` (-32021), + `MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION` (-32022) and + `MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY` (-32002), the reserved `_meta` keys + (`MCP_META_*`) and `MCP_CACHEABLE_METHODS`. +- `TLogger.StdoutReserved`: while set, console logging always goes to stderr + and `UseStdErr := False` is refused with a one-time warning. +- README sections "Protocol Versions and Dual-Era Behaviour", the library + checklist and "Automated tests". +- `TMCPToolResult` (`MCPServer.Tool.Result`): a builder for tool results with + text, image, audio, embedded resource and resource link content blocks, + `structuredContent`, `_meta`, per-block annotations and `isError`; + `EncodeBase64Blob` encodes without line breaks. +- `TMCPToolBase.ExecuteWithContext(Params, Context)` returning a `TValue` + (a string, a `TMCPToolResult`, a `TJSONObject` for structured content or a + ready-made `TJSONArray` of content blocks) next to `ExecuteWithParams`; + `EMCPToolError` for a failure the tool wants reported as an `isError` result. +- Tool metadata through `IMCPToolMetadata` (`annotations`, `icons`) on every + tool base; resource metadata through `IMCPResourceMetadata` (`title`, `size`, + `annotations`), `IMCPBinaryResource` (`blob` contents) and + `IMCPCacheableResource` (`ttlMs`, `cacheScope`) on `TMCPResourceBase`. +- `TMCPToolsManager` and `TMCPResourcesManager`: `AddTool` / `AddResource` + for instances outside `TMCPRegistry`, `ListTtlMs` and `ListCacheScope` for + the modern list results. +- Schema attributes `SchemaTitle`, `SchemaFormat`, `SchemaMinimum` and + `SchemaMaximum`. +- Example tools `test_simple_text`, `test_image_content`, `test_audio_content`, + `test_embedded_resource`, `test_multiple_content_types` and + `test_error_handling` (`MCPServer.Tool.ContentSamples`) and the resources + `test://static-text` and `test://static-binary` + (`MCPServer.Resource.Samples`): one example per content type, and the + fixtures the conformance suite calls. +- `EMCPError.UnknownTool` and `EMCPError.ResourceNotFound(Uri, Era)`; + `MCP_CACHE_SCOPE_PUBLIC` and `MCP_CACHE_SCOPE_PRIVATE`. +- Tests for the tool result builder, the serializer, the schema generator and + the tools and resources managers in both eras. +- Multi round-trip requests (MCP 2026-07-28): `EMCPInputRequired`, + `TMCPInputRequests` and `TMCPInputResponse` in `MCPServer.Mrtr`; the + processor answers `tools/call`, `resources/read` and `prompts/get` with an + `InputRequiredResult` (`resultType: input_required`, `inputRequests`, + `requestState`), validates `inputResponses` on the retry (`-32602` when + not an object of objects), only sends input requests the client declared + a capability for (`-32021` otherwise) and answers `-32603` to legacy + clients. `IMCPRequestContext` gains `InputResponses`, `RequestState` and + `TryGetInputResponse`. +- `TMCPRequestStateSealer` (`MCPServer.RequestState`): HMAC-SHA256 sealed + `requestState` tokens bound to the method, a digest of the request + parameters, the principal and an expiry; `[Security] RequestStateKey` and + `RequestStateTtlSeconds` in `settings.ini`. +- Streaming HTTP responses (`MCPServer.HttpStream`): when a request accepts + `text/event-stream` and its handler sends a notification, the response is a + chunked SSE stream (`X-Accel-Buffering: no`) with the notifications before + the final JSON-RPC response; a client that disconnects cancels the request. + `notifications/progress` therefore reaches HTTP clients in both eras. +- `IMCPRequestContext.Log` and `LogJson`: `notifications/message` on the + request's own stream, only when the request carries + `_meta.io.modelcontextprotocol/logLevel` and the level is at or above it; + `TMCPLogLevel` and `MCP_LOG_LEVELS` in `MCPServer.Types`. +- `[Security] AllowedHosts` (`TMCPHostPolicy`): `Host` header allow-list, + `403` for other hosts; `[Server] ExposeDiagnosticsResources` to keep + `logs://recent`, `logs://{level}` and `server://status` off a server that + strangers can reach; `TMCPResourcesManager.RemoveResourceTemplate`. +- Authentication (`MCPServer.Authorization`): `IMCPAuthorizer` on + `TMCPIdHTTPServer.Authorizer`, `TMCPStaticBearerAuthorizer` (constant-time + comparison), the abstract `TMCPOAuthResourceServerAuthorizer` (mandatory + audience and expiry checks, `RequiredScopes`) and + `TMCPIntrospectionAuthorizer` (RFC 7662). `401`/`403`/`400` with + `WWW-Authenticate: Bearer` challenges (`resource_metadata`, `error`, + `scope`), the RFC 9728 protected resource metadata document at + `/.well-known/oauth-protected-resource[]`, `[RequiresScope]` on + tool classes, `Principal`, `Scopes` and `HasScope` on the request context, + and `[Auth] BearerTokens`, `AuthorizationServers`, `ResourceUri` and + `ScopesSupported` in `settings.ini`. The stdio transport never + authenticates. +- `subscriptions/listen` (`MCPServer.SubscriptionsManager`): long-lived + change notification streams with the acknowledgement first, the honoured + filter, `_meta.io.modelcontextprotocol/subscriptionId` on every message, + SSE keep-alive comments over HTTP, a dedicated thread over stdio, + cancellation by closing the stream or `notifications/cancelled`, and a + completion response when the server closes the subscription. + `IMCPSubscriptionHub` and `IMCPKeepAlive` in `MCPServer.Types`. +- `ChangeNotifier` on `TMCPToolsManager`, `TMCPPromptsManager` and + `TMCPResourcesManager`: with a hub assigned the modern capabilities announce + `listChanged` and `resources.subscribe`, and `AddTool`, `RemoveTool`, + `AddPrompt`, `RemovePrompt`, `AddResource`, `RemoveResource`, + `AddResourceTemplate` and `ResourceUpdated` notify the subscribed clients. + `HasTool` and `HasPrompt`. The managers' lists are lock-guarded. +- Example tools `test_trigger_tool_change`, `test_trigger_prompt_change` and + `test_trigger_resource_change` (`MCPServer.Tool.SubscriptionSamples`), the + diagnostic hooks of the conformance suite's subscription checks. +- Example tools `test_logging_tool` (`MCPServer.Tool.ContentSamples`) and + `test_streaming_elicitation` (`MCPServer.Tool.InputRequiredSamples`), the + diagnostic tools of the conformance suite's stateless scenario. +- Example tools `test_input_required_result_elicitation`, `_sampling`, + `_list_roots`, `_request_state`, `_multiple_inputs`, `_multi_round`, + `_tampered_state`, `_capabilities` and `test_missing_capability` + (`MCPServer.Tool.InputRequiredSamples`) and the prompt + `test_input_required_result_prompt`: the multi round-trip fixtures of the + conformance suite. + +### Changed + +- `TMCPToolBase` (the non-generic, hand-written-schema base) now validates + its arguments against `BuildSchema` before calling the tool: the abstract + method a descendant overrides is `DoExecute`, not `Execute`, which is now + a concrete template method. Tools deriving from `TMCPToolBase` previously + got no argument validation at all; `TMCPToolBase` and + `TMCPToolBase` are unaffected (their arguments already go through + `TMCPSerializer`). +- The property name a tool or prompt parameter class publishes on the wire + is looked up the same way in both directions: `TMCPSerializer` honours + `[SchemaName]` for deserializing and serializing, not only the schema + generator. +- Non-ASCII input over stdio is decoded and echoed back unchanged; Text I/O + decoded stdin with the console code page, corrupting characters outside it + (a Windows console defaults to an ANSI code page, not UTF-8). +- A duplicate request id on stdio while the first is still in flight is + `-32600`, answered at once, instead of being queued behind it. +- `settings.ini`: `[Server] MaxConcurrentRequests` (default 1). +- The server binds to loopback (`127.0.0.1` and `::1`) when `Host` is + `localhost`; it listened on every interface. A non-loopback `Host` or an + explicit `BindAddress` binds elsewhere. +- The `Origin` header is validated on every request, also with CORS disabled + (it was only checked when CORS was on): loopback origins on any port pass, + other origins must be in `[Security] AllowedOrigins` or `[CORS] + AllowedOrigins`, `null` is refused; a rejected origin gets `403` with a + JSON-RPC error body and `Vary: Origin`. +- GET and DELETE on the MCP endpoint answer `405` with `Allow: POST, OPTIONS` + (GET answered an endpoint document or an immediately closed stream); + OPTIONS answers `204`; an unknown path `404` without a body. +- Notifications and client responses get `202` with an empty body instead of + Indy's HTML body; SSE responses lose the `id:` line and the duplicate + `Connection` header; the CORS headers list `POST, OPTIONS`, the modern + request headers and `WWW-Authenticate`, and reflect a preflight's + `Access-Control-Request-Headers`. +- A legacy request whose `MCP-Protocol-Version` header names an unknown + revision gets `400` (it got `200`). +- TLS 1.0 and 1.1 are no longer offered on the OpenSSL 1.0.2 handler. +- `USE_TAURUS_TLS` is defined in `src\MCPServer.inc`; the build scripts pass + `-Isrc`. The test program is `tests\MCPServerTests.dpr`. +- An `initialize` request that carries modern `_meta` is a modern request and + therefore an unknown method (`-32601`, HTTP 404), as a modern client probing + the server expects; only an `initialize` without modern `_meta` is legacy. +- `initialize` answers the requested revision when it is `2025-06-18` or + `2025-11-25`, otherwise `2025-11-25` (it always answered `2025-06-18`). The + result no longer contains the non-standard `sessionId` and the + `tools.supportsProgress` / `tools.supportsCancellation` keys; + `tools.listChanged: false` is added. No `Mcp-Session-Id` header is minted; + `TMCPCoreManager.SessionID` returns an empty string. +- Message-shape errors use the JSON-RPC codes: `-32600` for batch arrays, + `id: null`, a missing or non-string `method` and a missing `jsonrpc` + (batch arrays were `-32700`, `id: null` was treated as a notification and + a missing `jsonrpc` was accepted); `-32602` for a `params` that is not an + object. Client responses (`result` or `error` without `method`) are ignored. +- The `initialize` capabilities come from the registered managers + (`IMCPCapabilityProvider`); a registry with only a tools manager no longer + advertises resources. +- The `JSONRPC_*` error-code constants are defined once in `MCPServer.Types`. + `MCPServer.JsonRpcProcessor` keeps them as aliases, so existing consumer + code compiles unchanged; the unused duplicate block in + `MCPServer.IdHTTPServer` is gone. +- `TMCPRegistry` creates its dictionaries in a class constructor. Registration + must complete before the managers are created (before + `TMCPIdHTTPServer.Start` or `TMCPStdioTransport.Run`); this was already the + case and is now documented, also for `TServerStatusResource.SetNamePrefix`. +- `TMCPStdioTransport.Create` forces `TLogger.UseStdErr := True` and sets + `TLogger.StdoutReserved`. Library consumers that create the transport with + console logging enabled and never set `UseStdErr` now get their log lines on + stderr instead of corrupting the MCP channel on stdout. +- `tools/call` with an unknown tool answers `-32602` with `data.name` (it + answered an `isError` result "Tool not found"); a missing or empty `name` + and an `arguments` that is not an object are `-32602` as well (they were an + `isError` result "Invalid tool parameters"). +- `resources/read` for an unknown URI answers `-32002` with `data.uri` for + initialize-based clients and `-32602` with `data.uri` for modern clients (it + answered a text content "Error: Resource not found"); a missing `uri` is + `-32602`, a read that raises is `-32603`. +- Tool arguments are checked against the schema before the tool runs: a + missing required parameter, a value of the wrong JSON type, a fraction for an + integer or an unknown enumeration name is an `isError` result that names the + parameter. Missing parameters were silently defaulted and wrong types + coerced. +- Every `tools/call` result has a `content` array; a typed result + (`TMCPToolBase`) gets a text block with the compact JSON next to + `structuredContent`, so clients without structured-content support see it. +- Tools and resources are listed in registration order (they were listed in + dictionary order). +- Generated schemas: integer properties are `integer` (they were `number`), + `TDateTime` is a `string` with `format: date-time`, enumerations, sets, + dynamic arrays, `TList` and nested classes get typed schemas, and a tool + without parameters gets `additionalProperties: false`. +- Serialisation of results and resource data: enumerations by name (they were + written as booleans), sets and dynamic arrays as arrays, `nil` objects as + `null`, `TDateTime` as an ISO 8601 string (the `logs://recent` timestamps and + the `server://status` times were floating-point day numbers). +- `resources/list` carries `title`, `size` and `annotations` when the resource + provides them and omits an empty `description` or `mimeType`. Modern + `tools/list`, `resources/list`, `resources/templates/list` and + `resources/read` results carry `ttlMs` and `cacheScope` from the manager or + the resource. +- `logs://recent` no longer writes an access-log entry on every read; + `project://info` reports `MCP 2026-07-28 (initialize-based: 2025-11-25, + 2025-06-18)` and is cacheable for an hour (`cacheScope: public`). + +### Fixed + +- `TServerStatusResource` request and connection counters and the SSE event-id + counter are updated atomically; they were plain increments shared by all + Indy connection threads. +- `logs://recent` answered "Error reading resource: Invalid pointer operation": + the copied log entries were owned by two lists and freed twice. +- `TMCPSerializer` serialised `TList` and `TObjectList` properties as an + object with `count` and `capacity` members. They are JSON arrays now, so + `project://info` lists its features and `logs://recent` its entries. +- `server://status` was declared but never registered by the executable; the + unit registers it by default now, and `SetNamePrefix` replaces that + registration instead of adding a second URI (`TMCPRegistry.UnregisterResource` + is new). +- `resources/read` without `params` raised an access violation (returned as + `-32603`); it is now handled like a missing `uri`. +- `tools/call` without `arguments` raised an access violation inside the tool + (returned as an `isError` result); the tool now receives an empty object. +- The result object of a `TMCPToolBase` tool was cloned into + `structuredContent` and never freed; every call leaked it. +- Enumeration properties of a result were serialised as booleans. +- Resource templates compiled their pattern into one shared `TRegEx` and + matched on it from every Indy thread at once; matching is thread-safe now. + Template variables are percent-decoded only: a `+` in a URI stays a `+`. +- The stdio worker threads could still be running when the transport was + freed after the drain timeout; the transport now leaves the shared objects + in place for them instead of freeing them under a running thread. +- The stdio line reader read a line longer than the limit into memory before + rejecting it; it now discards such a line chunk by chunk up to its newline. +- `TMCPLegacySession` was read and written by several threads without a + lock. +- Origin allow-list entries without a port did not match an `Origin` header + that spelled out the default port (`https://app.example:443`), and the + other way round. +- `jsonrpc`, `method`, `protocolVersion`, `MCP-Name` and the cancel `reason` + were accepted when they were numbers, because `TJSONNumber` descends from + `TJSONString`; `IsJsonString` in `MCPServer.Types` tells them apart. +- `completion/complete` for an unknown `ref/resource` answers `-32002` to a + legacy client (`-32602` stays for a modern one). +- `TMCPCompletionManager` did not hold a reference to the prompts and + resources managers it was given as interfaces. +- The `/info` endpoint listed the protocol versions in a fixed string; it + now derives them from the supported version lists, newest first. +- An invalid JSON literal in a `[SchemaDefault]` attribute raises + `EArgumentException` instead of being silently dropped. +- A tool result that fails to serialise no longer leaks the partial JSON + object; the DEBUG `outputSchema` check no longer leaks the schema. diff --git a/MIGRATION.md b/MIGRATION.md new file mode 100644 index 0000000..d29fda1 --- /dev/null +++ b/MIGRATION.md @@ -0,0 +1,242 @@ +# Migration notes + +Behaviour changes that can affect an existing deployment or a project that +uses this repository as a library, with what to do about them. Everything +else in the CHANGELOG is additive. + +## HTTP transport + +**The server binds to loopback when `Host` is `localhost`.** It used to listen +on every interface. A server that must be reachable from other machines needs +either a `Host` that is not loopback (then it listens on every interface) or an +explicit `[Server] BindAddress`, for example `BindAddress=0.0.0.0`. + +**The `Origin` header is validated on every request**, also when CORS is +disabled. Loopback origins (`localhost`, `127.0.0.1`, `[::1]`, any port) always +pass; other origins must be listed in `[Security] AllowedOrigins` or, when that +is empty, in `[CORS] AllowedOrigins`. A rejected origin gets `403` with a +JSON-RPC error body. Browser front-ends on another host must be added to the +list (`https://app.example` or `https://app.example:*`). + +**GET and DELETE on the MCP endpoint answer `405`.** The old GET answered a +small JSON document with the endpoint URL; configure `[Server] EndpointInfoPath` +(for example `/info`) to keep such a document on a path of its own. + +**Notifications get `202` with an empty body**, no longer an HTML body. + +**Modern requests (MCP 2026-07-28) get real HTTP status codes**: `400` for +malformed `_meta`, an unsupported protocol version or a header that does not +match the body, `404` for an unknown method. Requests from `initialize`-based +clients keep `200` for every JSON-RPC error, except a `400` for an +`MCP-Protocol-Version` header naming an unknown revision. + +**Modern POSTs must carry `Mcp-Method`** and, for `tools/call`, +`resources/read` and `prompts/get`, **`Mcp-Name`** (Base64 sentinel encoding +accepted). A missing or different header is `400` with error `-32020`. + +**Request limits**: bodies above `[Server] MaxRequestBodyBytes` (4 MB) get +`413`, JSON nested deeper than `[Server] MaxJsonDepth` (64) gets `400`. + +**No `Mcp-Session-Id` is minted.** The `initialize` result no longer carries a +`sessionId`; an `Mcp-Session-Id` a legacy client sends is echoed back. + +**SSE responses have no `id:` lines** and no duplicate `Connection` header. + +**Responses stream when a tool sends notifications.** A request that accepts +`text/event-stream` and whose tool reports progress or logs (see +`IMCPRequestContext.ReportProgress` and `Log`) is answered with a chunked SSE +stream: the notifications first, the JSON-RPC response as the last event. +Such a stream is `200` even when the request ends in a JSON-RPC error, +because the status line has already been sent. Requests that send no +notification, and requests without `text/event-stream` in `Accept`, are +answered as before (single JSON object, or one SSE event, with a +`Content-Length`). Closing the stream cancels the request. + +**TLS 1.0 and 1.1 are disabled** on the OpenSSL 1.0.2 handler (the build +without `USE_TAURUS_TLS`). + +**Request and response bodies are logged at Debug level**, with `_meta`, +`requestState`, `inputResponses` and token-like members redacted. Lower +`TLogger.MinLogLevel` to see them. + +## Tools and resources + +**An unknown tool is a JSON-RPC error.** `tools/call` with a name that is not +registered answers `-32602` with `data.name`; it used to answer an `isError` +result with the text "Tool not found". A missing or empty `name`, or an +`arguments` that is not an object, is `-32602` too. Modern clients get HTTP +`400` with it, initialize-based clients `200`. + +**An unknown resource is a JSON-RPC error.** `resources/read` answers `-32002` +with `data.uri` for initialize-based clients and `-32602` with `data.uri` for +modern clients; it used to answer a text content "Error: Resource not found". +A read that raises is `-32603`. + +**Arguments are checked against the schema.** A missing required parameter, a +wrong JSON type (a string for a number, a fraction for an integer, a string +for a boolean) or an unknown enumeration name is an `isError` result naming +the parameter, before the tool runs. A parameter that may be absent needs the +`[Optional]` attribute; without it the old behaviour (silently defaulting) +is gone. `null` counts as absent. + +**Generated schemas changed.** Integer properties are `integer` (they were +`number`), `TDateTime` is a `string` with `format: date-time`, enumerations +and sets list their names, and a tool without parameters declares +`additionalProperties: false`. Clients that validate arguments against the +schema now reject `1.5` for an integer. + +**Result and resource JSON changed.** Enumerations are written by name (they +were booleans), sets and dynamic arrays as arrays, `nil` objects as `null` +and `TDateTime` as an ISO 8601 string. The `logs://recent` timestamps and the +`server://status` times are strings now. + +**Tools and resources are listed in registration order.** Anything that +depended on the previous dictionary order should use the names instead. + +**A typed tool result also gets a text block.** `TMCPToolBase` results +carry `structuredContent` and a text block with the same JSON; `content` is +never empty. + +## stdio transport + +**Non-ASCII input is no longer mangled.** stdin and stdout are read and +written as UTF-8 byte streams now instead of Text I/O; a message with `é` or +an emoji comes back unchanged. A client that worked around the old mangling +should remove that workaround. + +**Requests are answered one at a time by default, still in arrival order.** +Set `[Server] MaxConcurrentRequests` above 1 for a client that issues several +requests before waiting for a reply and wants them handled in parallel. + +**`notifications/cancelled` now does something.** Sending it for a request +still in flight stops that request and it gets no response, matching the +specification; previously the notification was accepted but ignored. + +**A request with `_meta.progressToken` gets `notifications/progress`** from +tools that report progress (`test_tool_with_progress` is the example); this +is new traffic on stdout a client that does not expect it should tolerate, +since it was already required by the specification. + +**The server exits promptly when stdin closes**, even with a request still +running: it waits `[Server] MaxConcurrentRequests`-many workers up to 2 +seconds (configurable via `TMCPStdioTransport.ShutdownDrainMs` for a library +consumer), then cancels what is left rather than blocking forever. + +**A duplicate request id while the first is still in flight is `-32600`**, +answered immediately, instead of being silently queued behind it. + +## Prompts, resource templates and completion + +**New capabilities, off unless you register the managers.** A registry that +never registers `TMCPPromptsManager` or `TMCPCompletionManager` behaves +exactly as before; the built-in `MCPServer.dpr`/stdio server registers both, +so the shipped executable now advertises `prompts` and `completions` and +answers `prompts/list`, `prompts/get`, `resources/templates/list` (with real +entries instead of an empty array) and `completion/complete`. + +**A hand-written tool (`TMCPToolBase`) now validates its arguments.** +Override `DoExecute` instead of `Execute`; the base class validates +`Arguments` against `BuildSchema` first and raises `EArgumentException` (an +`isError` result) on a mismatch. `TMCPToolBase` and `TMCPToolBase` +tools are unaffected. + +## Multi round-trip requests + +**Server-initiated requests are replaced by `InputRequiredResult`.** A tool, +resource or prompt that needs something from the client (`elicitation/create`, +`sampling/createMessage`, `roots/list`) raises `EMCPInputRequired` +(`MCPServer.Mrtr`) with the input requests and optional state; the modern +client retries with `inputResponses` and `requestState`, which the request +context exposes as `InputResponses`, `TryGetInputResponse` and +`RequestState`. Nothing changes for tools that never ask the client for +input. A legacy client (2025-06-18, 2025-11-25) gets `-32603` from such a +request, because those revisions delivered the same thing as server-to-client +requests that this server does not send. + +**`requestState` is signed.** Set `[Security] RequestStateKey` when more than +one instance serves the same clients or when tokens must survive a restart; +without it every process signs with its own random key and logs a warning +at startup. `RequestStateTtlSeconds` bounds the replay window (600 s). + +**Two new settings keys** (`RequestStateKey`, `RequestStateTtlSeconds`) and +nine new example tools plus one example prompt ship with the executable; +they are only registered when their units are in the project. + +## Host allow-list and diagnostics resources + +**`[Security] AllowedHosts` is empty by default**, so nothing changes until it +is set; then a request whose `Host` header is not listed gets `403`. + +**`[Server] ExposeDiagnosticsResources=0` drops `logs://recent`, +`logs://{level}` and `server://status`** from the shipped executable. The +default keeps them, as before. A library that registers the resources itself +uses `RemoveResource` and the new `RemoveResourceTemplate` on +`TMCPResourcesManager` to the same effect. + +## Authentication + +**Opt-in, and only over HTTP.** Nothing changes until `[Auth] BearerTokens` +is set or a library assigns `TMCPIdHTTPServer.Authorizer`. From then on every +request to the endpoint needs `Authorization: Bearer `; `OPTIONS` and +`GET /.well-known/oauth-protected-resource[]` stay open. Legacy and +modern clients get the same `401`/`403`/`400` answers with a +`WWW-Authenticate: Bearer` challenge and an id-less JSON-RPC error body. + +**`[RequiresScope]` tools answer `403` without the scope**, also to legacy +clients (their JSON-RPC errors otherwise travel in `200`). The response carries +`WWW-Authenticate: Bearer error="insufficient_scope", scope="..."` and +`error.data.requiredScope`. + +**`TMCPRequestContext.Create` and `TMCPTransportHints` gained `Principal` and +`Scopes`.** The request state sealer binds `requestState` tokens to the +principal now, so a token obtained by one authenticated caller is rejected +when another caller presents it. + +## Subscriptions + +**`subscriptions/listen` replaces `resources/subscribe` and the GET stream.** +The shipped executable registers `TMCPSubscriptionsManager` and assigns it as +`ChangeNotifier` of the tools, prompts and resources managers, so +`server/discover` now announces `tools.listChanged`, `prompts.listChanged`, +`resources.listChanged` and `resources.subscribe` to modern clients (the +`initialize` result for legacy clients still says `false`: those clients have +no stream to receive the notifications on). A library that registers the +managers itself keeps the old behaviour until it does the same. + +**Adding or removing a tool, prompt or resource at run time notifies +subscribed clients.** `AddTool`, `AddPrompt`, `AddResource` and +`AddResourceTemplate` were already there; `RemoveTool`, `RemovePrompt`, +`RemoveResource`, `HasTool`, `HasPrompt` and +`TMCPResourcesManager.ResourceUpdated` are new. The managers guard their +lists with a lock now, so run-time changes are safe from any thread. + +**Shutdown waits for subscriptions.** `TMCPIdHTTPServer.Stop` and the end of +stdin close the open subscriptions with a completion response before the +transport goes down (up to one second, or the stdio drain time). + +## Library use + +- `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are + unchanged. `ProcessRequestEx` returns the HTTP status your own transport + should answer with. +- `TMCPToolBase` gains `ExecuteWithContext(Params, Context): TValue`; + override it to return a `TMCPToolResult` (images, audio, embedded + resources, resource links, `_meta`) or to read the request context. + `ExecuteWithParams` keeps working as before. Raise `EMCPToolError` for a + failure the model should see as an `isError` result; any other exception + is reported the same way with its message. +- `TMCPResourceBase` has `FTitle`, `FSize`, `FAnnotations`, `FTtlMs` and + `FCacheScope` for the list and read results; implement `IMCPBinaryResource` + for a `blob` resource. +- `TMCPToolsManager.CallTool` raises `EMCPError` (-32602) for an unknown tool + instead of returning an error result; `TMCPResourcesManager.ReadResource` + raises `EMCPError` for an unknown URI. Both have era-aware overloads. +- `TMCPCoreManager.SessionID` returns an empty string. +- `initialize` answers the requested revision (`2025-06-18` or `2025-11-25`) + and its `capabilities` come from the registered managers; a registry with + only a tools manager no longer advertises resources. +- Batch arrays, `id: null`, a missing `method` or `jsonrpc` are answered with + `-32600`; a non-object `params` with `-32602`. +- `TMCPStdioTransport.Create` forces stderr logging. +- `USE_TAURUS_TLS` moved from `MCPServer.IdHTTPServer.pas` to + `src\MCPServer.inc`; add `src` to your include path. diff --git a/README.md b/README.md index 96adf09..1e7d406 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ ![Delphi](https://img.shields.io/badge/Delphi-12%2B-red) ![Platform](https://img.shields.io/badge/platform-Windows%20%7C%20Linux-lightgrey) ![License](https://img.shields.io/badge/license-MIT-blue) -![MCP](https://img.shields.io/badge/MCP-2025--06--18-green) +![MCP](https://img.shields.io/badge/MCP-2026--07--28%20(dual--era)-green) A Model Context Protocol (MCP) server implementation in Delphi, designed to integrate with Claude Code, Codex, and other MCP-compatible clients for AI-powered Delphi development workflows. @@ -13,13 +13,17 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte - [Requirements](#requirements) - [Installation](#installation) - [Transport Modes](#transport-modes) +- [Protocol Versions and Dual-Era Behaviour](#protocol-versions-and-dual-era-behaviour) - [Using as a Library](#using-as-a-library) - [Integration with Claude Code](#integration-with-claude-code) - [Integration with Codex](#integration-with-codex) - [Testing with MCP Inspector](#testing-with-mcp-inspector) - [Available Example Tools](#available-example-tools) +- [Available Example Prompts](#available-example-prompts) - [Available Example Resources](#available-example-resources) - [Configuration](#configuration) +- [Authentication](#authentication) +- [Network and Security](#network-and-security) - [License](#license) - [Contributing](#contributing) - [About GDK Software](#about-gdk-software) @@ -27,12 +31,13 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte ## Features -- **Full MCP Protocol Support**: Implements MCP specification 2025-06-18 with Streamable HTTP and SSE +- **Dual-era MCP**: Serves MCP 2026-07-28 (per-request `_meta`, `server/discover`) and the initialize-based revisions 2025-06-18 and 2025-11-25 on the same endpoint and the same stdio process; see [Protocol versions](#protocol-versions-and-dual-era-behaviour) - **Dual Transport Support**: HTTP (Streamable HTTP with SSE) and STDIO (stdin/stdout) - **Dual Response Mode**: Supports both JSON-RPC and Server-Sent Events in the same server - **Tool System**: Extensible tool system with RTTI-based discovery and execution - **Resource Management**: Modular resource system supporting various content types -- **Security**: Built-in security features including CORS configuration +- **Security**: `Origin` and `Host` validation against DNS rebinding on every request, loopback binding by default, CORS headers for browser clients, request size and nesting limits, opt-in bearer authentication with OAuth 2.1 resource-server discovery +- **Multi round-trip requests, streaming and subscriptions**: `InputRequiredResult` with signed `requestState`, progress and log notifications on the response stream, `subscriptions/listen` for change notifications - **High Performance**: Native implementation using Indy HTTP Server with keep-alive support - **Optional Parameters**: Support for optional tool parameters using custom attributes - **Cross-Platform**: Supports Windows (Win32/Win64) and Linux (x64) @@ -118,9 +123,12 @@ Win32\Debug\MCPServer.exe --stdio ``` The server will: -- Read JSON-RPC requests from stdin (one per line) -- Write JSON-RPC responses to stdout (one per line) -- Log diagnostic messages to stderr +- Read JSON-RPC messages from stdin, UTF-8, one per line, no byte-order mark +- Write JSON-RPC messages to stdout the same way +- Log diagnostic messages to stderr, never to stdout +- Answer `notifications/cancelled` by stopping the named request; it gets no response +- Send `notifications/progress` for a request that carries `_meta.progressToken`, before its response +- Exit within `[Server] MaxConcurrentRequests` worker threads' drain time (2 seconds by default) once stdin closes **Use STDIO transport for:** - Codex (OpenAI) @@ -129,6 +137,75 @@ The server will: **Supported flag variants:** `--stdio`, `-stdio`, `/stdio` +By default requests are answered one at a time, in the order they arrive. +`[Server] MaxConcurrentRequests` in `settings.ini` raises the number of worker +threads for a client that issues concurrent requests over the same process; a +stdio server never writes `settings.ini` on its own, so this and the other +`[Server]` limits still need explicit configuration when they should differ +from the defaults. + +A tool sees the request it is answering through `TMCPRequestContext.Current`: +`CheckCancelled` raises once the client cancels, `ReportProgress` sends a +`notifications/progress` when the request carries a progress token, and +`Log` sends a `notifications/message` when the request carries +`_meta.io.modelcontextprotocol/logLevel` and the message's level is at or +above it. See `test_tool_with_progress` and `test_logging_tool` in +`MCPServer.Tool.ContentSamples` for worked examples. + +Over HTTP the same notifications reach the client on the response: when the +request accepts `text/event-stream` and a tool sends one, the response turns +into an SSE stream (chunked, `X-Accel-Buffering: no`) that carries the +notifications first and the JSON-RPC response as its last event. A request +that sends none is answered as before. A client that closes the stream +cancels the request. + +### Change notifications (`subscriptions/listen`) + +A modern client that wants to hear about changes opens a long-lived +`subscriptions/listen` request with a `notifications` filter +(`toolsListChanged`, `promptsListChanged`, `resourcesListChanged`, +`resourceSubscriptions`: a list of URIs). `TMCPSubscriptionsManager` +(`MCPServer.SubscriptionsManager`) answers with +`notifications/subscriptions/acknowledged` carrying the honoured filter and +keeps the stream open: over HTTP as an SSE response with a keep-alive comment +every 15 seconds, over stdio on a thread of its own so the worker threads stay +free. Every message on the subscription carries +`_meta.io.modelcontextprotocol/subscriptionId`, the JSON-RPC id of the +`subscriptions/listen` request. Closing the SSE stream, or sending +`notifications/cancelled` for that id over stdio, ends the subscription; +when the server stops (or stdin closes) it answers the request with a +completion result first. + +Assign the manager as `ChangeNotifier` of the tools, prompts and resources +managers, as `MCPServer.dpr` does, and the `tools`, `prompts` and `resources` +capabilities announce `listChanged` (and `resources.subscribe`) to modern +clients. `AddTool`, `RemoveTool`, `AddPrompt`, `RemovePrompt`, `AddResource`, +`RemoveResource` and `AddResourceTemplate` then notify the subscribed clients, +and `TMCPResourcesManager.ResourceUpdated(Uri)` reports a changed resource to +the clients that subscribed to that URI. Without a `ChangeNotifier` nothing is +announced and nothing is sent. + +## Protocol Versions and Dual-Era Behaviour + +The server decides per request which protocol era it is speaking; nothing is negotiated per connection and no session is minted. + +| Request | Era | Served as | +|---|---|---| +| `params._meta` with `io.modelcontextprotocol/protocolVersion` | modern | `2026-07-28`. `clientCapabilities` is required (`-32602`); an unknown revision gets `-32022` with the supported list; `initialize`, `ping`, `logging/setLevel` and `resources/subscribe` do not exist in this era (`-32601`). | +| `initialize` without modern `_meta` | legacy | The requested revision when it is `2025-06-18` or `2025-11-25`, otherwise `2025-11-25`. The result carries `capabilities` and `serverInfo` only. | +| `server/discover` without `_meta` | modern, malformed | `-32602` | +| Anything else | legacy | The revision negotiated by `initialize` on this stdio process, the `MCP-Protocol-Version` header on HTTP, or `2025-11-25` when nothing is known. | + +Modern results carry `resultType`, `_meta.io.modelcontextprotocol/serverInfo` and, on `server/discover`, `tools/list`, `resources/list`, `resources/templates/list` and `resources/read`, the cache hints `ttlMs` and `cacheScope`. Legacy results are unchanged. Client responses (`result` or `error` without `method`) are ignored. + +Over HTTP, modern requests must carry `MCP-Protocol-Version`, `Mcp-Method` and, for `tools/call`, `resources/read` and `prompts/get`, `Mcp-Name` (Base64 sentinel encoding accepted); a missing or different header is `400` with `-32020`. Modern protocol errors get `400`, an unknown method `404`; legacy requests get `200` for every JSON-RPC error, except `400` for an unknown `MCP-Protocol-Version` header. Notifications get `202` with an empty body. Every 4xx to a modern request carries a JSON-RPC error body, so dual-era clients can tell a modern server from a legacy one. + +Handlers can read the era, the negotiated revision and the client's declared capabilities through `TMCPRequestContext.Current` (`MCPServer.RequestContext`) or by implementing `IMCPCapabilityManagerEx`, and can raise `EMCPError` (`MCPServer.Errors`) to send a specific JSON-RPC error code. + +`settings.ini` keys: `[Server] Title`, `Description`, `WebsiteUrl` and `Instructions` fill `serverInfo` and `instructions`; `[Protocol] LenientModernPing` answers `ping` in the modern era anyway, `DiscoverListsLegacyVersions` also lists the legacy revisions in `server/discover`, and `DiscoverTtlMs` is the cache hint on `server/discover`. + +`2025-03-26` is accepted on `initialize` but answered with `2025-11-25`; JSON-RPC batch arrays are rejected with `-32600`. + ## Using as a Library The Delphi MCP Server is designed to be used both as a standalone application and as a library for your own MCP server implementations. This section covers how to integrate it into your existing Delphi projects. @@ -156,6 +233,7 @@ Copy the `src` folder from MCPServer into your project and add the units to your - `lib\mcpserver\src\Server` - `lib\mcpserver\src\Tools` - `lib\mcpserver\src\Resources` + - `lib\mcpserver\src\Prompts` 2. **Required Units**: Include these core units in your project: ```pascal @@ -219,6 +297,14 @@ begin end. ``` +#### Library checklist + +- **Register before you start.** `TMCPToolsManager.Create` and `TMCPResourcesManager.Create` read `TMCPRegistry` once. Register your tools and resources (normally from unit `initialization` sections) before the managers are created, which means before `TMCPIdHTTPServer.Start` or `TMCPStdioTransport.Run`. Later registrations are not picked up. +- **STDIO: keep stdout clean.** Everything on stdout must be an MCP message. `TMCPStdioTransport.Create` forces `TLogger.UseStdErr := True` and sets `TLogger.StdoutReserved`, so console logging goes to stderr and an attempt to switch it back is refused with a one-time warning. Never `Writeln` from tools, managers or resources; log through `TLogger`. +- **`server://status` is registered by default** by the unit initialization of `MCPServer.Resource.Server`. `TServerStatusResource.SetNamePrefix('myapp_')` renames it to `server://myapp_status`; call it before the managers are created. +- **Error codes and protocol constants** live in `MCPServer.Types` (`JSONRPC_*`, `MCP_ERROR_*`, `MCP_PROTOCOL_VERSION_*`, `MCP_META_*`). The `JSONRPC_*` names in `MCPServer.JsonRpcProcessor` remain as aliases. +- **Prompts and completion are optional managers**, registered the same way as tools and resources: `ManagerRegistry.RegisterManager(TMCPPromptsManager.Create)` and, if you want argument completion, `ManagerRegistry.RegisterManager(TMCPCompletionManager.Create(PromptsManager, ResourcesManager))` (it needs the concrete manager instances, not the `IMCPCapabilityManager` interface, to look prompts and resource templates up by name). The `prompts` and `completions` capabilities are only advertised when these managers are registered. + ### Creating Custom Tools ```pascal @@ -283,6 +369,91 @@ initialization end. ``` +Arguments are validated against the generated schema before the tool runs: a +missing property without `[Optional]`, a value of the wrong JSON type or an +unknown enumeration name is answered as an `isError` result that names the +parameter. Integer properties are published as `integer`, `TDateTime` as a +`string` with `format: date-time`, enumerations and sets with their names; +`[SchemaTitle]`, `[SchemaFormat]`, `[SchemaMinimum]` and `[SchemaMaximum]` +add the corresponding keywords. + +A tool that returns more than text overrides `ExecuteWithContext` and builds +a `TMCPToolResult` (`MCPServer.Tool.Result`): + +```pascal +function TChartTool.ExecuteWithContext(const AParams: TChartParams; + const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create + .AddText('Chart for ' + AParams.Series) + .AddImage(RenderPng(AParams), 'image/png') + .AddResourceLink('chart://' + AParams.Series, AParams.Series, '', 'image/png'); +end; +``` + +The builder also has `AddAudio`, `AddEmbeddedText`, `AddEmbeddedBlob`, +`WithAnnotations` (for the last block), `SetStructuredContent`, `SetMeta` and +`SetError`. Raise `EMCPToolError` for a failure the model should see as an +`isError` result; the request context gives the protocol era and the +client's `_meta`. Tools that inherit from `TMCPToolBase` return an +object that becomes `structuredContent` plus a text block with the same +JSON. Set `FAnnotations` (for example `readOnlyHint`) or `FIcons` in the +constructor to publish them in `tools/list`. `MCPServer.Tool.ContentSamples` +has one small example per content type. + +### Asking the client for input (multi round-trip requests) + +MCP 2026-07-28 replaced server-initiated requests (`elicitation/create`, +`sampling/createMessage`, `roots/list`) with multi round-trip requests: the +server answers `tools/call`, `resources/read` or `prompts/get` with an +`InputRequiredResult` that lists what it needs, the client gathers the +answers and retries the same request with `inputResponses` (and the +server's opaque `requestState`). A tool, resource or prompt that needs input +raises `EMCPInputRequired` (`MCPServer.Mrtr`); the request context carries +the answers on the retry: + +```pascal +function TGreetTool.ExecuteWithContext(const Params: TNoParams; + const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Name := ''; + if Context.TryGetInputResponse('user_name', Response) then + Name := TMCPInputResponse.ElicitationField(Response, 'name'); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation('user_name', 'What is your name?', TMCPInputRequests.FieldSchema('name'))); + + Result := TMCPToolResult.Text(Format('Hello, %s!', [Name])); +end; +``` + +`TMCPInputRequests` builds the `inputRequests` map (`AddElicitation`, +`AddSampling`, `AddListRoots`); `TMCPInputResponse` reads the answers +(`ElicitationContent`, `ElicitationField`, `SamplingText`, `Roots`). The +processor only sends input requests the client declared a capability for +(`elicitation`, `sampling`, `roots`) and answers `-32021` otherwise, so a +tool can check `Context.HasClientCapability` first and ask for what the +client can deliver. Missing or wrong answers are handled by raising again: +the client gets a fresh `InputRequiredResult`. + +State that must survive the round trip goes into the second constructor +argument: `EMCPInputRequired.Create(Requests, State)` with a `TJSONObject`. +The processor seals it into `requestState` (HMAC-SHA256 over the state, the +method, a digest of the request parameters, the principal and an expiry) +and opens it on the retry into `Context.RequestState`; a tampered, expired +or foreign token is `-32602`. `[Security] RequestStateKey` in `settings.ini` +is the signing secret (set the same value on every instance behind a load +balancer; empty means a random key per process) and +`RequestStateTtlSeconds` the token lifetime (600 by default). + +Clients on the 2025 revisions cannot answer input requests, so a request +that raises `EMCPInputRequired` in the legacy era is answered with +`-32603`. `MCPServer.Tool.InputRequiredSamples` and +`test_input_required_result_prompt` are the examples the conformance suite +exercises. + ### Creating Custom Resources ```pascal @@ -341,6 +512,147 @@ initialization end. ``` +`FTitle`, `FSize` and `FAnnotations` are published in `resources/list`; +`FTtlMs` and `FCacheScope` (`private` unless set) are the cache hints modern +clients get on `resources/read`. A binary resource implements +`IMCPBinaryResource.ReadBinary` and is delivered as a `blob`; +`MCPServer.Resource.Samples` shows a text and a binary example. A URI that is +not registered is answered with a JSON-RPC error (`-32002` for +initialize-based clients, `-32602` for modern clients), a read that raises +with `-32603`. + +### Resource Templates + +A template matches a family of URIs and resolves the actual resource from +the captured variables. It supports RFC 6570 level 1 (`{var}`, one path +segment) and a level 2 subset (`{+var}`, the rest of the URI including +`/`); `{/var}` and `{?var}` are not implemented. + +```pascal +unit YourProject.Resource.CustomTemplate; + +interface + +uses + MCPServer.Resource.Base, + MCPServer.Registration; + +type + TCustomTemplate = class(TMCPResourceTemplateBase) + public + constructor Create; override; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; override; + end; + +implementation + +constructor TCustomTemplate.Create; +begin + inherited; + FUriTemplate := 'custom://{id}'; + FName := 'Custom item'; + FMimeType := 'application/json'; +end; + +function TCustomTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TCustomResource.CreateForId(URI, Vars['id']); +end; + +initialization + TMCPRegistry.RegisterResourceTemplate('custom://{id}', + function: IMCPResourceTemplate + begin + Result := TCustomTemplate.Create; + end + ); + +end. +``` + +`CreateResource` gets the actual requested URI (not the template) and the +captured variables, and returns an ordinary `IMCPResource` (typically a +`TMCPResourceBase` with a constructor of your own choosing, since the +registry never constructs a template's resources itself); `resources/read` +tries an exact match first, then each registered template in order. See +`MCPServer.Resource.Samples` (`test://template/{id}/data`) and +`MCPServer.Resource.Logs` (`logs://{level}`, reusing the existing log +filtering) for worked examples. + +### Creating Custom Prompts + +```pascal +unit YourProject.Prompt.Custom; + +interface + +uses + MCPServer.Types, + MCPServer.Prompt.Base, + MCPServer.Registration; + +type + TCustomPromptParams = class + private + FTopic: string; + public + [SchemaDescription('What to write about')] + property Topic: string read FTopic write FTopic; + end; + + TCustomPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TCustomPromptParams; + Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + +implementation + +constructor TCustomPrompt.Create; +begin + inherited; + FName := 'custom_prompt'; + FDescription := 'Asks the model to write about a topic'; +end; + +function TCustomPrompt.ExecuteWithParams(const Params: TCustomPromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', 'Write a short paragraph about ' + Params.Topic + '.'); + Result := 'Writing prompt'; +end; + +initialization + TMCPRegistry.RegisterPrompt('custom_prompt', + function: IMCPPrompt + begin + Result := TCustomPrompt.Create; + end + ); + +end. +``` + +The argument list in `prompts/list` comes from `T`'s string properties, the +same `[SchemaDescription]`/`[Optional]` attributes tools use; a required +argument missing from `arguments` is `-32602`, since `prompts/get` has no +`isError` result to report it through instead. `TMCPPromptMessages` builds +the messages: `AddText`, `AddImage`, `AddAudio`, `AddResourceLink`, +`AddEmbeddedText`, `AddEmbeddedBlob`, `AddEmbeddedResource` (wraps an +existing `IMCPResource`) and `WithAnnotations` for the last message added. +For a prompt with no natural parameter class, derive from the non-generic +`TMCPPromptBase` instead and set `FArguments` directly. `MCPServer.Prompt.SummarizeLogs` +and `MCPServer.Prompt.ContentSamples` show both content and templates in use. + +A prompt or resource template that wants to offer argument completion +implements `IMCPCompletable` (`function Complete(const ArgumentName, Value: string; +const Context: TArray>): TMCPCompletion`); a target +that does not implement it answers `completion/complete` with an empty +`values` array rather than an error, since not offering completion is a +valid choice. + ## Integration with Claude Code Configure using the Streamable HTTP transport: @@ -441,20 +753,117 @@ The Inspector provides a web interface to interact with your MCP server, making - **get_time**: Get the current server time - **list_files**: List files in a directory - **calculate**: Perform basic arithmetic calculations +- **test_simple_text**, **test_image_content**, **test_audio_content**, + **test_embedded_resource**, **test_multiple_content_types**, + **test_error_handling**, **test_tool_with_progress**, **test_logging_tool**: + one small tool per content type, one that fails, one that reports progress + and honours cancellation, and one that logs at every level, from + `MCPServer.Tool.ContentSamples`; the conformance suite calls these by name +- **json_schema_2020_12_tool**: a hand-written schema exercising `$schema`, + `$defs`, `$anchor`, `$ref`, `allOf`/`anyOf` and `if`/`then`/`else`, for the + conformance suite's schema-preservation check +- **test_input_required_result_elicitation**, **..._sampling**, + **..._list_roots**, **..._request_state**, **..._multiple_inputs**, + **..._multi_round**, **..._tampered_state**, **..._capabilities**: multi + round-trip requests, one per kind of client input plus signed request + state across one or two round trips, from + `MCPServer.Tool.InputRequiredSamples`; **test_missing_capability** + requires the `sampling` client capability and answers `-32021` without it, + **test_streaming_elicitation** logs to the response stream and then asks + for a confirmation +- **test_trigger_tool_change**, **test_trigger_prompt_change**, + **test_trigger_resource_change**: add or remove `test_dynamic_tool` and + `test_dynamic_prompt`, or report `test://static-text` as updated, so that + clients on `subscriptions/listen` receive the change notifications, from + `MCPServer.Tool.SubscriptionSamples` + +## Available Example prompts + +- **summarize_logs**: summarizes the server's recent log entries, optionally + filtered by level (argument completion suggests the levels actually + present in the log buffer) +- **test_simple_prompt**, **test_prompt_with_arguments**, + **test_prompt_with_embedded_resource**, **test_prompt_with_image**: one + prompt per content type, from `MCPServer.Prompt.ContentSamples`; the + conformance suite calls these by name +- **test_input_required_result_prompt**: asks the client for a context + through an elicitation input request before it renders ## Available Example resources -The server provides four essential resources accessible via URIs: +The server provides six resources and two resource templates, accessible via URIs: +- **server://status** - Current server status and health information (request and connection counters) - **project://info** - Project information (JSON metadata with collections) -- **project://readme** - This README file (markdown content) +- **project://readme** - This README file (markdown content) - **logs://recent** - Recent log entries from all categories (with thread safety) -- **server://status** - Current server status and health information +- **logs://{level}** - Recent log entries at one level, e.g. `logs://WARNING` +- **test://template/{id}/data** - A template resource for the conformance suite +- **test://static-text** - A fixed text resource +- **test://static-binary** - A fixed PNG image, delivered as a `blob` ## Configuration The server supports configuration through `settings.ini` files. A default `settings.ini.example` is provided in the repository. +### Authentication + +The HTTP endpoint is open by default, which is fine for a loopback-only +server. A server that other machines can reach should require a token: + +- `[Auth] BearerTokens`: comma-separated pre-shared tokens. With this set the + executable installs `TMCPStaticBearerAuthorizer`; every request except + `OPTIONS` and the protected resource metadata must carry + `Authorization: Bearer `. A missing token is `401` with a + `WWW-Authenticate: Bearer` challenge, an unknown token `401` with + `error="invalid_token"`, another scheme `400` with `error="invalid_request"`. + Tokens are compared in constant time and never logged. +- `[Auth] AuthorizationServers`: issuer URLs of the OAuth 2.1 authorization + servers, published in `GET /.well-known/oauth-protected-resource` and + `/.well-known/oauth-protected-resource` (RFC 9728) and referenced + by the `resource_metadata` parameter of every challenge, so clients can + discover where to obtain a token. `ResourceUri` is the canonical URI of this + server that the tokens must name as their audience (default + `://:`); `ScopesSupported` lists the scopes + clients may request (`offline_access` is never advertised). + +A library that hosts `TMCPIdHTTPServer` assigns its own `Authorizer` +(`MCPServer.Authorization`): + +- `TMCPStaticBearerAuthorizer.Create(Tokens, Scopes)`: the pre-shared tokens, + optionally limited to a set of scopes (all scopes by default). +- `TMCPOAuthResourceServerAuthorizer`: the base for token validation against + an authorization server. Override `ValidateToken(Token, out Claims)`; the + base class then requires the `aud` claim to name `ExpectedAudience`, the + `exp` claim to lie in the future, and the `RequiredScopes` to be present in + `scope` or `scp`, answering `401 invalid_token` or `403 insufficient_scope` + otherwise. `TMCPIntrospectionAuthorizer` implements `ValidateToken` with an + RFC 7662 token introspection request (client credentials over HTTP basic + authentication). Signed-JWT validation is not built in: the RTL has no JOSE + library, so a deployment that validates JWTs locally supplies its own + `ValidateToken` on top of its JWT library of choice. +- `[RequiresScope('name')]` on a tool class makes `tools/call` answer `403` + with `WWW-Authenticate: Bearer error="insufficient_scope", scope="name"` + unless the caller's token grants that scope. On an open server, and over + stdio, nobody holds a scope, so such a tool is unusable there. + +Tools see the authenticated caller as `Context.Principal` and +`Context.HasScope`. The inbound token is bound to this server: a tool that +calls an upstream API must obtain its own credentials and must never forward +the `Authorization` header it was called with. Authentication is an HTTP +concern; the stdio transport trusts the process that spawned it and never +consults an authorizer. + +### Network and Security + +- `[Server] BindAddress`: the interface to listen on. Empty (default) derives it from `Host`: a loopback `Host` binds `127.0.0.1` and `::1`, any other `Host` binds every interface. Set `0.0.0.0` to listen everywhere explicitly. +- `[Security] AllowedOrigins`: origins that pass the `Origin` check next to the loopback origins (`localhost`, `127.0.0.1`, `[::1]`, any port). Comma-separated `scheme://host[:port]`; `:*` allows any port; `*` allows everything. Falls back to `[CORS] AllowedOrigins`. A rejected origin gets `403` with a JSON-RPC error body, also when CORS is disabled. +- `[Security] AllowedHosts`: `Host` header values the server answers, comma-separated `host[:port]` (an entry without a port matches any port, `*` matches everything). Empty means any host. Set it when the server is reachable through a public name, so that a rebinding DNS name cannot reach it; a rejected host gets `403`. +- `[Server] ExposeDiagnosticsResources`: `1` (default) registers `logs://recent`, `logs://{level}` and `server://status`; set `0` on a server that strangers can reach, the log buffer and the status counters are diagnostics. +- `[CORS] Enabled`: adds the CORS response headers for browser clients; the `Origin` check runs regardless. +- `[Server] EndpointInfoPath`: optional GET path (for example `/info`) that answers a JSON document with the endpoint URL and the protocol versions. The MCP endpoint itself only accepts POST; GET and DELETE get `405`. +- `[Server] MaxRequestBodyBytes` (4 MB) and `MaxJsonDepth` (64): larger or deeper requests get `413` or `400`; `MaxConnections`: Indy connection limit, `0` = unlimited. + ### SSL/TLS Configuration The Delphi MCP Server supports two SSL/TLS implementations: @@ -553,7 +962,7 @@ We welcome contributions! Here's how to help: ### Pull Requests 1. Fork the repository 2. Create a feature branch: `git checkout -b feature/my-feature` -3. Follow existing code style (inline vars, named constants) +3. Follow the existing code style (inline vars, named constants, no comments in code); `coding-rules.md` in the repository root lists the conventions this library keeps on purpose 4. Test your changes 5. Submit a pull request @@ -562,6 +971,21 @@ We welcome contributions! Here's how to help: - Open `MCPServer.dproj` or build with `build.bat` - Test with `npx @modelcontextprotocol/inspector` or Claude Code or similar +### Automated tests + +The `tests` folder holds a DUnitX project that drives the JSON-RPC layer in-process and pins the wire behaviour with golden files (`tests\golden`, see the README there). The scripts under `scripts` wrap the build and the external tooling; the Node tools are pinned in `package.json`. + +```powershell +.\scripts\run-tests.ps1 # build tests\MCPServerTests.dpr (Win64 Debug) and run it +.\scripts\run-tests.ps1 -Platform Win32 +.\scripts\capture-http-goldens.ps1 # replay the HTTP golden cases with curl against Win64\Debug\MCPServer.exe +.\scripts\run-stdio-smoke.ps1 # drive --stdio and check the framing of stdout/stderr +.\scripts\run-conformance.ps1 # official conformance CLI, 2026-07-28 and 2025-11-25 requirement sets +.\scripts\run-inspector-smoke.ps1 # Inspector CLI tools/list per protocol era (legacy, auto, modern) and over stdio +``` + +Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. The Inspector smoke run takes entries that are expected to fail as `-ExpectedFailures`. `build-tests.bat [Config] [Platform]` compiles the test project on its own. + ## About GDK Software [GDK Software](https://www.gdksoftware.com) is a Delphi specialist: we build, upgrade and maintain Delphi applications worldwide, and offer Delphi and AI consultancy and AI training. diff --git a/build-tests.bat b/build-tests.bat new file mode 100644 index 0000000..dbcb356 --- /dev/null +++ b/build-tests.bat @@ -0,0 +1,82 @@ +@echo off +setlocal EnableDelayedExpansion + +echo Delphi MCP Server Test Build Script (DUnitX) +echo ============================================ +echo. + +REM Set Delphi installation path - adjust if needed (same as build.bat) +set DELPHI_PATH=C:\Program Files (x86)\Embarcadero\Studio\37.0 + +if not exist "!DELPHI_PATH!\bin\dcc32.exe" ( + echo ERROR: dcc32.exe not found at !DELPHI_PATH!\bin\ + echo Please update DELPHI_PATH in this script to point to your Delphi installation + exit /b 1 +) + +set DCC32="!DELPHI_PATH!\bin\dcc32.exe" +set DCC64="!DELPHI_PATH!\bin\dcc64.exe" + +REM DUnitX ships with RAD Studio; the include path is needed for DUnitX.inc +set DUNITX_PATH=!DELPHI_PATH!\source\DUnitX + +set CONFIG=%1 +if "%CONFIG%"=="" set CONFIG=Debug + +set PLATFORM=%2 +if "%PLATFORM%"=="" set PLATFORM=Win32 + +set OUTPUT_DIR=.\tests\%PLATFORM%\%CONFIG% +if not exist %OUTPUT_DIR% mkdir %OUTPUT_DIR% + +REM Locate TaurusTLS the same way build.bat does; MCPServer.IdHTTPServer needs it. +for %%i in ("!DELPHI_PATH!") do set STUDIO_VER=%%~nxi +set CATALOG_DIR=%USERPROFILE%\Documents\Embarcadero\Studio\!STUDIO_VER!\CatalogRepository + +if not "%TAURUS_PATH%"=="" goto :TaurusResolved + +for /f "usebackq delims=" %%d in (`powershell -NoProfile -Command "$root = '!CATALOG_DIR!\TaurusTLS'; if (Test-Path $root) { Get-ChildItem $root -Directory ^| Where-Object { Test-Path (Join-Path $_.FullName 'Source') } ^| Sort-Object { try { [version]$_.Name } catch { [version]'0.0' } } ^| Select-Object -Last 1 -ExpandProperty FullName }"`) do set "TAURUS_PATH=%%d\Source" + +if "!TAURUS_PATH!"=="" if exist "!CATALOG_DIR!\TaurusTLS-12\Source" set "TAURUS_PATH=!CATALOG_DIR!\TaurusTLS-12\Source" + +:TaurusResolved +if not "!TAURUS_PATH!"=="" ( + set EXTRA_UNITS=;!TAURUS_PATH! +) else ( + set EXTRA_UNITS= + echo Warning: TaurusTLS not found. The HTTP server unit needs it. +) + +set UNIT_PATHS=src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;src\Prompts;tests!EXTRA_UNITS! +set NAMESPACES=Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap + +echo Building MCPServer.Tests - %CONFIG% %PLATFORM% +echo. + +if "%PLATFORM%"=="Win32" ( + !DCC32! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win32\debug";%UNIT_PATHS% -Isrc;!TAURUS_PATH!;"!DUNITX_PATH!" -R!TAURUS_PATH! -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServerTests.dpr + goto :CheckBuildResult +) else if "%PLATFORM%"=="Win64" ( + !DCC64! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win64\debug";%UNIT_PATHS% -Isrc;!TAURUS_PATH!;"!DUNITX_PATH!" -R!TAURUS_PATH! -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServerTests.dpr + goto :CheckBuildResult +) else ( + echo ERROR: Invalid platform. Use Win32 or Win64 + echo. + echo Usage: build-tests.bat [Config] [Platform] + echo Config: Debug or Release (default: Debug) + echo Platform: Win32 or Win64 (default: Win32) + exit /b 1 +) + +:CheckBuildResult +if %ERRORLEVEL% neq 0 ( + echo. + echo Test build FAILED! + exit /b %ERRORLEVEL% +) + +echo. +echo Test build completed successfully! +echo Output: %OUTPUT_DIR%\MCPServerTests.exe + +endlocal diff --git a/build.bat b/build.bat index ab09d36..eab88e3 100644 --- a/build.bat +++ b/build.bat @@ -70,10 +70,10 @@ if not "!TAURUS_PATH!"=="" ( ) if "%PLATFORM%"=="Win32" ( - !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -I!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;src\Prompts!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Win64" ( - !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -I!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;src\Prompts!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Linux64" ( REM Use MSBuild for Linux64 diff --git a/ci-servers.json b/ci-servers.json new file mode 100644 index 0000000..1094df3 --- /dev/null +++ b/ci-servers.json @@ -0,0 +1,24 @@ +{ + "mcpServers": { + "delphi-legacy": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "legacy" + }, + "delphi-auto": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "auto" + }, + "delphi-modern": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "modern" + }, + "delphi-stdio": { + "type": "stdio", + "command": "Win64\\Release\\MCPServer.exe", + "args": ["--stdio"] + } + } +} diff --git a/coding-rules.md b/coding-rules.md new file mode 100644 index 0000000..0b68ff9 --- /dev/null +++ b/coding-rules.md @@ -0,0 +1,33 @@ +# Coding rules + +This file records where this repository deviates from the GDK Delphi coding standard and why. Everything not listed here follows that standard. + +## Exceptions + +### Registration in `initialization` sections + +Tools, prompts, resources and resource templates register themselves in the `initialization` section of their own unit. Consumers add a unit to their project's `uses` clause and the item is available; that is the public contract of the library and the reason no central registration list exists. New tool, prompt and resource units follow the same pattern. + +### System.Generics.Collections + +The library has no third-party dependencies so that it can be dropped into any Delphi project. `System.Generics.Collections` is used instead of Spring4D collections. + +### Public global functions + +`MCPServer.Types` and a few other units expose global functions (`IsJsonString`, `StandardInputStream`, `StandardOutputStream`) because they are part of the public API and because attribute or record helpers cannot host them. Internal helpers still belong in classes or records. + +### Constructor parameter names in attributes + +Schema attributes and exception classes keep the `A` prefix on constructor parameters where the parameter would otherwise shadow a property of the same class (`Code`, `Message`, `Description`). Elsewhere parameters carry no prefix. + +### Framework callback signatures + +Indy event handlers keep the signature Indy declares, including `var` parameters (for example `OnQuerySSLPort`). + +### DUnitX fixtures + +The test runner uses RTTI discovery (`UseRTTI := True`). Test units have no `initialization` section. + +### Class section markers + +The `{ TClassName }` markers the IDE generates in the implementation section are kept. No other comments are used; behaviour is documented in the README, CHANGELOG and MIGRATION guide. diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml new file mode 100644 index 0000000..266d3ba --- /dev/null +++ b/conformance-baseline-2025-11-25.yml @@ -0,0 +1,14 @@ +# Known conformance failures for --requirements 2025-11-25 +# Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). +# Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. +server: + - logging-set-level + - tools-call-with-logging + - tools-call-sampling + - tools-call-elicitation + - elicitation-sep1034-defaults + - elicitation-sep1330-enums + - resources-subscribe + - resources-unsubscribe + # only a WARNING check (no session id on the SSE path); the runner counts it as not passed + - server-sse-multiple-streams diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml new file mode 100644 index 0000000..175080f --- /dev/null +++ b/conformance-baseline-2026-07-28.yml @@ -0,0 +1,4 @@ +# Known conformance failures for --requirements 2026-07-28 +# Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). +# Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. +server: [] diff --git a/package.json b/package.json new file mode 100644 index 0000000..2c47523 --- /dev/null +++ b/package.json @@ -0,0 +1,18 @@ +{ + "name": "delphi-mcp-server-tooling", + "version": "0.0.0", + "private": true, + "description": "Pinned Node tooling for the conformance and Inspector smoke runs of the Delphi MCP Server (see scripts/).", + "engines": { + "node": ">=22.19.0" + }, + "scripts": { + "conformance": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-conformance.ps1", + "inspector:smoke": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-inspector-smoke.ps1", + "stdio:smoke": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-stdio-smoke.ps1" + }, + "devDependencies": { + "@modelcontextprotocol/conformance": "0.2.0-alpha.11", + "@modelcontextprotocol/inspector": "2.5.0" + } +} diff --git a/scripts/McpServerProcess.ps1 b/scripts/McpServerProcess.ps1 new file mode 100644 index 0000000..91d2025 --- /dev/null +++ b/scripts/McpServerProcess.ps1 @@ -0,0 +1,157 @@ +# Helper functions for scripts that need a running server executable. +# Dot-source this file: . "$PSScriptRoot\McpServerProcess.ps1" + +function Get-RepoRoot { + return Split-Path -Parent $PSScriptRoot +} + +function Invoke-ServerBuild { + param( + [Parameter(Mandatory)] [string]$Configuration, + [Parameter(Mandatory)] [string]$Platform + ) + $repoRoot = Get-RepoRoot + Write-Host "Building server ($Configuration $Platform)..." + & cmd.exe /c "cd /d `"$repoRoot`" && .\build.bat $Configuration $Platform" + if ($LASTEXITCODE -ne 0) { + throw "Server build failed with exit code $LASTEXITCODE" + } +} + +function Wait-McpPort { + param( + [Parameter(Mandatory)] [int]$Port, + [int]$TimeoutSeconds = 15 + ) + $deadline = (Get-Date).AddSeconds($TimeoutSeconds) + while ((Get-Date) -lt $deadline) { + $client = New-Object System.Net.Sockets.TcpClient + try { + $client.Connect('127.0.0.1', $Port) + if ($client.Connected) { return $true } + } catch { + } finally { + $client.Dispose() + } + Start-Sleep -Milliseconds 200 + } + return $false +} + +<# +.SYNOPSIS + Starts the server executable on the given port and waits for it. + +.DESCRIPTION + The server reads settings.ini next to its executable, so a temporary one + with the requested port is written. Stop-McpServer restores the original. + Returns a handle object for Stop-McpServer. +#> +function Start-McpServer { + param( + [Parameter(Mandatory)] [string]$ServerExe, + [Parameter(Mandatory)] [int]$Port, + [Parameter(Mandatory)] [string]$LogDir + ) + + $ServerExe = (Resolve-Path $ServerExe).Path + $exeDir = Split-Path -Parent $ServerExe + $settingsFile = Join-Path $exeDir 'settings.ini' + $settingsBackup = $null + if (Test-Path $settingsFile) { + $settingsBackup = Get-Content -Raw $settingsFile + } + + $settingsContent = @" +[Server] +Port=$Port +Host=localhost +Name=delphi-mcp-server +Version=1.0.0 +Endpoint=/mcp +EndpointInfoPath=/info + +[CORS] +Enabled=1 +AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1 + +[SSL] +Enabled=0 +"@ + Set-Content -Path $settingsFile -Value $settingsContent -Encoding ASCII + + New-Item -ItemType Directory -Force -Path $LogDir | Out-Null + $process = Start-Process -FilePath $ServerExe -WorkingDirectory $exeDir -PassThru -NoNewWindow ` + -RedirectStandardOutput (Join-Path $LogDir 'server.log') ` + -RedirectStandardError (Join-Path $LogDir 'server.err.log') + + $handle = [pscustomobject]@{ + Process = $process + SettingsFile = $settingsFile + SettingsBackup = $settingsBackup + Port = $Port + Url = "http://127.0.0.1:$Port/mcp" + } + + if (-not (Wait-McpPort -Port $Port)) { + Stop-McpServer $handle + throw "Server did not open port $Port within the timeout (see $LogDir\server.log)" + } + return $handle +} + +function Stop-McpServer { + param([Parameter(Mandatory)] $Handle) + + if ($Handle.Process -and -not $Handle.Process.HasExited) { + Stop-Process -Id $Handle.Process.Id -Force + $Handle.Process.WaitForExit(5000) | Out-Null + } + if ($null -ne $Handle.SettingsBackup) { + Set-Content -Path $Handle.SettingsFile -Value $Handle.SettingsBackup -NoNewline + } else { + Remove-Item $Handle.SettingsFile -ErrorAction SilentlyContinue + } +} + +<# +.SYNOPSIS + Runs a native command line through cmd.exe with both streams in a log file. + +.DESCRIPTION + Windows PowerShell 5.1 turns stderr lines of native commands into error + records, which aborts scripts that run with ErrorActionPreference Stop. + Writing the command line to a batch file and redirecting inside cmd.exe + keeps the output intact. Returns the exit code. +#> +function Invoke-NativeToLog { + param( + [Parameter(Mandatory)] [string]$CommandLine, + [Parameter(Mandatory)] [string]$LogFile, + [Parameter(Mandatory)] [string]$WorkingDirectory + ) + $batchFile = [System.IO.Path]::ChangeExtension($LogFile, '.cmd') + $content = @( + '@echo off' + "cd /d `"$WorkingDirectory`"" + "$CommandLine > `"$LogFile`" 2>&1" + 'exit /b %ERRORLEVEL%' + ) + Set-Content -Path $batchFile -Value $content -Encoding ASCII + $process = Start-Process -FilePath 'cmd.exe' -ArgumentList @('/c', "`"$batchFile`"") -PassThru -NoNewWindow -Wait + return $process.ExitCode +} + +function Assert-NodeTooling { + $repoRoot = Get-RepoRoot + if (-not (Test-Path (Join-Path $repoRoot 'node_modules\@modelcontextprotocol'))) { + Write-Host 'Installing pinned Node tooling (npm install)...' + Push-Location $repoRoot + try { + & npm.cmd install --no-audit --no-fund + if ($LASTEXITCODE -ne 0) { throw "npm install failed with exit code $LASTEXITCODE" } + } finally { + Pop-Location + } + } +} diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 new file mode 100644 index 0000000..812573c --- /dev/null +++ b/scripts/capture-http-goldens.ps1 @@ -0,0 +1,245 @@ +<# +.SYNOPSIS + Records or verifies the HTTP transport golden files with curl. + +.DESCRIPTION + Starts the built server executable on a dedicated port, sends a fixed set + of requests with curl and stores status line, headers and body of each + response under tests\golden\http. In verify mode the stored files are + compared with a fresh capture. + + Volatile parts are normalised before storing: the Date and Server + headers are dropped, GUIDs become , SSE "id:" lines become + "id: ", and line endings are LF. + +.PARAMETER Record + Overwrite the stored golden files with the current responses. + +.PARAMETER ServerExe + Path to the server executable. Default: Win64\Debug\MCPServer.exe. + +.PARAMETER Port + TCP port the server is started on. Default: 3939. + +.EXAMPLE + .\scripts\capture-http-goldens.ps1 -Record + .\scripts\capture-http-goldens.ps1 +#> +[CmdletBinding()] +param( + [switch]$Record, + [string]$ServerExe, + [int]$Port = 3939 +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +if (-not $ServerExe) { + $ServerExe = Join-Path $repoRoot 'Win64\Debug\MCPServer.exe' +} +$ServerExe = (Resolve-Path $ServerExe).Path +$goldenDir = Join-Path $repoRoot 'tests\golden\http' +$resultsDir = Join-Path $repoRoot 'tests\results\http-golden' +$endpoint = "http://127.0.0.1:$Port/mcp" + +New-Item -ItemType Directory -Force -Path $goldenDir, $resultsDir | Out-Null + +$curl = Get-Command curl.exe -ErrorAction Stop + +# --------------------------------------------------------------------------- +# Server lifecycle: the server reads settings.ini next to its executable, so a +# temporary one with the test port is written and the original restored. +# --------------------------------------------------------------------------- +$exeDir = Split-Path -Parent $ServerExe +$settingsFile = Join-Path $exeDir 'settings.ini' +$settingsBackup = $null +if (Test-Path $settingsFile) { + $settingsBackup = Get-Content -Raw $settingsFile +} + +$settingsContent = @" +[Server] +Port=$Port +Host=localhost +Name=delphi-mcp-server +Version=1.0.0 +Endpoint=/mcp +EndpointInfoPath=/info + +[CORS] +Enabled=1 +AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1 + +[SSL] +Enabled=0 +"@ +Set-Content -Path $settingsFile -Value $settingsContent -Encoding ASCII + +function Wait-ForPort([int]$PortNumber, [int]$TimeoutSeconds = 15) { + $deadline = (Get-Date).AddSeconds($TimeoutSeconds) + while ((Get-Date) -lt $deadline) { + $client = New-Object System.Net.Sockets.TcpClient + try { + $client.Connect('127.0.0.1', $PortNumber) + if ($client.Connected) { return $true } + } catch { + } finally { + $client.Dispose() + } + Start-Sleep -Milliseconds 200 + } + return $false +} + +$serverLog = Join-Path $resultsDir 'server.log' +$serverErr = Join-Path $resultsDir 'server.err.log' +$server = Start-Process -FilePath $ServerExe -WorkingDirectory $exeDir -PassThru -NoNewWindow ` + -RedirectStandardOutput $serverLog -RedirectStandardError $serverErr + +try { + if (-not (Wait-ForPort $Port)) { + throw "Server did not open port $Port within the timeout (see $serverLog)" + } + + # Observation for the PR description: which address does Indy bind to? + $listen = (netstat -ano | Select-String ":$Port\s" | Select-String 'LISTENING' | ForEach-Object { $_.Line.Trim() }) -join "`n" + Set-Content -Path (Join-Path $resultsDir 'listen.txt') -Value $listen -Encoding ASCII + Write-Host "Listening sockets:`n$listen" + + # ----------------------------------------------------------------------- + # Cases + # ----------------------------------------------------------------------- + $jsonAccept = 'Accept: application/json' + $sseAccept = 'Accept: application/json, text/event-stream' + $jsonType = 'Content-Type: application/json' + $initialize = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0.0"}}}' + $modernHeader = 'MCP-Protocol-Version: 2026-07-28' + $modernMeta = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},"io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0.0"}}' + + $cases = @( + @{ Name = 'modern-discover'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: server/discover'); Body = '{"jsonrpc":"2.0","id":"d1","method":"server/discover","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":20,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-tools-call-name-base64'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call', 'Mcp-Name: =?base64?ZWNobw==?='); Body = '{"jsonrpc":"2.0","id":25,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hello modern"},' + $modernMeta + '}}' } + @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: totally/bogus/method'); Body = '{"jsonrpc":"2.0","id":21,"method":"totally/bogus/method","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-missing-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-missing-method-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-method-header-mismatch'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call'); Body = '{"jsonrpc":"2.0","id":27,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-unsupported-version'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 1900-01-01', 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":23,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}' } + @{ Name = 'modern-missing-client-capabilities'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":24,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}' } + @{ Name = 'modern-notification'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","method":"notifications/initialized"}' } + @{ Name = 'get-info-path'; Method = 'GET'; Headers = @($jsonAccept); Path = '/info' } + @{ Name = 'post-initialize'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = $initialize } + @{ Name = 'post-initialize-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = $initialize } + @{ Name = 'post-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } + @{ Name = 'post-tools-list-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } + @{ Name = 'post-tools-call-echo'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hello golden"}}}' } + @{ Name = 'post-resources-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":4,"method":"resources/list"}' } + @{ Name = 'post-resources-read-project-info'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":5,"method":"resources/read","params":{"uri":"project://info"}}' } + @{ Name = 'post-notification-initialized'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","method":"notifications/initialized"}' } + @{ Name = 'post-client-response'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":1,"result":{}}' } + @{ Name = 'post-batch-notifications'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","method":"notifications/initialized"}]' } + @{ Name = 'post-batch-requests'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","id":6,"method":"ping"}]' } + @{ Name = 'post-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":7,"method":"totally/bogus/method"}' } + @{ Name = 'post-parse-error'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":8,"method":' } + @{ Name = 'post-empty-body'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '' } + @{ Name = 'post-no-accept-header'; Method = 'POST'; Headers = @($jsonType); Body = '{"jsonrpc":"2.0","id":9,"method":"ping"}' } + @{ Name = 'post-session-echo'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Mcp-Session-Id: golden-session-1'); Body = '{"jsonrpc":"2.0","id":10,"method":"ping"}' } + @{ Name = 'post-session-echo-lowercase'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'mcp-session-id: golden-session-2'); Body = '{"jsonrpc":"2.0","id":11,"method":"ping"}' } + @{ Name = 'post-protocol-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 2025-06-18'); Body = '{"jsonrpc":"2.0","id":12,"method":"ping"}' } + @{ Name = 'post-origin-allowed'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Origin: http://localhost'); Body = '{"jsonrpc":"2.0","id":13,"method":"ping"}' } + @{ Name = 'post-origin-forbidden'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Origin: http://evil.example'); Body = '{"jsonrpc":"2.0","id":14,"method":"ping"}' } + @{ Name = 'post-wrong-path'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":15,"method":"ping"}'; Path = '/other' } + @{ Name = 'get-endpoint-info'; Method = 'GET'; Headers = @($jsonAccept) } + @{ Name = 'get-sse-stream'; Method = 'GET'; Headers = @('Accept: text/event-stream') } + @{ Name = 'options-preflight'; Method = 'OPTIONS'; Headers = @('Origin: http://localhost', 'Access-Control-Request-Method: POST', 'Access-Control-Request-Headers: Content-Type') } + @{ Name = 'delete-endpoint'; Method = 'DELETE'; Headers = @($jsonAccept) } + @{ Name = 'put-endpoint'; Method = 'PUT'; Headers = @($jsonType, $jsonAccept); Body = '{}' } + ) + + function Normalize-Response([string]$Text) { + $lines = ($Text -replace "`r`n", "`n").Split("`n") + $kept = New-Object System.Collections.Generic.List[string] + foreach ($line in $lines) { + if ($line -match '^(Date|Server):\s') { continue } + $normalized = $line + $normalized = [regex]::Replace($normalized, '\{?[0-9A-Fa-f]{8}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{12}\}?', '') + $normalized = [regex]::Replace($normalized, '^id: \d+$', 'id: ') + $kept.Add($normalized) + } + return ($kept -join "`n") + } + + $failures = 0 + $bodyFile = Join-Path $resultsDir 'request-body.tmp' + $responseFile = Join-Path $resultsDir 'response.tmp' + + foreach ($case in $cases) { + $path = if ($case.Path) { $case.Path } else { '/mcp' } + $url = "http://127.0.0.1:$Port$path" + $arguments = @('-s', '-i', '--http1.1', '-X', $case.Method, '-o', $responseFile) + foreach ($header in $case.Headers) { + $arguments += @('-H', $header) + } + if ($case.ContainsKey('Body')) { + [System.IO.File]::WriteAllBytes($bodyFile, [System.Text.Encoding]::UTF8.GetBytes([string]$case.Body)) + $arguments += @('--data-binary', "@$bodyFile") + } + $arguments += $url + + & $curl.Source @arguments + if ($LASTEXITCODE -ne 0) { + Write-Host "[$($case.Name)] curl failed with exit code $LASTEXITCODE" + $failures++ + continue + } + + $raw = [System.Text.Encoding]::UTF8.GetString([System.IO.File]::ReadAllBytes($responseFile)) + $actual = (Normalize-Response $raw).TrimEnd("`n") + $goldenFile = Join-Path $goldenDir "$($case.Name).txt" + + if ($Record) { + [System.IO.File]::WriteAllText($goldenFile, $actual + "`n", (New-Object System.Text.UTF8Encoding($false))) + Write-Host "[$($case.Name)] recorded" + continue + } + + if (-not (Test-Path $goldenFile)) { + Write-Host "[$($case.Name)] MISSING golden file (run with -Record)" + $failures++ + continue + } + + $expected = ([System.IO.File]::ReadAllText($goldenFile) -replace "`r`n", "`n").TrimEnd("`n") + if ($expected -eq $actual) { + Write-Host "[$($case.Name)] ok" + } else { + Write-Host "[$($case.Name)] MISMATCH" + Write-Host '--- expected ---' + Write-Host $expected + Write-Host '--- actual ---' + Write-Host $actual + Write-Host '---' + $failures++ + } + } + + Remove-Item $bodyFile, $responseFile -ErrorAction SilentlyContinue + + if ($failures -gt 0) { + Write-Host "$failures case(s) failed" + exit 1 + } + Write-Host 'All HTTP golden cases passed' +} +finally { + if ($server -and -not $server.HasExited) { + Stop-Process -Id $server.Id -Force + $server.WaitForExit(5000) | Out-Null + } + if ($null -ne $settingsBackup) { + Set-Content -Path $settingsFile -Value $settingsBackup -NoNewline + } else { + Remove-Item $settingsFile -ErrorAction SilentlyContinue + } +} diff --git a/scripts/run-conformance.ps1 b/scripts/run-conformance.ps1 new file mode 100644 index 0000000..fa45d5e --- /dev/null +++ b/scripts/run-conformance.ps1 @@ -0,0 +1,110 @@ +<# +.SYNOPSIS + Runs the official MCP conformance suite against the built server. + +.DESCRIPTION + Builds the server, starts it, and runs + "npx @modelcontextprotocol/conformance server" once per requirement set + (2026-07-28 and 2025-11-25 by default) against the same endpoint. Known + failures are read from conformance-baseline.yml; the run fails on new + failures and on stale baseline entries. Reports land in + tests\results\conformance\. + + The pinned tool version comes from package.json (the --requirements flag + needs the 0.2.0 line of the conformance package). + +.PARAMETER Configuration + Release (default) or Debug. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER Port + Port to start the server on. Default: 3000. + +.PARAMETER Requirements + Requirement sets to run. Default: 2026-07-28 and 2025-11-25. + +.PARAMETER NoBuild + Use the existing executable. + +.PARAMETER NoBaseline + Run without the expected-failures file (to see the raw result). + +.EXAMPLE + .\scripts\run-conformance.ps1 + .\scripts\run-conformance.ps1 -NoBuild -Requirements 2025-11-25 +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Release', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [int]$Port = 3000, + + [string[]]$Requirements = @('2026-07-28', '2025-11-25'), + + [switch]$NoBuild, + + [switch]$NoBaseline +) + +$ErrorActionPreference = 'Stop' +. "$PSScriptRoot\McpServerProcess.ps1" + +$repoRoot = Get-RepoRoot +$serverExe = Join-Path $repoRoot "$Platform\$Configuration\MCPServer.exe" +$resultsRoot = Join-Path $repoRoot 'tests\results\conformance' +$baseline = Join-Path $repoRoot 'conformance-baseline.yml' + +if (-not $NoBuild) { + Invoke-ServerBuild -Configuration $Configuration -Platform $Platform +} +Assert-NodeTooling + +New-Item -ItemType Directory -Force -Path $resultsRoot | Out-Null +$server = Start-McpServer -ServerExe $serverExe -Port $Port -LogDir $resultsRoot + +$summary = @() +try { + foreach ($revision in $Requirements) { + $outputDir = Join-Path $resultsRoot $revision + $logFile = Join-Path $resultsRoot "$revision.log" + $commandLine = "npx @modelcontextprotocol/conformance server --url $($server.Url) --requirements $revision -o `"$outputDir`"" + # One baseline per requirement set: a scenario can pass on one wire + # and fail on the other, and a listed scenario that passes counts as a + # stale entry. + $baseline = Join-Path $repoRoot "conformance-baseline-$revision.yml" + if (-not $NoBaseline -and (Test-Path $baseline)) { + $commandLine += " --expected-failures `"$baseline`"" + } + + Write-Host '' + Write-Host "=== conformance --requirements $revision ===" + $exitCode = Invoke-NativeToLog -CommandLine $commandLine -LogFile $logFile -WorkingDirectory $repoRoot + + # The per-scenario progress is in the log file; show the summary only. + $logText = [System.IO.File]::ReadAllText($logFile) + $summaryStart = $logText.LastIndexOf('=== SUMMARY ===') + if ($summaryStart -ge 0) { Write-Host $logText.Substring($summaryStart) } else { Write-Host $logText } + $summary += [pscustomobject]@{ Revision = $revision; ExitCode = $exitCode; Log = $logFile } + } +} +finally { + Stop-McpServer $server +} + +Write-Host '' +Write-Host 'Summary:' +$summary | Format-Table -AutoSize | Out-String | Write-Host + +$failed = @($summary | Where-Object { $_.ExitCode -ne 0 }) +if ($failed.Count -gt 0) { + Write-Host "$($failed.Count) requirement set(s) did not match the baseline" + exit 1 +} +Write-Host 'All requirement sets match the baseline' +exit 0 diff --git a/scripts/run-inspector-smoke.ps1 b/scripts/run-inspector-smoke.ps1 new file mode 100644 index 0000000..3ac8f63 --- /dev/null +++ b/scripts/run-inspector-smoke.ps1 @@ -0,0 +1,117 @@ +<# +.SYNOPSIS + Smoke-tests the server with the MCP Inspector CLI in every protocol era. + +.DESCRIPTION + Starts the built server and calls tools/list through + "npx @modelcontextprotocol/inspector --cli" for each entry in + ci-servers.json: delphi-legacy, delphi-auto, delphi-modern over HTTP and + delphi-stdio over a spawned process. The pinned Inspector version comes + from package.json. + + Every entry is expected to list the tools. Entries named in + -ExpectedFailures are expected to fail instead; the script exits non-zero + when an entry does not behave as expected in either direction. + +.PARAMETER Configuration + Release (default) or Debug. The stdio entry in ci-servers.json points at + Win64\Release\MCPServer.exe. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER NoBuild + Use the existing executable. + +.PARAMETER ExpectedFailures + Entry names that must fail (for example delphi-modern while the server + does not implement server/discover). + +.EXAMPLE + .\scripts\run-inspector-smoke.ps1 + .\scripts\run-inspector-smoke.ps1 -ExpectedFailures delphi-modern +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Release', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [switch]$NoBuild, + + [string[]]$ExpectedFailures = @() +) + +$ErrorActionPreference = 'Stop' +. "$PSScriptRoot\McpServerProcess.ps1" + +$repoRoot = Get-RepoRoot +$serverExe = Join-Path $repoRoot "$Platform\$Configuration\MCPServer.exe" +$resultsDir = Join-Path $repoRoot 'tests\results\inspector' +$config = Join-Path $repoRoot 'ci-servers.json' +$port = 3000 # ci-servers.json points at this port + +if (-not $NoBuild) { + Invoke-ServerBuild -Configuration $Configuration -Platform $Platform +} +Assert-NodeTooling + +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null +$server = Start-McpServer -ServerExe $serverExe -Port $port -LogDir $resultsDir + +$entries = @() +foreach ($name in 'delphi-legacy', 'delphi-auto', 'delphi-modern', 'delphi-stdio') { + $entries += @{ Name = $name; ExpectSuccess = ($ExpectedFailures -notcontains $name) } +} + +$rows = @() +try { + foreach ($entry in $entries) { + $logFile = Join-Path $resultsDir "$($entry.Name).log" + $commandLine = "npx @modelcontextprotocol/inspector --cli --config `"$config`" --server $($entry.Name) --method tools/list --format json" + $exitCode = Invoke-NativeToLog -CommandLine $commandLine -LogFile $logFile -WorkingDirectory $repoRoot + $text = [System.IO.File]::ReadAllText($logFile) + + # The JSON result is one line on stdout. A stdio server's stderr log + # lines share the log file and can interleave with it, so locate the + # result object by its prefix and parse up to the end of that line. + $toolCount = $null + $resultStart = $text.LastIndexOf('{"result":') + if ($resultStart -ge 0) { + $resultEnd = $text.IndexOfAny([char[]]@("`r", "`n"), $resultStart) + if ($resultEnd -lt 0) { $resultEnd = $text.Length } + $jsonLine = $text.Substring($resultStart, $resultEnd - $resultStart) + try { + $json = $jsonLine | ConvertFrom-Json + if ($json.result -and $json.result.tools) { $toolCount = @($json.result.tools).Count } + } catch { + } + } + + $succeeded = ($exitCode -eq 0) -and ($null -ne $toolCount) + $asExpected = ($succeeded -eq $entry.ExpectSuccess) + $rows += [pscustomobject]@{ + Server = $entry.Name + ExitCode = $exitCode + Tools = $toolCount + Succeeded = $succeeded + Expected = $entry.ExpectSuccess + AsExpected = $asExpected + } + } +} +finally { + Stop-McpServer $server +} + +$rows | Format-Table -AutoSize | Out-String | Write-Host + +$unexpected = @($rows | Where-Object { -not $_.AsExpected }) +if ($unexpected.Count -gt 0) { + Write-Host "$($unexpected.Count) entr(y/ies) did not behave as expected (see $resultsDir)" + exit 1 +} +Write-Host 'Inspector smoke run behaved as expected' +exit 0 diff --git a/scripts/run-stdio-smoke.ps1 b/scripts/run-stdio-smoke.ps1 new file mode 100644 index 0000000..6f2c03d --- /dev/null +++ b/scripts/run-stdio-smoke.ps1 @@ -0,0 +1,176 @@ +<# +.SYNOPSIS + Drives the server over stdio and checks the framing of the channel. + +.DESCRIPTION + Feeds a fixed set of JSON-RPC lines (initialize, initialized, tools/list, + tools/call echo with non-ASCII text, a tools/call with a progressToken, a + slow tools/call followed by notifications/cancelled, and ping) to + "MCPServer.exe --stdio" through cmd.exe redirection, exactly as a client + spawning the process would, and checks: + - stdout holds one JSON object per line and nothing else, + - every request id gets exactly one response, except the cancelled one, + - the non-ASCII text comes back unchanged, + - the progress notifications precede their response and increase, + - the server exits promptly once stdin is closed, + - all log lines went to stderr. + +.PARAMETER ServerExe + Path to the executable. Default: Win64\Release\MCPServer.exe. + +.EXAMPLE + .\scripts\run-stdio-smoke.ps1 +#> +[CmdletBinding()] +param( + [string]$ServerExe +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +if (-not $ServerExe) { + $ServerExe = Join-Path $repoRoot 'Win64\Release\MCPServer.exe' +} +$ServerExe = (Resolve-Path $ServerExe).Path +$resultsDir = Join-Path $repoRoot 'tests\results\stdio' +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null + +$inputFile = Join-Path $resultsDir 'input.jsonl' +$stdoutFile = Join-Path $resultsDir 'stdout.txt' +$stderrFile = Join-Path $resultsDir 'stderr.txt' + +$probe = 'h' + [char]0x00E9 + 'llo w' + [char]0x00F6 + 'rld' +$lines = @( + '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"stdio-smoke","version":"1.0.0"}}}' + '{"jsonrpc":"2.0","method":"notifications/initialized"}' + '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' + ('{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"' + $probe + '"}}}') + '{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":80},"_meta":{"progressToken":"smoke-progress"}}}' + '{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":50,"stepMs":100}}}' + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":5,"reason":"smoke test"}}' + '{"jsonrpc":"2.0","id":6,"method":"ping"}' +) +$utf8 = New-Object System.Text.UTF8Encoding($false) +[System.IO.File]::WriteAllBytes($inputFile, $utf8.GetBytes(($lines -join "`n") + "`n")) + +# A batch file keeps the redirections out of PowerShell's argument quoting. +$batchFile = Join-Path $resultsDir 'run.cmd' +$command = "@`"$ServerExe`" --stdio < `"$inputFile`" > `"$stdoutFile`" 2> `"$stderrFile`"" +Set-Content -Path $batchFile -Value $command -Encoding ASCII +$stopwatch = [System.Diagnostics.Stopwatch]::StartNew() +$process = Start-Process -FilePath 'cmd.exe' -ArgumentList @('/c', "`"$batchFile`"") -WorkingDirectory (Split-Path -Parent $ServerExe) ` + -PassThru -NoNewWindow -Wait +$stopwatch.Stop() +if ($process.ExitCode -ne 0) { + Write-Host "Server exited with code $($process.ExitCode)" +} +Write-Host "server run time: $($stopwatch.ElapsedMilliseconds) ms" + +$stdout = $utf8.GetString([System.IO.File]::ReadAllBytes($stdoutFile)) +$stderr = $utf8.GetString([System.IO.File]::ReadAllBytes($stderrFile)) + +$failures = 0 +$stdoutLines = @($stdout -split "`n" | Where-Object { $_ -ne '' }) +if ($stdout.Contains("`r")) { + Write-Host 'carriage return found on stdout; the framing is a bare LF' + $failures++ +} +if ($stdout.Length -gt 0 -and [int][char]$stdout[0] -eq 0xFEFF) { + Write-Host 'byte-order mark found on stdout' + $failures++ +} + +Write-Host "stdout lines: $($stdoutLines.Count)" +$responses = @{} +$progress = @() +$lineIndex = 0 +$responseIndexes = @{} +foreach ($line in $stdoutLines) { + try { + $message = $line | ConvertFrom-Json + } catch { + Write-Host "NOT JSON on stdout: $line" + $failures++ + continue + } + if ($null -eq $message.jsonrpc) { + Write-Host "stdout line is not a JSON-RPC message: $line" + $failures++ + continue + } + if ($null -ne $message.id) { + $responses[[string]$message.id] = $message + $responseIndexes[[string]$message.id] = $lineIndex + } elseif ($message.method -eq 'notifications/progress') { + $progress += [pscustomobject]@{ Index = $lineIndex; Params = $message.params } + } else { + Write-Host "unexpected message on stdout: $line" + $failures++ + } + $lineIndex++ +} + +foreach ($id in '1', '2', '3', '4', '6') { + if (-not $responses.ContainsKey($id)) { + Write-Host "missing response for id $id" + $failures++ + } +} +if ($responses.ContainsKey('5')) { + Write-Host 'the cancelled request (id 5) got a response' + $failures++ +} + +$smokeProgress = @($progress | Where-Object { $_.Params.progressToken -eq 'smoke-progress' }) +if ($smokeProgress.Count -lt 3) { + Write-Host "expected at least 3 progress notifications for id 4, got $($smokeProgress.Count)" + $failures++ +} else { + $previous = -1 + foreach ($item in $smokeProgress) { + if ($item.Params.progress -le $previous) { + Write-Host "progress did not increase: $($item.Params.progress) after $previous" + $failures++ + } + $previous = $item.Params.progress + if ($responseIndexes.ContainsKey('4') -and $item.Index -gt $responseIndexes['4']) { + Write-Host 'a progress notification arrived after its response' + $failures++ + } + } +} +if (@($progress | Where-Object { $_.Params.progressToken -ne 'smoke-progress' }).Count -gt 0) { + Write-Host 'progress notification with an unknown token' + $failures++ +} + +if ($stopwatch.ElapsedMilliseconds -gt 4000) { + Write-Host "the server took $($stopwatch.ElapsedMilliseconds) ms to exit; the cancelled tool should not hold it" + $failures++ +} + +if ($stdout -match '\[(INFO|WARN|ERROR|DEBUG)\s*\]') { + Write-Host 'log lines found on stdout' + $failures++ +} +if ($stderr.Trim().Length -eq 0) { + Write-Host 'expected log lines on stderr, found none' + $failures++ +} + +if ($responses.ContainsKey('3')) { + $echoText = $responses['3'].result.content[0].text + if ($echoText -ne "Echo: $probe") { + Write-Host "non-ASCII input was altered on the stdio round trip: $echoText" + $failures++ + } +} + +Write-Host "stderr: $($stderr.Length) characters (see $stderrFile)" +if ($failures -gt 0) { + Write-Host "$failures check(s) failed" + exit 1 +} +Write-Host 'stdio smoke run passed' +exit 0 diff --git a/scripts/run-tests.ps1 b/scripts/run-tests.ps1 new file mode 100644 index 0000000..17fe62d --- /dev/null +++ b/scripts/run-tests.ps1 @@ -0,0 +1,88 @@ +<# +.SYNOPSIS + Builds and runs the DUnitX test project. + +.DESCRIPTION + Compiles tests\MCPServerTests.dpr with build-tests.bat and runs the + resulting executable. Results are written as NUnit XML to tests\results. + +.PARAMETER Configuration + Debug (default) or Release. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER Record + Re-record the golden files from the current code instead of comparing. + Only do this on a commit whose behaviour you want to pin; review the diff. + +.PARAMETER Filter + Optional DUnitX run filter with fully qualified test names, comma separated, + for example "MCPServer.Tests.Golden.Legacy.TLegacyGoldenTests.Ping". + +.PARAMETER NoBuild + Skip the compile step and run the existing executable. + +.EXAMPLE + .\scripts\run-tests.ps1 + .\scripts\run-tests.ps1 -Platform Win32 + .\scripts\run-tests.ps1 -Record +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Debug', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [switch]$Record, + + [string]$Filter, + + [switch]$NoBuild +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +$testExe = Join-Path $repoRoot "tests\$Platform\$Configuration\MCPServerTests.exe" +$resultsDir = Join-Path $repoRoot 'tests\results' +$xmlFile = Join-Path $resultsDir "dunitx-$Platform-$Configuration.xml" + +if (-not $NoBuild) { + Write-Host "Building tests ($Configuration $Platform)..." + & cmd.exe /c "cd /d `"$repoRoot`" && .\build-tests.bat $Configuration $Platform" + if ($LASTEXITCODE -ne 0) { + Write-Error "Test build failed with exit code $LASTEXITCODE" + exit $LASTEXITCODE + } +} + +if (-not (Test-Path $testExe)) { + Write-Error "Test executable not found: $testExe" + exit 1 +} + +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null + +if ($Record) { + $env:MCP_GOLDEN_RECORD = '1' + Write-Host 'Golden record mode: expectations will be rewritten.' +} else { + Remove-Item Env:\MCP_GOLDEN_RECORD -ErrorAction SilentlyContinue +} + +$arguments = @('-exit:continue', "-xml:$xmlFile") +if ($Filter) { + $arguments += "-run:$Filter" +} + +Write-Host "Running $testExe $($arguments -join ' ')" +& $testExe @arguments +$exitCode = $LASTEXITCODE + +Remove-Item Env:\MCP_GOLDEN_RECORD -ErrorAction SilentlyContinue + +Write-Host "Results: $xmlFile" +exit $exitCode diff --git a/settings.ini.example b/settings.ini.example index ea0587f..4e78632 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -8,15 +8,82 @@ Host=localhost Name=delphi-mcp-server Version=1.0.0 Endpoint=/mcp +; Optional identity reported to clients (initialize and server/discover) +Title= +Description= +WebsiteUrl= +; Optional guidance for LLM clients on how to use this server +Instructions= +; Interface to listen on. Empty = derived from Host: a loopback Host binds +; 127.0.0.1 and ::1, any other Host binds every interface. Set 0.0.0.0 to +; listen on every interface explicitly. +BindAddress= +; Optional GET path that answers a JSON document with the endpoint URL and +; the protocol versions (the MCP endpoint itself only accepts POST) +EndpointInfoPath= +; Larger POST bodies are refused with 413 +MaxRequestBodyBytes=4194304 +; Deeper JSON nesting is refused with 400 +MaxJsonDepth=64 +; Indy connection limit; 0 = unlimited +MaxConnections=0 +; Serve logs://recent, logs://{level} and server://status; set 0 on a server +; that strangers can reach, the log buffer and status counters are diagnostics +ExposeDiagnosticsResources=1 +; Worker threads of the stdio transport; 1 answers requests in arrival order +MaxConcurrentRequests=1 + +[Security] +; Origins allowed next to the loopback origins (localhost, 127.0.0.1, [::1] on +; any port), for DNS-rebinding protection. Comma-separated scheme://host[:port]; +; ":*" allows any port. Empty = the [CORS] AllowedOrigins list below. +AllowedOrigins= +; Host header values the server answers, comma-separated host[:port]; an +; entry without a port matches any port, * matches everything. Empty = any +; host. Set it when the server is reachable through a public name so that a +; rebinding DNS name cannot reach it. +AllowedHosts= +; Secret that signs the requestState tokens of multi round-trip requests. +; Empty = a random key per process: tokens stop verifying after a restart +; and on other instances. Set the same value on every instance. +RequestStateKey= +; Seconds a requestState token stays valid +RequestStateTtlSeconds=600 + +[Auth] +; Pre-shared bearer tokens for the HTTP endpoint, comma-separated. Empty = no +; authentication (the default for a loopback-only server). With tokens set, +; every request except OPTIONS and the protected resource metadata must carry +; "Authorization: Bearer "; otherwise it gets 401. +BearerTokens= +; OAuth 2.1 authorization server issuer URLs, comma-separated, published in +; /.well-known/oauth-protected-resource so clients can discover where to get a +; token. Leave empty for pre-shared tokens only. +AuthorizationServers= +; Canonical URI of this server as bound into token audiences (RFC 8707). +; Empty = ://: +ResourceUri= +; Scopes clients may ask for, comma-separated, published in the metadata +ScopesSupported= + +[Protocol] +; Boolean values: use 1 (true) or 0 (false) +; Answer ping for MCP 2026-07-28 requests although that revision removed it +LenientModernPing=0 +; Also list the initialize-based revisions (2025-06-18, 2025-11-25) in +; server/discover and in unsupported-version errors +DiscoverListsLegacyVersions=0 +; Cache hint (milliseconds) on server/discover results; 0 = immediately stale +DiscoverTtlMs=0 [CORS] -; Cross-Origin Resource Sharing configuration +; Cross-Origin Resource Sharing response headers for browser clients ; Boolean values: use 1 (true) or 0 (false) Enabled=1 -; Comma-separated list of allowed origins +; Comma-separated list of allowed origins; also the Origin allow-list when +; [Security] AllowedOrigins is empty. Loopback origins are always allowed. ; Use * to allow all origins (not recommended for production) -; Default: localhost and 127.0.0.1 with http and https -AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1,http://localhost:3000,http://127.0.0.1:3000 +AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1 [SSL] ; SSL/TLS configuration (optional) diff --git a/src/Core/MCPServer.Authorization.pas b/src/Core/MCPServer.Authorization.pas new file mode 100644 index 0000000..84fbb03 --- /dev/null +++ b/src/Core/MCPServer.Authorization.pas @@ -0,0 +1,440 @@ +unit MCPServer.Authorization; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +type + TMCPAuthDecision = (Allow, Unauthorized, Forbidden, BadRequest); + + TMCPPrincipal = record + Subject: string; + Scopes: TArray; + function HasScope(const Scope: string): Boolean; + class function None: TMCPPrincipal; static; + end; + + TMCPAuthChallenge = record + Error: string; + ErrorDescription: string; + Scope: string; + class function None: TMCPAuthChallenge; static; + class function InvalidToken(const Description: string): TMCPAuthChallenge; static; + class function InvalidRequest(const Description: string): TMCPAuthChallenge; static; + class function InsufficientScope(const Scope: string): TMCPAuthChallenge; static; + end; + + IMCPAuthorizer = interface + ['{7B3D5F1A-9C2E-4A8B-B6D0-1E3F5A7C9B2D}'] + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + end; + + RequiresScopeAttribute = class(TCustomAttribute) + private + FScope: string; + public + constructor Create(const AScope: string); + property Scope: string read FScope; + end; + + TMCPBearerChallenge = record + const SCHEME = 'Bearer'; + const ERROR_INVALID_TOKEN = 'invalid_token'; + const ERROR_INVALID_REQUEST = 'invalid_request'; + const ERROR_INSUFFICIENT_SCOPE = 'insufficient_scope'; + class function Build(const ResourceMetadataUrl: string; const Challenge: TMCPAuthChallenge): string; static; + class function Quote(const Value: string): string; static; + end; + + TMCPProtectedResourceMetadata = record + const WELL_KNOWN_PATH = '/.well-known/oauth-protected-resource'; + class function Build(const ResourceUri, ResourceName: string; + const AuthorizationServers, ScopesSupported: TArray): TJSONObject; static; + class function WithoutOfflineAccess(const Scopes: TArray): TArray; static; + end; + + TMCPStaticBearerAuthorizer = class(TInterfacedObject, IMCPAuthorizer) + strict private + FTokens: TArray; + FScopes: TArray; + public + constructor Create(const Tokens: TArray; const Scopes: TArray = nil); + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + class function SameToken(const Presented, Expected: TBytes): Boolean; static; + end; + + TMCPOAuthResourceServerAuthorizer = class abstract(TInterfacedObject, IMCPAuthorizer) + strict private + FExpectedAudience: string; + FRequiredScopes: TArray; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; virtual; abstract; + function AudienceMatches(const Claims: TJSONObject): Boolean; virtual; + function IsExpired(const Claims: TJSONObject): Boolean; virtual; + function ScopesOf(const Claims: TJSONObject): TArray; virtual; + public + constructor Create(const ExpectedAudience: string); + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + property ExpectedAudience: string read FExpectedAudience; + property RequiredScopes: TArray read FRequiredScopes write FRequiredScopes; + end; + + TMCPIntrospectionAuthorizer = class(TMCPOAuthResourceServerAuthorizer) + strict private + FIntrospectionUrl: string; + FClientId: string; + FClientSecret: string; + FTimeoutMs: Integer; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; override; + public + const DEFAULT_TIMEOUT_MS = 5000; + constructor Create(const ExpectedAudience, IntrospectionUrl, ClientId, ClientSecret: string); + property IntrospectionUrl: string read FIntrospectionUrl; + property TimeoutMs: Integer read FTimeoutMs write FTimeoutMs; + end; + + EMCPAuthorizationConfiguration = class(Exception) + end; + +implementation + +uses + System.Classes, + System.DateUtils, + System.NetEncoding, + System.Net.HttpClient, + System.Net.URLClient, + System.NetConsts, + MCPServer.Logger; + +const + CLAIM_SUBJECT = 'sub'; + CLAIM_AUDIENCE = 'aud'; + CLAIM_EXPIRY = 'exp'; + CLAIM_SCOPE = 'scope'; + CLAIM_SCOPE_ARRAY = 'scp'; + CLAIM_ACTIVE = 'active'; + SCOPE_ANY = '*'; + SCOPE_OFFLINE_ACCESS = 'offline_access'; + SCOPE_SEPARATOR = ' '; + STATIC_SUBJECT_FORMAT = 'token-%d'; + MEDIA_TYPE_FORM = 'application/x-www-form-urlencoded'; + +{ TMCPPrincipal } + +class function TMCPPrincipal.None: TMCPPrincipal; +begin + Result := Default(TMCPPrincipal); +end; + +function TMCPPrincipal.HasScope(const Scope: string): Boolean; +begin + for var Granted in Scopes do + begin + if (Granted = Scope) or (Granted = SCOPE_ANY) then + Exit(True); + end; + Result := False; +end; + +{ TMCPAuthChallenge } + +class function TMCPAuthChallenge.None: TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); +end; + +class function TMCPAuthChallenge.InvalidToken(const Description: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INVALID_TOKEN; + Result.ErrorDescription := Description; +end; + +class function TMCPAuthChallenge.InvalidRequest(const Description: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INVALID_REQUEST; + Result.ErrorDescription := Description; +end; + +class function TMCPAuthChallenge.InsufficientScope(const Scope: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INSUFFICIENT_SCOPE; + Result.Scope := Scope; +end; + +{ RequiresScopeAttribute } + +constructor RequiresScopeAttribute.Create(const AScope: string); +begin + inherited Create; + FScope := AScope; +end; + +{ TMCPBearerChallenge } + +class function TMCPBearerChallenge.Quote(const Value: string): string; +begin + var Clean := Value.Replace(#13, ' ').Replace(#10, ' '); + Result := '"' + Clean.Replace('\', '\\').Replace('"', '\"') + '"'; +end; + +class function TMCPBearerChallenge.Build(const ResourceMetadataUrl: string; const Challenge: TMCPAuthChallenge): string; +begin + var Parameters: TArray := nil; + if ResourceMetadataUrl <> '' then + Parameters := Parameters + ['resource_metadata=' + Quote(ResourceMetadataUrl)]; + if Challenge.Error <> '' then + Parameters := Parameters + ['error=' + Quote(Challenge.Error)]; + if Challenge.ErrorDescription <> '' then + Parameters := Parameters + ['error_description=' + Quote(Challenge.ErrorDescription)]; + if Challenge.Scope <> '' then + Parameters := Parameters + ['scope=' + Quote(Challenge.Scope)]; + + Result := SCHEME; + if Length(Parameters) > 0 then + Result := Result + ' ' + string.Join(', ', Parameters); +end; + +{ TMCPProtectedResourceMetadata } + +class function TMCPProtectedResourceMetadata.WithoutOfflineAccess(const Scopes: TArray): TArray; +begin + Result := nil; + for var Scope in Scopes do + begin + if Scope = SCOPE_OFFLINE_ACCESS then + TLogger.Warning('offline_access is not advertised: refresh tokens are not a resource requirement') + else if Scope <> '' then + Result := Result + [Scope]; + end; +end; + +class function TMCPProtectedResourceMetadata.Build(const ResourceUri, ResourceName: string; + const AuthorizationServers, ScopesSupported: TArray): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('resource', ResourceUri); + var Servers := TJSONArray.Create; + Result.AddPair('authorization_servers', Servers); + for var Server in AuthorizationServers do + begin + Servers.Add(Server); + end; + var Scopes := WithoutOfflineAccess(ScopesSupported); + if Length(Scopes) > 0 then + begin + var ScopesArray := TJSONArray.Create; + Result.AddPair('scopes_supported', ScopesArray); + for var Scope in Scopes do + begin + ScopesArray.Add(Scope); + end; + end; + var Methods := TJSONArray.Create; + Methods.Add('header'); + Result.AddPair('bearer_methods_supported', Methods); + if ResourceName <> '' then + Result.AddPair('resource_name', ResourceName); +end; + +{ TMCPStaticBearerAuthorizer } + +constructor TMCPStaticBearerAuthorizer.Create(const Tokens: TArray; const Scopes: TArray); +begin + inherited Create; + for var Token in Tokens do + begin + if Token.Trim <> '' then + FTokens := FTokens + [TEncoding.UTF8.GetBytes(Token.Trim)]; + end; + if Length(FTokens) = 0 then + raise EMCPAuthorizationConfiguration.Create('A static bearer authorizer needs at least one token'); + FScopes := Scopes; + if Length(FScopes) = 0 then + FScopes := [SCOPE_ANY]; +end; + +class function TMCPStaticBearerAuthorizer.SameToken(const Presented, Expected: TBytes): Boolean; +begin + Result := TMCPConstantTime.SameBytes(Presented, Expected); +end; + +function TMCPStaticBearerAuthorizer.Authorize(const BearerToken, HttpMethod, Path: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +begin + Principal := TMCPPrincipal.None; + Challenge := TMCPAuthChallenge.None; + var Presented := TEncoding.UTF8.GetBytes(BearerToken); + var Matched: Integer := -1; + for var I := 0 to High(FTokens) do + begin + if SameToken(Presented, FTokens[I]) then + Matched := Integer(I); + end; + + if Matched < 0 then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The bearer token is not recognised'); + Exit(TMCPAuthDecision.Unauthorized); + end; + Principal.Subject := Format(STATIC_SUBJECT_FORMAT, [Matched + 1]); + Principal.Scopes := FScopes; + Result := TMCPAuthDecision.Allow; +end; + +{ TMCPOAuthResourceServerAuthorizer } + +constructor TMCPOAuthResourceServerAuthorizer.Create(const ExpectedAudience: string); +begin + inherited Create; + if ExpectedAudience.Trim = '' then + raise EMCPAuthorizationConfiguration.Create('An OAuth resource server authorizer needs the expected audience'); + FExpectedAudience := ExpectedAudience.Trim; +end; + +function TMCPOAuthResourceServerAuthorizer.AudienceMatches(const Claims: TJSONObject): Boolean; +begin + var Audience := Claims.GetValue(CLAIM_AUDIENCE); + if IsJsonString(Audience) then + Exit(SameText(TJSONString(Audience).Value, FExpectedAudience)); + if Audience is TJSONArray then + begin + for var Item in TJSONArray(Audience) do + begin + if IsJsonString(Item) and SameText(TJSONString(Item).Value, FExpectedAudience) then + Exit(True); + end; + end; + Result := False; +end; + +function TMCPOAuthResourceServerAuthorizer.IsExpired(const Claims: TJSONObject): Boolean; +begin + var Expiry := Claims.GetValue(CLAIM_EXPIRY); + if not (Expiry is TJSONNumber) then + Exit(True); + Result := TJSONNumber(Expiry).AsInt64 <= DateTimeToUnix(Now, False); +end; + +function TMCPOAuthResourceServerAuthorizer.ScopesOf(const Claims: TJSONObject): TArray; +begin + Result := nil; + var Scope := Claims.GetValue(CLAIM_SCOPE); + if IsJsonString(Scope) then + Exit(TJSONString(Scope).Value.Split([SCOPE_SEPARATOR], TStringSplitOptions.ExcludeEmpty)); + + var ScopeArray := Claims.GetValue(CLAIM_SCOPE_ARRAY); + if ScopeArray is TJSONArray then + begin + for var Item in TJSONArray(ScopeArray) do + begin + if IsJsonString(Item) then + Result := Result + [TJSONString(Item).Value]; + end; + end; +end; + +function TMCPOAuthResourceServerAuthorizer.Authorize(const BearerToken, HttpMethod, Path: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +var + Claims: TJSONObject; +begin + Principal := TMCPPrincipal.None; + Challenge := TMCPAuthChallenge.None; + if not ValidateToken(BearerToken, Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token is not valid'); + Exit(TMCPAuthDecision.Unauthorized); + end; + + try + if not AudienceMatches(Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token was not issued for this server'); + Exit(TMCPAuthDecision.Unauthorized); + end; + if IsExpired(Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token has expired'); + Exit(TMCPAuthDecision.Unauthorized); + end; + + Principal.Subject := Claims.GetValue(CLAIM_SUBJECT, ''); + Principal.Scopes := ScopesOf(Claims); + for var Required in FRequiredScopes do + begin + if not Principal.HasScope(Required) then + begin + Challenge := TMCPAuthChallenge.InsufficientScope(string.Join(SCOPE_SEPARATOR, FRequiredScopes)); + Exit(TMCPAuthDecision.Forbidden); + end; + end; + Result := TMCPAuthDecision.Allow; + finally + Claims.Free; + end; +end; + +{ TMCPIntrospectionAuthorizer } + +constructor TMCPIntrospectionAuthorizer.Create(const ExpectedAudience, IntrospectionUrl, ClientId, ClientSecret: string); +begin + inherited Create(ExpectedAudience); + if IntrospectionUrl.Trim = '' then + raise EMCPAuthorizationConfiguration.Create('An introspection authorizer needs the introspection endpoint URL'); + FIntrospectionUrl := IntrospectionUrl.Trim; + FClientId := ClientId; + FClientSecret := ClientSecret; + FTimeoutMs := DEFAULT_TIMEOUT_MS; +end; + +function TMCPIntrospectionAuthorizer.ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; +begin + Claims := nil; + var Client := THTTPClient.Create; + var Form := TStringStream.Create('token=' + TNetEncoding.URL.EncodeForm(Token), TEncoding.UTF8); + try + Client.ConnectionTimeout := FTimeoutMs; + Client.ResponseTimeout := FTimeoutMs; + Client.ContentType := MEDIA_TYPE_FORM; + var Headers: TArray := [TNetHeader.Create('Accept', 'application/json')]; + if FClientId <> '' then + Headers := Headers + [TNetHeader.Create('Authorization', 'Basic ' + TNetEncoding.Base64.Encode(FClientId + ':' + FClientSecret))]; + + var Response := Client.Post(FIntrospectionUrl, Form, nil, Headers); + if Response.StatusCode <> 200 then + begin + TLogger.Warning(Format('Token introspection answered HTTP %d', [Response.StatusCode])); + Exit(False); + end; + + var Parsed := TJSONObject.ParseJSONValue(Response.ContentAsString(TEncoding.UTF8)); + if not (Parsed is TJSONObject) then + begin + Parsed.Free; + Exit(False); + end; + if not (TJSONObject(Parsed).GetValue(CLAIM_ACTIVE) is TJSONTrue) then + begin + Parsed.Free; + Exit(False); + end; + Claims := TJSONObject(Parsed); + Result := True; + finally + Form.Free; + Client.Free; + end; +end; + +end. diff --git a/src/Core/MCPServer.Logger.pas b/src/Core/MCPServer.Logger.pas index d5c9d32..6e92273 100644 --- a/src/Core/MCPServer.Logger.pas +++ b/src/Core/MCPServer.Logger.pas @@ -5,20 +5,21 @@ interface uses System.SysUtils, System.Classes, + System.JSON, System.SyncObjs; type {$SCOPEDENUMS ON} TLogLevel = (Debug, Info, Warning, Error); {$SCOPEDENUMS OFF} - + TLogMessageProc = reference to procedure(const Message: string); TLogger = class private class var FInstance: TLogger; class var FLock: TCriticalSection; - + FLogToConsole: Boolean; FLogToFile: Boolean; FLogFile: TStreamWriter; @@ -26,13 +27,16 @@ TLogger = class FMinLogLevel: TLogLevel; FOnLogMessage: TLogMessageProc; FUseStdErr: Boolean; - + FStdoutReserved: Boolean; + FStdoutWarningIssued: Boolean; + class procedure SetLogToConsole(const Value: Boolean); static; class procedure SetLogToFile(const Value: Boolean); static; class procedure SetLogFileName(const Value: string); static; class procedure SetMinLogLevel(const Value: TLogLevel); static; class procedure SetOnLogMessage(const Value: TLogMessageProc); static; class procedure SetUseStdErr(const Value: Boolean); static; + class procedure SetStdoutReserved(const Value: Boolean); static; class function GetLogToConsole: Boolean; static; class function GetLogToFile: Boolean; static; @@ -40,7 +44,8 @@ TLogger = class class function GetMinLogLevel: TLogLevel; static; class function GetOnLogMessage: TLogMessageProc; static; class function GetUseStdErr: Boolean; static; - + class function GetStdoutReserved: Boolean; static; + constructor CreateInstance; procedure DoWriteLog(const Level: TLogLevel; const Message: string); procedure EnsureLogFile; @@ -49,28 +54,31 @@ TLogger = class class constructor Create; class destructor Destroy; destructor Destroy; override; - + class function Instance: TLogger; - + class procedure Debug(const Message: string); overload; class procedure Debug(const Format: string; const Args: array of const); overload; - + class procedure Info(const Message: string); overload; class procedure Info(const Format: string; const Args: array of const); overload; - + class procedure Warning(const Message: string); overload; class procedure Warning(const Format: string; const Args: array of const); overload; - + class procedure Error(const Message: string); overload; class procedure Error(const Format: string; const Args: array of const); overload; class procedure Error(const Exception: Exception); overload; - + + class function RedactJson(const Json: string): string; + class property LogToConsole: Boolean read GetLogToConsole write SetLogToConsole; class property LogToFile: Boolean read GetLogToFile write SetLogToFile; class property LogFileName: string read GetLogFileName write SetLogFileName; class property MinLogLevel: TLogLevel read GetMinLogLevel write SetMinLogLevel; class property OnLogMessage: TLogMessageProc read GetOnLogMessage write SetOnLogMessage; class property UseStdErr: Boolean read GetUseStdErr write SetUseStdErr; + class property StdoutReserved: Boolean read GetStdoutReserved write SetStdoutReserved; end; implementation @@ -127,7 +135,6 @@ class function TLogger.Instance: TLogger; Result := FInstance; end; - procedure TLogger.EnsureLogFile; begin if FLogToFile and not Assigned(FLogFile) then @@ -152,29 +159,32 @@ procedure TLogger.DoWriteLog(const Level: TLogLevel; const Message: string); var Timestamp: string; LogLine: string; + ToStdErr: Boolean; {$IFDEF MSWINDOWS} ConsoleHandle: THandle; {$ENDIF} begin if Level < FMinLogLevel then Exit; - + Timestamp := FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Now); LogLine := Format('[%s] [%-5s] %s', [Timestamp, LOG_LEVEL_NAMES[Level], Message]); - + FLock.Enter; try if FLogToConsole then begin + ToStdErr := FUseStdErr or FStdoutReserved; + {$IFDEF MSWINDOWS} - if FUseStdErr then + if ToStdErr then ConsoleHandle := GetStdHandle(STD_ERROR_HANDLE) else ConsoleHandle := GetStdHandle(STD_OUTPUT_HANDLE); SetConsoleTextAttribute(ConsoleHandle, LOG_LEVEL_COLORS[Level]); {$ENDIF} - if FUseStdErr then + if ToStdErr then WriteLn(ErrOutput, LogLine) else WriteLn(LogLine); @@ -183,14 +193,14 @@ procedure TLogger.DoWriteLog(const Level: TLogLevel; const Message: string); SetConsoleTextAttribute(ConsoleHandle, 7); {$ENDIF} end; - + if FLogToFile then begin EnsureLogFile; if Assigned(FLogFile) then FLogFile.WriteLine(LogLine); end; - + if Assigned(FOnLogMessage) then FOnLogMessage(LogLine); finally @@ -243,6 +253,51 @@ class procedure TLogger.Error(const Exception: Exception); Instance.DoWriteLog(TLogLevel.Error, System.SysUtils.Format('%s: %s', [Exception.ClassName, Exception.Message])); end; +function IsSensitiveKey(const Key: string): Boolean; +const + EXACT_KEYS: array[0..2] of string = ('_meta', 'requestState', 'inputResponses'); + PARTIAL_KEYS: array[0..5] of string = ('token', 'secret', 'password', 'authorization', 'apikey', 'api_key'); +begin + for var Exact in EXACT_KEYS do + if Key = Exact then + Exit(True); + + var Lower := Key.ToLower; + for var Partial in PARTIAL_KEYS do + if Lower.Contains(Partial) then + Exit(True); + Result := False; +end; + +procedure RedactValue(const Value: TJSONValue); +begin + if Value is TJSONObject then + begin + for var Pair in TJSONObject(Value) do + if IsSensitiveKey(Pair.JsonString.Value) then + Pair.JsonValue := TJSONString.Create('') + else + RedactValue(Pair.JsonValue); + end + else if Value is TJSONArray then + for var Item in TJSONArray(Value) do + RedactValue(Item); +end; + +class function TLogger.RedactJson(const Json: string): string; +begin + var Parsed := TJSONObject.ParseJSONValue(Json); + if not Assigned(Parsed) then + Exit(Format('<%d characters, not JSON>', [Length(Json)])); + + try + RedactValue(Parsed); + Result := Parsed.ToJSON; + finally + Parsed.Free; + end; +end; + class function TLogger.GetLogToConsole: Boolean; begin Result := Instance.FLogToConsole; @@ -331,10 +386,49 @@ class function TLogger.GetUseStdErr: Boolean; class procedure TLogger.SetUseStdErr(const Value: Boolean); var lInstance: TLogger; + WarnOnce: Boolean; begin lInstance := Instance; - if Assigned(lInstance) then + if not Assigned(lInstance) then + Exit; + + if Value or not lInstance.FStdoutReserved then + begin lInstance.FUseStdErr := Value; + Exit; + end; + + FLock.Enter; + try + WarnOnce := not lInstance.FStdoutWarningIssued; + lInstance.FStdoutWarningIssued := True; + finally + FLock.Leave; + end; + + if WarnOnce then + lInstance.DoWriteLog(TLogLevel.Warning, + 'TLogger.UseStdErr := False ignored: stdout is reserved for MCP messages while the stdio transport runs'); +end; + +class function TLogger.GetStdoutReserved: Boolean; +begin + Result := Instance.FStdoutReserved; +end; + +class procedure TLogger.SetStdoutReserved(const Value: Boolean); +var + lInstance: TLogger; +begin + lInstance := Instance; + if not Assigned(lInstance) then + Exit; + + lInstance.FStdoutReserved := Value; + if Value then + lInstance.FUseStdErr := True + else + lInstance.FStdoutWarningIssued := False; end; end. \ No newline at end of file diff --git a/src/Core/MCPServer.ManagerRegistry.pas b/src/Core/MCPServer.ManagerRegistry.pas index e1f90c3..6f8f0fc 100644 --- a/src/Core/MCPServer.ManagerRegistry.pas +++ b/src/Core/MCPServer.ManagerRegistry.pas @@ -8,15 +8,16 @@ interface MCPServer.Types; type - TMCPManagerRegistry = class(TInterfacedObject, IMCPManagerRegistry) + TMCPManagerRegistry = class(TInterfacedObject, IMCPManagerRegistry, IMCPManagerEnumerator) private FManagers: TList; public constructor Create; destructor Destroy; override; - + procedure RegisterManager(const Manager: IMCPCapabilityManager); function GetManagerForMethod(const Method: string): IMCPCapabilityManager; + function GetManagers: TArray; end; implementation @@ -37,9 +38,15 @@ destructor TMCPManagerRegistry.Destroy; end; procedure TMCPManagerRegistry.RegisterManager(const Manager: IMCPCapabilityManager); +var + Aware: IMCPRegistryAware; begin - if not FManagers.Contains(Manager) then - FManagers.Add(Manager); + if FManagers.Contains(Manager) then + Exit; + + FManagers.Add(Manager); + if Supports(Manager, IMCPRegistryAware, Aware) then + Aware.SetManagerRegistry(Self); end; function TMCPManagerRegistry.GetManagerForMethod(const Method: string): IMCPCapabilityManager; @@ -57,4 +64,9 @@ function TMCPManagerRegistry.GetManagerForMethod(const Method: string): IMCPCapa end; end; -end. \ No newline at end of file +function TMCPManagerRegistry.GetManagers: TArray; +begin + Result := FManagers.ToArray; +end; + +end. diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index 9551b88..a727180 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -7,69 +7,127 @@ interface System.Generics.Collections, MCPServer.Tool.Base, MCPServer.Resource.Base, + MCPServer.Prompt.Base, MCPServer.Logger; type TMCPToolClass = class of TMCPToolBase; - + TMCPToolFactory = reference to function: IMCPTool; TMCPResourceFactory = reference to function: IMCPResource; + TMCPPromptFactory = reference to function: IMCPPrompt; + TMCPResourceTemplateFactory = reference to function: IMCPResourceTemplate; TMCPRegistry = class private class var FTools: TDictionary; + class var FToolOrder: TList; class var FResources: TDictionary; - - class procedure EnsureInitialized; + class var FResourceOrder: TList; + class var FPrompts: TDictionary; + class var FPromptOrder: TList; + class var FResourceTemplates: TDictionary; + class var FResourceTemplateOrder: TList; + + class constructor Create; + class destructor Destroy; public class procedure RegisterTool(const Name: string; Factory: TMCPToolFactory); class procedure RegisterResource(const URI: string; Factory: TMCPResourceFactory); - + class procedure RegisterPrompt(const Name: string; Factory: TMCPPromptFactory); + class procedure RegisterResourceTemplate(const UriTemplate: string; Factory: TMCPResourceTemplateFactory); + class procedure UnregisterResource(const URI: string); + class function CreateTool(const Name: string): IMCPTool; class function CreateResource(const URI: string): IMCPResource; - + class function CreatePrompt(const Name: string): IMCPPrompt; + class function CreateResourceTemplate(const UriTemplate: string): IMCPResourceTemplate; + class function GetToolNames: TArray; class function GetResourceURIs: TArray; - + class function GetPromptNames: TArray; + class function GetResourceTemplateURIs: TArray; + class function HasTool(const Name: string): Boolean; class function HasResource(const URI: string): Boolean; + class function HasPrompt(const Name: string): Boolean; end; implementation { TMCPRegistry } -class procedure TMCPRegistry.EnsureInitialized; +class constructor TMCPRegistry.Create; begin - if not Assigned(FTools) then - FTools := TDictionary.Create; + FTools := TDictionary.Create; + FToolOrder := TList.Create; + FResources := TDictionary.Create; + FResourceOrder := TList.Create; + FPrompts := TDictionary.Create; + FPromptOrder := TList.Create; + FResourceTemplates := TDictionary.Create; + FResourceTemplateOrder := TList.Create; +end; - if not Assigned(FResources) then - FResources := TDictionary.Create; +class destructor TMCPRegistry.Destroy; +begin + FreeAndNil(FTools); + FreeAndNil(FToolOrder); + FreeAndNil(FResources); + FreeAndNil(FResourceOrder); + FreeAndNil(FPrompts); + FreeAndNil(FPromptOrder); + FreeAndNil(FResourceTemplates); + FreeAndNil(FResourceTemplateOrder); end; class procedure TMCPRegistry.RegisterTool(const Name: string; Factory: TMCPToolFactory); begin - EnsureInitialized; - + if not FTools.ContainsKey(Name) then + FToolOrder.Add(Name); FTools.AddOrSetValue(Name, Factory); TLogger.Info('Registered tool: ' + Name); end; class procedure TMCPRegistry.RegisterResource(const URI: string; Factory: TMCPResourceFactory); begin - EnsureInitialized; - + if not FResources.ContainsKey(URI) then + FResourceOrder.Add(URI); FResources.AddOrSetValue(URI, Factory); TLogger.Info('Registered resource: ' + URI); end; +class procedure TMCPRegistry.RegisterPrompt(const Name: string; Factory: TMCPPromptFactory); +begin + if not FPrompts.ContainsKey(Name) then + FPromptOrder.Add(Name); + FPrompts.AddOrSetValue(Name, Factory); + TLogger.Info('Registered prompt: ' + Name); +end; + +class procedure TMCPRegistry.RegisterResourceTemplate(const UriTemplate: string; + Factory: TMCPResourceTemplateFactory); +begin + if not FResourceTemplates.ContainsKey(UriTemplate) then + FResourceTemplateOrder.Add(UriTemplate); + FResourceTemplates.AddOrSetValue(UriTemplate, Factory); + TLogger.Info('Registered resource template: ' + UriTemplate); +end; + +class procedure TMCPRegistry.UnregisterResource(const URI: string); +begin + if FResources.ContainsKey(URI) then + begin + FResources.Remove(URI); + FResourceOrder.Remove(URI); + TLogger.Info('Unregistered resource: ' + URI); + end; +end; + class function TMCPRegistry.CreateTool(const Name: string): IMCPTool; var Factory: TMCPToolFactory; begin - EnsureInitialized; - if FTools.TryGetValue(Name, Factory) then Result := Factory() else @@ -80,48 +138,65 @@ class function TMCPRegistry.CreateResource(const URI: string): IMCPResource; var Factory: TMCPResourceFactory; begin - EnsureInitialized; - if FResources.TryGetValue(URI, Factory) then Result := Factory() else raise Exception.CreateFmt('Resource not found: %s', [URI]); end; -class function TMCPRegistry.GetToolNames: TArray; +class function TMCPRegistry.CreatePrompt(const Name: string): IMCPPrompt; +var + Factory: TMCPPromptFactory; begin - EnsureInitialized; + if FPrompts.TryGetValue(Name, Factory) then + Result := Factory() + else + raise Exception.CreateFmt('Prompt not found: %s', [Name]); +end; - Result := FTools.Keys.ToArray; +class function TMCPRegistry.CreateResourceTemplate(const UriTemplate: string): IMCPResourceTemplate; +var + Factory: TMCPResourceTemplateFactory; +begin + if FResourceTemplates.TryGetValue(UriTemplate, Factory) then + Result := Factory() + else + raise Exception.CreateFmt('Resource template not found: %s', [UriTemplate]); +end; + +class function TMCPRegistry.GetToolNames: TArray; +begin + Result := FToolOrder.ToArray; end; class function TMCPRegistry.GetResourceURIs: TArray; begin - EnsureInitialized; + Result := FResourceOrder.ToArray; +end; - Result := FResources.Keys.ToArray; +class function TMCPRegistry.GetPromptNames: TArray; +begin + Result := FPromptOrder.ToArray; end; -class function TMCPRegistry.HasTool(const Name: string): Boolean; +class function TMCPRegistry.GetResourceTemplateURIs: TArray; begin - EnsureInitialized; + Result := FResourceTemplateOrder.ToArray; +end; +class function TMCPRegistry.HasTool(const Name: string): Boolean; +begin Result := FTools.ContainsKey(Name); end; class function TMCPRegistry.HasResource(const URI: string): Boolean; begin - EnsureInitialized; - Result := FResources.ContainsKey(URI); end; -initialization - -finalization - if Assigned(TMCPRegistry.FTools) then - TMCPRegistry.FTools.Free; - if Assigned(TMCPRegistry.FResources) then - TMCPRegistry.FResources.Free; +class function TMCPRegistry.HasPrompt(const Name: string): Boolean; +begin + Result := FPrompts.ContainsKey(Name); +end; -end. \ No newline at end of file +end. diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index acb9cbe..09afae8 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -22,17 +22,41 @@ TMCPSettings = class FSSLCertFile: string; FSSLKeyFile: string; FSSLRootCertFile: string; + FServerTitle: string; + FServerDescription: string; + FServerWebsiteUrl: string; + FInstructions: string; + FLenientModernPing: Boolean; + FDiscoverListsLegacyVersions: Boolean; + FDiscoverTtlMs: Integer; + FBindAddress: string; + FEndpointInfoPath: string; + FMaxRequestBodyBytes: Integer; + FMaxJsonDepth: Integer; + FMaxConnections: Integer; + FMaxConcurrentRequests: Integer; + FSecurityAllowedOrigins: string; + FAllowedHosts: string; + FExposeDiagnosticsResources: Boolean; + FRequestStateKey: string; + FRequestStateTtlSeconds: Integer; + FBearerTokens: string; + FAuthorizationServers: string; + FResourceUri: string; + FScopesSupported: string; function GetProtocol: string; - + function SplitList(const Value: string): TArray; + function GetAllowedOrigins: string; + procedure LoadDefaults; procedure CreateDefaultSettingsFile; public constructor Create(const ASettingsFile: string = ''; const ACreateFile: Boolean = True); destructor Destroy; override; - + procedure LoadFromFile; procedure SaveToFile; - + property Port: Integer read FPort write FPort; property Host: string read FHost write FHost; property Protocol: string read GetProtocol; @@ -46,6 +70,41 @@ TMCPSettings = class property SSLCertFile: string read FSSLCertFile write FSSLCertFile; property SSLKeyFile: string read FSSLKeyFile write FSSLKeyFile; property SSLRootCertFile: string read FSSLRootCertFile write FSSLRootCertFile; + + property ServerTitle: string read FServerTitle write FServerTitle; + property ServerDescription: string read FServerDescription write FServerDescription; + property ServerWebsiteUrl: string read FServerWebsiteUrl write FServerWebsiteUrl; + property Instructions: string read FInstructions write FInstructions; + + property LenientModernPing: Boolean read FLenientModernPing write FLenientModernPing; + property DiscoverListsLegacyVersions: Boolean read FDiscoverListsLegacyVersions write FDiscoverListsLegacyVersions; + property DiscoverTtlMs: Integer read FDiscoverTtlMs write FDiscoverTtlMs; + + property BindAddress: string read FBindAddress write FBindAddress; + property EndpointInfoPath: string read FEndpointInfoPath write FEndpointInfoPath; + property MaxRequestBodyBytes: Integer read FMaxRequestBodyBytes write FMaxRequestBodyBytes; + property MaxJsonDepth: Integer read FMaxJsonDepth write FMaxJsonDepth; + property MaxConnections: Integer read FMaxConnections write FMaxConnections; + property MaxConcurrentRequests: Integer read FMaxConcurrentRequests write FMaxConcurrentRequests; + property SecurityAllowedOrigins: string read FSecurityAllowedOrigins write FSecurityAllowedOrigins; + property AllowedOrigins: string read GetAllowedOrigins; + property AllowedHosts: string read FAllowedHosts write FAllowedHosts; + property ExposeDiagnosticsResources: Boolean read FExposeDiagnosticsResources write FExposeDiagnosticsResources; + function AllowedHostList: TArray; + property RequestStateKey: string read FRequestStateKey write FRequestStateKey; + property RequestStateTtlSeconds: Integer read FRequestStateTtlSeconds write FRequestStateTtlSeconds; + property BearerTokens: string read FBearerTokens write FBearerTokens; + property AuthorizationServers: string read FAuthorizationServers write FAuthorizationServers; + property ResourceUri: string read FResourceUri write FResourceUri; + property ScopesSupported: string read FScopesSupported write FScopesSupported; + function BearerTokenList: TArray; + function AuthorizationServerList: TArray; + function ScopesSupportedList: TArray; + + const DEFAULT_MAX_REQUEST_BODY_BYTES = 4 * 1024 * 1024; + const DEFAULT_MAX_JSON_DEPTH = 64; + const DEFAULT_MAX_CONCURRENT_REQUESTS = 1; + const DEFAULT_REQUEST_STATE_TTL_SECONDS = 600; end; implementation @@ -58,20 +117,20 @@ implementation constructor TMCPSettings.Create(const ASettingsFile: string; const ACreateFile: Boolean); begin inherited Create; - + if ASettingsFile = '' then FSettingsFile := TPath.Combine(ExtractFilePath(ParamStr(0)), 'settings.ini') else FSettingsFile := ASettingsFile; - + LoadDefaults; - + if ACreateFile and (not TFile.Exists(FSettingsFile)) then begin TLogger.Info('Settings file not found. Creating default settings: ' + FSettingsFile); CreateDefaultSettingsFile; end; - + LoadFromFile; end; @@ -93,6 +152,66 @@ procedure TMCPSettings.LoadDefaults; FSSLCertFile := ''; FSSLKeyFile := ''; FSSLRootCertFile := ''; + FServerTitle := ''; + FServerDescription := ''; + FServerWebsiteUrl := ''; + FInstructions := ''; + FLenientModernPing := False; + FDiscoverListsLegacyVersions := False; + FDiscoverTtlMs := 0; + FBindAddress := ''; + FEndpointInfoPath := ''; + FMaxRequestBodyBytes := DEFAULT_MAX_REQUEST_BODY_BYTES; + FMaxJsonDepth := DEFAULT_MAX_JSON_DEPTH; + FMaxConcurrentRequests := DEFAULT_MAX_CONCURRENT_REQUESTS; + FMaxConnections := 0; + FSecurityAllowedOrigins := ''; + FAllowedHosts := ''; + FExposeDiagnosticsResources := True; + FRequestStateKey := ''; + FRequestStateTtlSeconds := DEFAULT_REQUEST_STATE_TTL_SECONDS; + FBearerTokens := ''; + FAuthorizationServers := ''; + FResourceUri := ''; + FScopesSupported := ''; +end; + +function TMCPSettings.SplitList(const Value: string): TArray; +begin + Result := nil; + for var Item in Value.Split([',']) do + begin + if Item.Trim <> '' then + Result := Result + [Item.Trim]; + end; +end; + +function TMCPSettings.AllowedHostList: TArray; +begin + Result := SplitList(FAllowedHosts); +end; + +function TMCPSettings.BearerTokenList: TArray; +begin + Result := SplitList(FBearerTokens); +end; + +function TMCPSettings.AuthorizationServerList: TArray; +begin + Result := SplitList(FAuthorizationServers); +end; + +function TMCPSettings.ScopesSupportedList: TArray; +begin + Result := SplitList(FScopesSupported); +end; + +function TMCPSettings.GetAllowedOrigins: string; +begin + if FSecurityAllowedOrigins.Trim <> '' then + Result := FSecurityAllowedOrigins + else + Result := FCorsAllowedOrigins; end; function TMCPSettings.GetProtocol: string; @@ -115,12 +234,46 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Server', 'Name', FServerName); IniFile.WriteString('Server', 'Version', FServerVersion); IniFile.WriteString('Server', 'Endpoint', FEndpoint); - + IniFile.WriteString('Server', '; Optional identity reported to clients', ''); + IniFile.WriteString('Server', 'Title', FServerTitle); + IniFile.WriteString('Server', 'Description', FServerDescription); + IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString('Server', 'Instructions', FInstructions); + IniFile.WriteString('Server', '; Network: BindAddress empty = derived from Host (loopback for localhost)', ''); + IniFile.WriteString('Server', 'BindAddress', FBindAddress); + IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); + IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + IniFile.WriteString('Server', '; Serve logs://recent, logs://{level} and server://status (0 = keep diagnostics private)', ''); + IniFile.WriteBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + + IniFile.WriteString('Security', '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); + IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', '; Host header values accepted, comma-separated host[:port] (empty = any)', ''); + IniFile.WriteString('Security', 'AllowedHosts', FAllowedHosts); + IniFile.WriteString('Security', '; Secret that signs requestState tokens (empty = random per process)', ''); + IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + IniFile.WriteString('Auth', '; Bearer tokens accepted on the HTTP endpoint (comma-separated; empty = open server)', ''); + IniFile.WriteString('Auth', 'BearerTokens', FBearerTokens); + IniFile.WriteString('Auth', '; OAuth authorization servers published in the protected resource metadata', ''); + IniFile.WriteString('Auth', 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString('Auth', 'ResourceUri', FResourceUri); + IniFile.WriteString('Auth', 'ScopesSupported', FScopesSupported); + + IniFile.WriteString('Protocol', '; Protocol options (1 = on, 0 = off)', ''); + IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + IniFile.WriteString('CORS', '; Cross-Origin Resource Sharing configuration', ''); IniFile.WriteBool('CORS', 'Enabled', FCorsEnabled); IniFile.WriteString('CORS', '; Comma-separated list of allowed origins', ''); IniFile.WriteString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); - + IniFile.WriteString('SSL', '; SSL/TLS configuration (optional)', ''); IniFile.WriteBool('SSL', 'Enabled', FSSLEnabled); IniFile.WriteString('SSL', 'CertFile', FSSLCertFile); @@ -137,7 +290,7 @@ procedure TMCPSettings.LoadFromFile; begin if not TFile.Exists(FSettingsFile) then Exit; - + IniFile := TIniFile.Create(FSettingsFile); try FPort := IniFile.ReadInteger('Server', 'Port', FPort); @@ -145,15 +298,40 @@ procedure TMCPSettings.LoadFromFile; FServerName := IniFile.ReadString('Server', 'Name', FServerName); FServerVersion := IniFile.ReadString('Server', 'Version', FServerVersion); FEndpoint := IniFile.ReadString('Server', 'Endpoint', FEndpoint); - + FServerTitle := IniFile.ReadString('Server', 'Title', FServerTitle); + FServerDescription := IniFile.ReadString('Server', 'Description', FServerDescription); + FServerWebsiteUrl := IniFile.ReadString('Server', 'WebsiteUrl', FServerWebsiteUrl); + FInstructions := IniFile.ReadString('Server', 'Instructions', FInstructions); + FBindAddress := IniFile.ReadString('Server', 'BindAddress', FBindAddress); + FEndpointInfoPath := IniFile.ReadString('Server', 'EndpointInfoPath', FEndpointInfoPath); + FMaxRequestBodyBytes := IniFile.ReadInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + FMaxJsonDepth := IniFile.ReadInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + FMaxConcurrentRequests := IniFile.ReadInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); + FMaxConnections := IniFile.ReadInteger('Server', 'MaxConnections', FMaxConnections); + + FSecurityAllowedOrigins := IniFile.ReadString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + FAllowedHosts := IniFile.ReadString('Security', 'AllowedHosts', FAllowedHosts); + FExposeDiagnosticsResources := IniFile.ReadBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + FRequestStateKey := IniFile.ReadString('Security', 'RequestStateKey', FRequestStateKey); + FRequestStateTtlSeconds := IniFile.ReadInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + FBearerTokens := IniFile.ReadString('Auth', 'BearerTokens', FBearerTokens); + FAuthorizationServers := IniFile.ReadString('Auth', 'AuthorizationServers', FAuthorizationServers); + FResourceUri := IniFile.ReadString('Auth', 'ResourceUri', FResourceUri); + FScopesSupported := IniFile.ReadString('Auth', 'ScopesSupported', FScopesSupported); + + FLenientModernPing := IniFile.ReadBool('Protocol', 'LenientModernPing', FLenientModernPing); + FDiscoverListsLegacyVersions := IniFile.ReadBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + FDiscoverTtlMs := IniFile.ReadInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + FCorsEnabled := IniFile.ReadBool('CORS', 'Enabled', FCorsEnabled); FCorsAllowedOrigins := IniFile.ReadString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); - + FSSLEnabled := IniFile.ReadBool('SSL', 'Enabled', FSSLEnabled); FSSLCertFile := IniFile.ReadString('SSL', 'CertFile', FSSLCertFile); FSSLKeyFile := IniFile.ReadString('SSL', 'KeyFile', FSSLKeyFile); FSSLRootCertFile := IniFile.ReadString('SSL', 'RootCertFile', FSSLRootCertFile); - + TLogger.Info('Settings loaded from: ' + FSettingsFile); TLogger.Info('Server: ' + Protocol + '://' + FHost + ':' + IntToStr(FPort)); if FSSLEnabled then @@ -181,10 +359,35 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteString('Server', 'Name', FServerName); IniFile.WriteString('Server', 'Version', FServerVersion); IniFile.WriteString('Server', 'Endpoint', FEndpoint); - + IniFile.WriteString('Server', 'Title', FServerTitle); + IniFile.WriteString('Server', 'Description', FServerDescription); + IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString('Server', 'Instructions', FInstructions); + IniFile.WriteString('Server', 'BindAddress', FBindAddress); + IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); + IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + IniFile.WriteBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + + IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', 'AllowedHosts', FAllowedHosts); + IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + IniFile.WriteString('Auth', 'BearerTokens', FBearerTokens); + IniFile.WriteString('Auth', 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString('Auth', 'ResourceUri', FResourceUri); + IniFile.WriteString('Auth', 'ScopesSupported', FScopesSupported); + + IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + IniFile.WriteBool('CORS', 'Enabled', FCorsEnabled); IniFile.WriteString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); - + IniFile.WriteBool('SSL', 'Enabled', FSSLEnabled); IniFile.WriteString('SSL', 'CertFile', FSSLCertFile); IniFile.WriteString('SSL', 'KeyFile', FSSLKeyFile); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 24ddf5b..916cba4 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -12,35 +12,58 @@ uses Posix.Signal, {$ENDIF} MCPServer.Types in 'Protocol\MCPServer.Types.pas', + MCPServer.Errors in 'Protocol\MCPServer.Errors.pas', + MCPServer.RequestContext in 'Protocol\MCPServer.RequestContext.pas', + MCPServer.Capabilities in 'Protocol\MCPServer.Capabilities.pas', + MCPServer.HttpHeaders in 'Server\MCPServer.HttpHeaders.pas', + MCPServer.HttpStream in 'Server\MCPServer.HttpStream.pas', MCPServer.Serializer in 'Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in 'Protocol\MCPServer.Schema.Generator.pas', + MCPServer.Schema.Validator in 'Protocol\MCPServer.Schema.Validator.pas', + MCPServer.ContentBlocks in 'Protocol\MCPServer.ContentBlocks.pas', MCPServer.Logger in 'Core\MCPServer.Logger.pas', MCPServer.Settings in 'Core\MCPServer.Settings.pas', + MCPServer.Authorization in 'Core\MCPServer.Authorization.pas', MCPServer.Registration in 'Core\MCPServer.Registration.pas', MCPServer.ManagerRegistry in 'Core\MCPServer.ManagerRegistry.pas', MCPServer.Tool.Base in 'Tools\MCPServer.Tool.Base.pas', + MCPServer.Tool.Result in 'Tools\MCPServer.Tool.Result.pas', MCPServer.Resource.Base in 'Resources\MCPServer.Resource.Base.pas', + MCPServer.Prompt.Base in 'Prompts\MCPServer.Prompt.Base.pas', MCPServer.IdHTTPServer in 'Server\MCPServer.IdHTTPServer.pas', MCPServer.StdioTransport in 'Server\MCPServer.StdioTransport.pas', + MCPServer.StdioChannel in 'Server\MCPServer.StdioChannel.pas', MCPServer.JsonRpcProcessor in 'Protocol\MCPServer.JsonRpcProcessor.pas', MCPServer.CoreManager in 'Managers\MCPServer.CoreManager.pas', MCPServer.ToolsManager in 'Managers\MCPServer.ToolsManager.pas', MCPServer.ResourcesManager in 'Managers\MCPServer.ResourcesManager.pas', + MCPServer.PromptsManager in 'Managers\MCPServer.PromptsManager.pas', + MCPServer.CompletionManager in 'Managers\MCPServer.CompletionManager.pas', + MCPServer.SubscriptionsManager in 'Managers\MCPServer.SubscriptionsManager.pas', MCPServer.Resource.Server in 'Resources\MCPServer.Resource.Server.pas', MCPServer.Tool.Echo in 'Tools\MCPServer.Tool.Echo.pas', MCPServer.Tool.GetTime in 'Tools\MCPServer.Tool.GetTime.pas', MCPServer.Tool.ListFiles in 'Tools\MCPServer.Tool.ListFiles.pas', MCPServer.Tool.Calculate in 'Tools\MCPServer.Tool.Calculate.pas', MCPServer.Resource.Logs in 'Resources\MCPServer.Resource.Logs.pas', - MCPServer.Resource.Project in 'Resources\MCPServer.Resource.Project.pas'; + MCPServer.Resource.Project in 'Resources\MCPServer.Resource.Project.pas', + MCPServer.Tool.ContentSamples in 'Tools\MCPServer.Tool.ContentSamples.pas', + MCPServer.Tool.InputRequiredSamples in 'Tools\MCPServer.Tool.InputRequiredSamples.pas', + MCPServer.Tool.SubscriptionSamples in 'Tools\MCPServer.Tool.SubscriptionSamples.pas', + MCPServer.Resource.Samples in 'Resources\MCPServer.Resource.Samples.pas', + MCPServer.Prompt.SummarizeLogs in 'Prompts\MCPServer.Prompt.SummarizeLogs.pas', + MCPServer.Prompt.ContentSamples in 'Prompts\MCPServer.Prompt.ContentSamples.pas'; var Server: TMCPIdHTTPServer; Settings: TMCPSettings; ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager; - ToolsManager: IMCPCapabilityManager; - ResourcesManager: IMCPCapabilityManager; + ToolsManager: TMCPToolsManager; + ResourcesManager: TMCPResourcesManager; + PromptsManager: TMCPPromptsManager; + CompletionManager: IMCPCapabilityManager; + SubscriptionsManager: TMCPSubscriptionsManager; ShutdownEvent: TEvent; {$IFDEF MSWINDOWS} @@ -85,16 +108,33 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + if not Settings.ExposeDiagnosticsResources then + begin + ResourcesManager.RemoveResource('logs://recent'); + ResourcesManager.RemoveResource('server://status'); + ResourcesManager.RemoveResourceTemplate('logs://{level}'); + end; + PromptsManager := TMCPPromptsManager.Create; + CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); + SubscriptionsManager := TMCPSubscriptionsManager.Create; + ToolsManager.ChangeNotifier := SubscriptionsManager; + ResourcesManager.ChangeNotifier := SubscriptionsManager; + PromptsManager.ChangeNotifier := SubscriptionsManager; ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); + ManagerRegistry.RegisterManager(PromptsManager); + ManagerRegistry.RegisterManager(CompletionManager); + ManagerRegistry.RegisterManager(SubscriptionsManager); Server := TMCPIdHTTPServer.Create(nil); try Server.Settings := Settings; Server.ManagerRegistry := ManagerRegistry; Server.CoreManager := CoreManager; + if Length(Settings.BearerTokenList) > 0 then + Server.Authorizer := TMCPStaticBearerAuthorizer.Create(Settings.BearerTokenList); Server.Start; @@ -115,7 +155,9 @@ procedure RunStdioServer; var StdioTransport: TMCPStdioTransport; begin - Settings := TMCPSettings.Create; + // A stdio server is spawned by its client; it reads settings.ini when + // present but never writes one next to the executable. + Settings := TMCPSettings.Create('', False); TLogger.Info('Delphi MCP Server v' + Settings.ServerVersion); TLogger.Info('================================'); @@ -126,13 +168,29 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + if not Settings.ExposeDiagnosticsResources then + begin + ResourcesManager.RemoveResource('logs://recent'); + ResourcesManager.RemoveResource('server://status'); + ResourcesManager.RemoveResourceTemplate('logs://{level}'); + end; + PromptsManager := TMCPPromptsManager.Create; + CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); + SubscriptionsManager := TMCPSubscriptionsManager.Create; + ToolsManager.ChangeNotifier := SubscriptionsManager; + ResourcesManager.ChangeNotifier := SubscriptionsManager; + PromptsManager.ChangeNotifier := SubscriptionsManager; ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); + ManagerRegistry.RegisterManager(PromptsManager); + ManagerRegistry.RegisterManager(CompletionManager); + ManagerRegistry.RegisterManager(SubscriptionsManager); StdioTransport := TMCPStdioTransport.Create(ManagerRegistry, CoreManager); try + StdioTransport.Settings := Settings; StdioTransport.Run; finally StdioTransport.Free; @@ -166,20 +224,29 @@ begin TLogger.LogToConsole := True; TLogger.MinLogLevel := TLogLevel.Info; - ReportMemoryLeaksOnShutdown := True; + {$IFDEF DEBUG} + // The leak report is a dialog on Windows; a stdio server has no place for it. + ReportMemoryLeaksOnShutdown := not HasStdioFlag; + {$ENDIF} IsMultiThread := True; // Create shutdown event ShutdownEvent := TEvent.Create(nil, True, False, ''); try - // Set up signal handlers + // Set up signal handlers. Over stdio the client ends the server by + // closing stdin; a signal keeps its default meaning (terminate) instead + // of setting an event nobody waits on. {$IFDEF MSWINDOWS} - SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); + if not HasStdioFlag then + SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); {$ENDIF} {$IFDEF POSIX} - signal(SIGINT, @SignalHandler); - signal(SIGTERM, @SignalHandler); + if not HasStdioFlag then + begin + signal(SIGINT, @SignalHandler); + signal(SIGTERM, @SignalHandler); + end; {$ENDIF} try @@ -196,7 +263,8 @@ begin end; {$IFDEF MSWINDOWS} - SetConsoleCtrlHandler(@ConsoleCtrlHandler, False); + if not HasStdioFlag then + SetConsoleCtrlHandler(@ConsoleCtrlHandler, False); {$ENDIF} finally ShutdownEvent.Free; diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index ed82f9e..4abf768 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -75,7 +75,7 @@ MCPServer RESTBackendComponents;bindengine;CloudService;DataSnapClient;DataSnapCommon;DataSnapConnectors;DatasnapConnectorsFreePascal;DataSnapProviderClient;DataSnapServer;dbexpress;dbrtl;dbxcds;DbxClientDriver;DbxCommonDriver;DBXInterBaseDriver;DBXMySQLDriver;DBXSqliteDriver;fmx;fmxase;fmxdae;fmxobj;IndyCore;IndyIPClient;IndyIPCommon;IndyIPServer;IndyProtocols;IndySystem;inet;RESTComponents;rtl;soaprtl;vcl;vcldb;vcldsnap;vclimg;vcltouch;vclx;xmlrtl;$(DCC_UsePackage) true - .;.\Managers;.\Server;.\Tools;.\Core;.\Protocol;.\Libraries;.\Resources;$(DCC_UnitSearchPath) + .;.\Managers;.\Server;.\Tools;.\Core;.\Protocol;.\Libraries;.\Resources;.\Prompts;$(DCC_UnitSearchPath) System.Posix;$(DCC_Namespace) @@ -129,18 +129,30 @@ MainSource + + + + + + + + + + + + @@ -148,6 +160,14 @@ + + + + + + + + Base diff --git a/src/MCPServer.inc b/src/MCPServer.inc new file mode 100644 index 0000000..4c802c0 --- /dev/null +++ b/src/MCPServer.inc @@ -0,0 +1,7 @@ +// Shared compiler settings for the Delphi MCP Server units. + +// TaurusTLS provides OpenSSL 3.x/4.x support with modern ECDHE cipher suites. +// Install via GetIt Package Manager ("TaurusTLS") or from +// https://github.com/TaurusTLS-Developers/TaurusTLS +// Comment the next line to use the standard Indy SSL handler (OpenSSL 1.0.2). +{$DEFINE USE_TAURUS_TLS} diff --git a/src/Managers/MCPServer.CompletionManager.pas b/src/Managers/MCPServer.CompletionManager.pas new file mode 100644 index 0000000..08b74ef --- /dev/null +++ b/src/Managers/MCPServer.CompletionManager.pas @@ -0,0 +1,216 @@ +unit MCPServer.CompletionManager; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON, + System.Rtti, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Logger, + MCPServer.PromptsManager, + MCPServer.ResourcesManager; + +type + TMCPCompletionManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) + strict private + FPrompts: TMCPPromptsManager; + FResources: TMCPResourcesManager; + FPromptsRef: IInterface; + FResourcesRef: IInterface; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; + function ResolveTarget(const Ref: TJSONObject; Era: TMCPProtocolEra): IInterface; + function ParseContext(const Params: TJSONObject): TArray>; + function BuildCompletionJSON(const Completion: TMCPCompletion): TJSONObject; + public + constructor Create(const Prompts: TMCPPromptsManager; const Resources: TMCPResourcesManager); + + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + + function Complete(const Params: System.JSON.TJSONObject): TValue; overload; + function Complete(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.RequestContext, + MCPServer.Prompt.Base, + MCPServer.Resource.Base; + +{ TMCPCompletionManager } + +constructor TMCPCompletionManager.Create(const Prompts: TMCPPromptsManager; const Resources: TMCPResourcesManager); +begin + inherited Create; + FPrompts := Prompts; + FResources := Resources; + FPromptsRef := Prompts; + FResourcesRef := Resources; +end; + +function TMCPCompletionManager.GetCapabilityName: string; +begin + Result := 'completions'; +end; + +function TMCPCompletionManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = 'completion/complete'; +end; + +procedure TMCPCompletionManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + Capabilities.AddPair('completions', TJSONObject.Create); +end; + +function TMCPCompletionManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPCompletionManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPCompletionManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = 'completion/complete' then + Result := Complete(Params, EraOf(Context)) + else + raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); +end; + +function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject; Era: TMCPProtocolEra): IInterface; +var + Prompt: IMCPPrompt; + Template: IMCPResourceTemplate; + Resource: IMCPResource; +begin + var TypeValue := Ref.GetValue('type'); + if not (TypeValue is TJSONString) then + raise EMCPError.InvalidParams('params.ref.type is required'); + var RefType := TJSONString(TypeValue).Value; + + if RefType = 'ref/prompt' then + begin + var NameValue := Ref.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.ref.name is required for ref/prompt'); + var PromptName := TJSONString(NameValue).Value; + if not FPrompts.TryGetPrompt(PromptName, Prompt) then + raise EMCPError.UnknownPrompt(PromptName); + Result := Prompt; + end + else if RefType = 'ref/resource' then + begin + var UriValue := Ref.GetValue('uri'); + if not (UriValue is TJSONString) or (TJSONString(UriValue).Value = '') then + raise EMCPError.InvalidParams('params.ref.uri is required for ref/resource'); + var Uri := TJSONString(UriValue).Value; + if FResources.TryGetResourceTemplate(Uri, Template) then + Result := Template + else if FResources.TryGetResource(Uri, Resource) then + Result := Resource + else + raise EMCPError.ResourceNotFound(Uri, Era); + end + else + raise EMCPError.InvalidParams('params.ref.type must be "ref/prompt" or "ref/resource"'); +end; + +function TMCPCompletionManager.ParseContext(const Params: TJSONObject): TArray>; +begin + Result := nil; + var ContextValue := Params.GetValue('context'); + if not (ContextValue is TJSONObject) then + Exit; + var ArgumentsValue := TJSONObject(ContextValue).GetValue('arguments'); + if not (ArgumentsValue is TJSONObject) then + Exit; + + var List := TList>.Create; + try + for var Pair in TJSONObject(ArgumentsValue) do + if Pair.JsonValue is TJSONString then + List.Add(TPair.Create(Pair.JsonString.Value, TJSONString(Pair.JsonValue).Value)); + Result := List.ToArray; + finally + List.Free; + end; +end; + +function TMCPCompletionManager.BuildCompletionJSON(const Completion: TMCPCompletion): TJSONObject; +begin + var Values := TJSONArray.Create; + for var Value in Completion.Values do + Values.Add(Value); + + Result := TJSONObject.Create; + Result.AddPair('values', Values); + if Completion.Total >= 0 then + Result.AddPair('total', TJSONNumber.Create(Completion.Total)); + Result.AddPair('hasMore', TJSONBool.Create(Completion.HasMore)); +end; + +function TMCPCompletionManager.Complete(const Params: System.JSON.TJSONObject): TValue; +begin + Result := Complete(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPCompletionManager.Complete(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +var + Completable: IMCPCompletable; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.ref is required'); + + var RefValue := Params.GetValue('ref'); + if not (RefValue is TJSONObject) then + raise EMCPError.InvalidParams('params.ref is required and must be an object'); + + var ArgumentValue := Params.GetValue('argument'); + if not (ArgumentValue is TJSONObject) then + raise EMCPError.InvalidParams('params.argument is required and must be an object'); + var Argument := TJSONObject(ArgumentValue); + var ArgumentNameValue := Argument.GetValue('name'); + if not (ArgumentNameValue is TJSONString) or (TJSONString(ArgumentNameValue).Value = '') then + raise EMCPError.InvalidParams('params.argument.name is required and must be a non-empty string'); + var ArgumentValueValue := Argument.GetValue('value'); + if not (ArgumentValueValue is TJSONString) then + raise EMCPError.InvalidParams('params.argument.value is required and must be a string'); + + TLogger.Info('MCP Complete called for argument: ' + TJSONString(ArgumentNameValue).Value); + + var Target := ResolveTarget(TJSONObject(RefValue), Era); + var Completion: TMCPCompletion; + if Supports(Target, IMCPCompletable, Completable) then + Completion := Completable.Complete(TJSONString(ArgumentNameValue).Value, TJSONString(ArgumentValueValue).Value, + ParseContext(Params)) + else + Completion := TMCPCompletion.Create(nil); + + var ResultJSON := TJSONObject.Create; + try + ResultJSON.AddPair('completion', BuildCompletionJSON(Completion)); + Result := TValue.From(ResultJSON); + except + ResultJSON.Free; + raise; + end; +end; + +end. diff --git a/src/Managers/MCPServer.CoreManager.pas b/src/Managers/MCPServer.CoreManager.pas index f73f761..e7fe62c 100644 --- a/src/Managers/MCPServer.CoreManager.pas +++ b/src/Managers/MCPServer.CoreManager.pas @@ -6,38 +6,54 @@ interface System.SysUtils, System.JSON, System.Rtti, - System.DateUtils, MCPServer.Types, MCPServer.Settings, MCPServer.Logger; type - TMCPCoreManager = class(TInterfacedObject, IMCPCapabilityManager) + TMCPCoreManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPRegistryAware) private - FSessionID: string; FSettings: TMCPSettings; + [Weak] FManagerRegistry: IMCPManagerRegistry; + function GetSessionID: string; + function BuildServerInfo: TJSONObject; + function BuildCapabilities(Era: TMCPProtocolEra): TJSONObject; + function SupportedVersions: TJSONArray; + procedure LogClientInfo(const ClientInfo: TJSONValue); + procedure WarnAboutDeprecatedClientCapabilities(const Capabilities: TJSONValue); public constructor Create(ASettings: TMCPSettings); - + function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; - - function Initialize(const Params: TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure SetManagerRegistry(const Registry: IMCPManagerRegistry); + + function Initialize(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; + function Discover(const Context: IMCPRequestContext): TValue; function Ping: TValue; - - property SessionID: string read FSessionID; + + property SessionID: string read GetSessionID; + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; end; implementation +uses + MCPServer.Capabilities, + MCPServer.RequestContext; + +const + CACHE_SCOPE_PUBLIC = 'public'; + { TMCPCoreManager } constructor TMCPCoreManager.Create(ASettings: TMCPSettings); begin inherited Create; FSettings := ASettings; - FSessionID := ''; end; function TMCPCoreManager.GetCapabilityName: string; @@ -45,17 +61,34 @@ function TMCPCoreManager.GetCapabilityName: string; Result := 'core'; end; +function TMCPCoreManager.GetSessionID: string; +begin + Result := ''; +end; + +procedure TMCPCoreManager.SetManagerRegistry(const Registry: IMCPManagerRegistry); +begin + FManagerRegistry := Registry; +end; + function TMCPCoreManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'initialize') or + Result := (Method = 'initialize') or (Method = 'notifications/initialized') or - (Method = 'ping'); + (Method = 'ping') or + (Method = 'server/discover'); end; function TMCPCoreManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPCoreManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'initialize' then - Result := Initialize(Params) + Result := Initialize(Params, Context) else if Method = 'notifications/initialized' then begin TLogger.Info('MCP Initialized notification received'); @@ -63,75 +96,99 @@ function TMCPCoreManager.ExecuteMethod(const Method: string; const Params: TJSON end else if Method = 'ping' then Result := Ping + else if Method = 'server/discover' then + Result := Discover(Context) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; -function TMCPCoreManager.Initialize(const Params: TJSONObject): TValue; +function TMCPCoreManager.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('name', FSettings.ServerName); + Result.AddPair('version', FSettings.ServerVersion); + if FSettings.ServerTitle <> '' then + Result.AddPair('title', FSettings.ServerTitle); + if FSettings.ServerDescription <> '' then + Result.AddPair('description', FSettings.ServerDescription); + if FSettings.ServerWebsiteUrl <> '' then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPCoreManager.BuildCapabilities(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TMCPCapabilityBuilder.Build(FManagerRegistry, Era); +end; + +function TMCPCoreManager.SupportedVersions: TJSONArray; +begin + Result := TJSONArray.Create; + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Result.Add(Version); + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Result.Add(Version); +end; + +procedure TMCPCoreManager.LogClientInfo(const ClientInfo: TJSONValue); +begin + if not (ClientInfo is TJSONObject) then + Exit; + + var ClientName := TJSONObject(ClientInfo).GetValue('name'); + var ClientVersion := TJSONObject(ClientInfo).GetValue('version'); + if Assigned(ClientName) and Assigned(ClientVersion) then + TLogger.Info(Format('Client: %s v%s', [ClientName.Value, ClientVersion.Value])); +end; + +procedure TMCPCoreManager.WarnAboutDeprecatedClientCapabilities(const Capabilities: TJSONValue); +begin + if not (Capabilities is TJSONObject) then + Exit; + + for var Deprecated in ['roots', 'sampling'] do + if Assigned(TJSONObject(Capabilities).GetValue(Deprecated)) then + TLogger.Warning(Format('Client declares the %s capability; this server does not use it (deprecated in MCP 2026-07-28)', [Deprecated])); +end; + +function TMCPCoreManager.Initialize(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; var - Capabilities: TJSONObject; - ClientInfo: TJSONObject; - ClientName: TJSONValue; - ClientVersion: TJSONValue; - ResourcesCap: TJSONObject; - ResultJSON: TJSONObject; - ServerInfo: TJSONObject; - ToolsCap: TJSONObject; + Negotiated: string; begin TLogger.Info('MCP Initialize called'); - - if Assigned(Params) then - begin - ClientInfo := Params.GetValue('clientInfo') as TJSONObject; - if Assigned(ClientInfo) then + if Assigned(Context) then + Negotiated := Context.ProtocolVersion + else + begin + var Requested := ''; + if Assigned(Params) then begin - ClientName := ClientInfo.GetValue('name'); - ClientVersion := ClientInfo.GetValue('version'); - - if Assigned(ClientName) and Assigned(ClientVersion) then - TLogger.Info(Format('Client: %s v%s', [ClientName.Value, ClientVersion.Value])); + var RequestedValue := Params.GetValue('protocolVersion'); + if RequestedValue is TJSONString then + Requested := TJSONString(RequestedValue).Value; end; + Negotiated := NegotiateLegacyProtocolVersion(Requested); end; - - FSessionID := TGuid.NewGuid.ToString; - - ResultJSON := TJSONObject.Create; + + if Assigned(Params) then + begin + LogClientInfo(Params.GetValue('clientInfo')); + WarnAboutDeprecatedClientCapabilities(Params.GetValue('capabilities')); + end; + + var ResultJSON := TJSONObject.Create; try - ResultJSON.AddPair('protocolVersion', MCP_PROTOCOL_VERSION); - - Capabilities := TJSONObject.Create; - ResultJSON.AddPair('capabilities', Capabilities); - - ToolsCap := TJSONObject.Create; - Capabilities.AddPair('tools', ToolsCap); -{$IF COMPILERVERSION <= 29} - ToolsCap.AddPair('supportsProgress', TJSONFalse.Create); - ToolsCap.AddPair('supportsCancellation', TJSONFalse.Create); -{$ELSE} - ToolsCap.AddPair('supportsProgress', TJSONBool.Create(False)); - ToolsCap.AddPair('supportsCancellation', TJSONBool.Create(False)); -{$ENDIF} - - ResourcesCap := TJSONObject.Create; - Capabilities.AddPair('resources', ResourcesCap); -{$IF COMPILERVERSION <= 29} - ResourcesCap.AddPair('subscribe', TJSONFalse.Create); - ResourcesCap.AddPair('listChanged', TJSONFalse.Create); -{$ELSE} - ResourcesCap.AddPair('subscribe', TJSONBool.Create(False)); - ResourcesCap.AddPair('listChanged', TJSONBool.Create(False)); -{$ENDIF} - - ResultJSON.AddPair('sessionId', FSessionID); - - ServerInfo := TJSONObject.Create; - ResultJSON.AddPair('serverInfo', ServerInfo); - ServerInfo.AddPair('name', FSettings.ServerName); - ServerInfo.AddPair('version', FSettings.ServerVersion); - - TLogger.Info('Created new MCP session: ' + FSessionID); - + ResultJSON.AddPair('protocolVersion', Negotiated); + ResultJSON.AddPair('capabilities', BuildCapabilities(TMCPProtocolEra.Legacy)); + ResultJSON.AddPair('serverInfo', BuildServerInfo); + if FSettings.Instructions <> '' then + ResultJSON.AddPair('instructions', FSettings.Instructions); + + if Assigned(Context) and Assigned(Context.LegacySession) then + Context.LegacySession.ProtocolVersion := Negotiated; + + TLogger.Info('Negotiated protocol version ' + Negotiated); Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -139,14 +196,25 @@ function TMCPCoreManager.Initialize(const Params: TJSONObject): TValue; end; end; -function TMCPCoreManager.Ping: TValue; -var - ResultJSON: TJSONObject; +function TMCPCoreManager.Discover(const Context: IMCPRequestContext): TValue; begin - TLogger.Info('MCP Ping called'); - - ResultJSON := TJSONObject.Create; + TLogger.Info('MCP Discover called'); + + var ResultJSON := TJSONObject.Create; try + ResultJSON.AddPair('resultType', 'complete'); + ResultJSON.AddPair('supportedVersions', SupportedVersions); + ResultJSON.AddPair('capabilities', BuildCapabilities(TMCPProtocolEra.Modern)); + + var Meta := TJSONObject.Create; + ResultJSON.AddPair('_meta', Meta); + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); + + if FSettings.Instructions <> '' then + ResultJSON.AddPair('instructions', FSettings.Instructions); + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FSettings.DiscoverTtlMs)); + ResultJSON.AddPair('cacheScope', CACHE_SCOPE_PUBLIC); + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -154,4 +222,10 @@ function TMCPCoreManager.Ping: TValue; end; end; -end. \ No newline at end of file +function TMCPCoreManager.Ping: TValue; +begin + TLogger.Info('MCP Ping called'); + Result := TValue.From(TJSONObject.Create); +end; + +end. diff --git a/src/Managers/MCPServer.PromptsManager.pas b/src/Managers/MCPServer.PromptsManager.pas new file mode 100644 index 0000000..e9d32f4 --- /dev/null +++ b/src/Managers/MCPServer.PromptsManager.pas @@ -0,0 +1,325 @@ +unit MCPServer.PromptsManager; + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + System.JSON, + System.Rtti, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Logger, + MCPServer.Prompt.Base; + +type + TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) + strict private + FPrompts: TDictionary; + FOrder: TList; + FLock: TCriticalSection; + FListTtlMs: Integer; + FListCacheScope: string; + FChangeNotifier: IMCPSubscriptionHub; + procedure NotifyListChanged; + procedure RegisterPrompt(const Prompt: IMCPPrompt); + procedure RegisterBuiltInPrompts; + procedure CheckCursor(const Params: TJSONObject); + function CreatePromptJSON(const Prompt: IMCPPrompt): TJSONObject; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; + public + constructor Create; + destructor Destroy; override; + + procedure AddPrompt(const Prompt: IMCPPrompt); + procedure RemovePrompt(const Name: string); + function HasPrompt(const Name: string): Boolean; + function TryGetPrompt(const Name: string; out Prompt: IMCPPrompt): Boolean; + + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + + function ListPrompts: TValue; overload; + function ListPrompts(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + function GetPrompt(const Params: System.JSON.TJSONObject): TValue; overload; + function GetPrompt(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; + end; + +implementation + +uses + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Errors; + +{ TMCPPromptsManager } + +constructor TMCPPromptsManager.Create; +begin + inherited; + FLock := TCriticalSection.Create; + FPrompts := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; + RegisterBuiltInPrompts; +end; + +destructor TMCPPromptsManager.Destroy; +begin + FPrompts.Free; + FOrder.Free; + FLock.Free; + inherited; +end; + +function TMCPPromptsManager.GetCapabilityName: string; +begin + Result := 'prompts'; +end; + +function TMCPPromptsManager.HandlesMethod(const Method: string): Boolean; +begin + Result := (Method = 'prompts/list') or (Method = 'prompts/get'); +end; + +procedure TMCPPromptsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); + var Prompts := TJSONObject.Create; + Prompts.AddPair('listChanged', TJSONBool.Create(Announces)); + Capabilities.AddPair('prompts', Prompts); +end; + +function TMCPPromptsManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPPromptsManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPPromptsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = 'prompts/list' then + Result := ListPrompts(Params, EraOf(Context)) + else if Method = 'prompts/get' then + Result := GetPrompt(Params, EraOf(Context)) + else + raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); +end; + +procedure TMCPPromptsManager.RegisterPrompt(const Prompt: IMCPPrompt); +begin + FLock.Enter; + try + if not FPrompts.ContainsKey(Prompt.Name) then + FOrder.Add(Prompt.Name); + FPrompts.AddOrSetValue(Prompt.Name, Prompt); + finally + FLock.Leave; + end; +end; + +procedure TMCPPromptsManager.RemovePrompt(const Name: string); +begin + FLock.Enter; + try + if not FPrompts.ContainsKey(Name) then + Exit; + FPrompts.Remove(Name); + FOrder.Remove(Name); + finally + FLock.Leave; + end; + NotifyListChanged; +end; + +function TMCPPromptsManager.HasPrompt(const Name: string): Boolean; +var + Prompt: IMCPPrompt; +begin + Result := TryGetPrompt(Name, Prompt); +end; + +procedure TMCPPromptsManager.NotifyListChanged; +begin + if Assigned(FChangeNotifier) then + FChangeNotifier.PromptsListChanged; +end; + +procedure TMCPPromptsManager.RegisterBuiltInPrompts; +begin + for var PromptName in TMCPRegistry.GetPromptNames do + RegisterPrompt(TMCPRegistry.CreatePrompt(PromptName)); +end; + +procedure TMCPPromptsManager.AddPrompt(const Prompt: IMCPPrompt); +begin + RegisterPrompt(Prompt); + NotifyListChanged; +end; + +function TMCPPromptsManager.TryGetPrompt(const Name: string; out Prompt: IMCPPrompt): Boolean; +begin + FLock.Enter; + try + Result := FPrompts.TryGetValue(Name, Prompt); + finally + FLock.Leave; + end; +end; + +procedure TMCPPromptsManager.CheckCursor(const Params: TJSONObject); +begin + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +function TMCPPromptsManager.CreatePromptJSON(const Prompt: IMCPPrompt): TJSONObject; +var + Metadata: IMCPPromptMetadata; +begin + Result := TJSONObject.Create; + Result.AddPair('name', Prompt.Name); + if Prompt.Title <> Prompt.Name then + Result.AddPair('title', Prompt.Title); + if Prompt.Description <> '' then + Result.AddPair('description', Prompt.Description); + + var Arguments := Prompt.Arguments; + if Length(Arguments) > 0 then + begin + var ArgumentsArray := TJSONArray.Create; + Result.AddPair('arguments', ArgumentsArray); + for var Arg in Arguments do + begin + var ArgObject := TJSONObject.Create; + ArgumentsArray.AddElement(ArgObject); + ArgObject.AddPair('name', Arg.Name); + if Arg.Description <> '' then + ArgObject.AddPair('description', Arg.Description); + ArgObject.AddPair('required', TJSONBool.Create(Arg.Required)); + end; + end; + + if Supports(Prompt, IMCPPromptMetadata, Metadata) and Assigned(Metadata.Icons) then + Result.AddPair('icons', TJSONArray(Metadata.Icons.Clone)); +end; + +function TMCPPromptsManager.ListPrompts: TValue; +begin + Result := ListPrompts(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPPromptsManager.ListPrompts(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +begin + TLogger.Info('MCP ListPrompts called'); + CheckCursor(Params); + + var ResultJSON := TJSONObject.Create; + try + var PromptsArray := TJSONArray.Create; + ResultJSON.AddPair('prompts', PromptsArray); + FLock.Enter; + try + for var Name in FOrder do + begin + PromptsArray.AddElement(CreatePromptJSON(FPrompts[Name])); + end; + finally + FLock.Leave; + end; + + if Era = TMCPProtocolEra.Modern then + begin + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair('cacheScope', FListCacheScope); + end; + + Result := TValue.From(ResultJSON); + except + ResultJSON.Free; + raise; + end; +end; + +function TMCPPromptsManager.GetPrompt(const Params: System.JSON.TJSONObject): TValue; +begin + Result := GetPrompt(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPPromptsManager.GetPrompt(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +var + Prompt: IMCPPrompt; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.name is required'); + var NameValue := Params.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.name is required and must be a non-empty string'); + var PromptName := TJSONString(NameValue).Value; + + var ArgumentsValue := Params.GetValue('arguments'); + if Assigned(ArgumentsValue) and not (ArgumentsValue is TJSONObject) and not (ArgumentsValue is TJSONNull) then + raise EMCPError.InvalidParams('params.arguments must be an object'); + var OwnedArguments: TJSONObject := nil; + var Arguments: TJSONObject; + if ArgumentsValue is TJSONObject then + Arguments := TJSONObject(ArgumentsValue) + else + begin + OwnedArguments := TJSONObject.Create; + Arguments := OwnedArguments; + end; + + try + if not TryGetPrompt(PromptName, Prompt) then + raise EMCPError.UnknownPrompt(PromptName); + + TLogger.Info('MCP GetPrompt called for prompt: ' + PromptName); + + var Messages := TMCPPromptMessages.Create; + try + var Description: string; + try + Description := Prompt.Get(Arguments, Messages); + except + on E: EArgumentException do + raise EMCPError.InvalidParams('Invalid arguments: ' + E.Message); + end; + + var ResultJSON := TJSONObject.Create; + try + if Description <> '' then + ResultJSON.AddPair('description', Description); + ResultJSON.AddPair('messages', Messages.ToJson); + Result := TValue.From(ResultJSON); + except + ResultJSON.Free; + raise; + end; + finally + Messages.Free; + end; + finally + OwnedArguments.Free; + end; +end; + +end. diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 1c1f529..3f8c5d4 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -4,6 +4,7 @@ interface uses System.SysUtils, + System.SyncObjs, System.Classes, System.JSON, System.Rtti, @@ -13,41 +14,87 @@ interface MCPServer.Resource.Base; type - TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager) + TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) private FResources: TDictionary; + FOrder: TList; + FTemplates: TList; + FLock: TCriticalSection; + FChangeNotifier: IMCPSubscriptionHub; + FListTtlMs: Integer; + FListCacheScope: string; + procedure NotifyListChanged; procedure RegisterResource(const Resource: IMCPResource); procedure RegisterBuiltInResources; + procedure RegisterBuiltInResourceTemplates; + procedure CheckCursor(const Params: TJSONObject); + procedure AddListCacheHints(const ResultJSON: TJSONObject; Era: TMCPProtocolEra); + function CreateResourceJSON(const Resource: IMCPResource): TJSONObject; + function CreateResourceTemplateJSON(const Template: IMCPResourceTemplate): TJSONObject; + function CreateContentsItem(const Resource: IMCPResource): TJSONObject; + function FindResource(const URI: string): IMCPResource; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; public constructor Create; destructor Destroy; override; - + + procedure AddResource(const Resource: IMCPResource); + procedure RemoveResource(const URI: string); + procedure ResourceUpdated(const URI: string); + procedure AddResourceTemplate(const Template: IMCPResourceTemplate); + procedure RemoveResourceTemplate(const UriTemplate: string); + function TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; + function TryGetResourceTemplate(const UriTemplate: string; out Template: IMCPResourceTemplate): Boolean; + function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; - - function ListResources: TValue; - function ReadResource(const Params: System.JSON.TJSONObject): TValue; - function ListResourceTemplates: TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + + function ListResources: TValue; overload; + function ListResources(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + function ReadResource(const Params: System.JSON.TJSONObject): TValue; overload; + function ReadResource(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + function ListResourceTemplates: TValue; overload; + function ListResourceTemplates(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; end; implementation uses - MCPServer.Registration; + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Errors, + MCPServer.Mrtr, + MCPServer.ContentBlocks; { TMCPResourcesManager } constructor TMCPResourcesManager.Create; begin inherited; + FLock := TCriticalSection.Create; FResources := TDictionary.Create; + FOrder := TList.Create; + FTemplates := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; RegisterBuiltInResources; + RegisterBuiltInResourceTemplates; end; destructor TMCPResourcesManager.Destroy; begin FResources.Free; + FOrder.Free; + FTemplates.Free; + FLock.Free; inherited; end; @@ -58,62 +105,276 @@ function TMCPResourcesManager.GetCapabilityName: string; function TMCPResourcesManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'resources/list') or - (Method = 'resources/read') or + Result := (Method = 'resources/list') or + (Method = 'resources/read') or (Method = 'resources/templates/list'); end; +procedure TMCPResourcesManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); + var Resources := TJSONObject.Create; + Resources.AddPair('subscribe', TJSONBool.Create(Announces)); + Resources.AddPair('listChanged', TJSONBool.Create(Announces)); + Capabilities.AddPair('resources', Resources); +end; + +function TMCPResourcesManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + function TMCPResourcesManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPResourcesManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'resources/list' then - Result := ListResources + Result := ListResources(Params, EraOf(Context)) else if Method = 'resources/read' then - Result := ReadResource(Params) + Result := ReadResource(Params, EraOf(Context)) else if Method = 'resources/templates/list' then - Result := ListResourceTemplates + Result := ListResourceTemplates(Params, EraOf(Context)) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; procedure TMCPResourcesManager.RegisterResource(const Resource: IMCPResource); begin - FResources.Add(Resource.URI, Resource); + FLock.Enter; + try + if not FResources.ContainsKey(Resource.URI) then + FOrder.Add(Resource.URI); + FResources.AddOrSetValue(Resource.URI, Resource); + finally + FLock.Leave; + end; +end; + +procedure TMCPResourcesManager.RemoveResource(const URI: string); +begin + FLock.Enter; + try + if not FResources.ContainsKey(URI) then + Exit; + FResources.Remove(URI); + FOrder.Remove(URI); + finally + FLock.Leave; + end; + NotifyListChanged; +end; + +procedure TMCPResourcesManager.ResourceUpdated(const URI: string); +begin + if Assigned(FChangeNotifier) then + FChangeNotifier.ResourceUpdated(URI); +end; + +procedure TMCPResourcesManager.NotifyListChanged; +begin + if Assigned(FChangeNotifier) then + FChangeNotifier.ResourcesListChanged; end; procedure TMCPResourcesManager.RegisterBuiltInResources; +begin + for var ResourceURI in TMCPRegistry.GetResourceURIs do + RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); +end; + +procedure TMCPResourcesManager.RegisterBuiltInResourceTemplates; +begin + for var UriTemplate in TMCPRegistry.GetResourceTemplateURIs do + FTemplates.Add(TMCPRegistry.CreateResourceTemplate(UriTemplate)); +end; + +procedure TMCPResourcesManager.AddResource(const Resource: IMCPResource); +begin + RegisterResource(Resource); + NotifyListChanged; +end; + +procedure TMCPResourcesManager.RemoveResourceTemplate(const UriTemplate: string); +begin + var Removed := False; + FLock.Enter; + try + for var I := FTemplates.Count - 1 downto 0 do + begin + if FTemplates[I].UriTemplate = UriTemplate then + begin + FTemplates.Delete(I); + Removed := True; + end; + end; + finally + FLock.Leave; + end; + if Removed then + NotifyListChanged; +end; + +procedure TMCPResourcesManager.AddResourceTemplate(const Template: IMCPResourceTemplate); +begin + FLock.Enter; + try + FTemplates.Add(Template); + finally + FLock.Leave; + end; + NotifyListChanged; +end; + +function TMCPResourcesManager.TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; +begin + Result := FResources.TryGetValue(URI, Resource); +end; + +function TMCPResourcesManager.TryGetResourceTemplate(const UriTemplate: string; + out Template: IMCPResourceTemplate): Boolean; +begin + for var Candidate in FTemplates do + if Candidate.UriTemplate = UriTemplate then + begin + Template := Candidate; + Exit(True); + end; + Template := nil; + Result := False; +end; + +function TMCPResourcesManager.FindResource(const URI: string): IMCPResource; +var + Templates: TArray; +begin + FLock.Enter; + try + if FResources.TryGetValue(URI, Result) then + Exit; + Templates := FTemplates.ToArray; + finally + FLock.Leave; + end; + + var Vars := TMCPTemplateVars.Create; + try + for var Template in Templates do + begin + if Template.Matches(URI, Vars) then + Exit(Template.CreateResource(URI, Vars)); + end; + finally + Vars.Free; + end; + Result := nil; +end; + +procedure TMCPResourcesManager.CheckCursor(const Params: TJSONObject); +begin + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +procedure TMCPResourcesManager.AddListCacheHints(const ResultJSON: TJSONObject; Era: TMCPProtocolEra); +begin + if Era = TMCPProtocolEra.Modern then + begin + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair('cacheScope', FListCacheScope); + end; +end; + +function TMCPResourcesManager.CreateResourceJSON(const Resource: IMCPResource): TJSONObject; var - ResourceURI: string; + Metadata: IMCPResourceMetadata; begin - for ResourceURI in TMCPRegistry.GetResourceURIs do + Result := TJSONObject.Create; + Result.AddPair('uri', Resource.URI); + Result.AddPair('name', Resource.Name); + + if Supports(Resource, IMCPResourceMetadata, Metadata) then begin - RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); + if Metadata.Title <> '' then + Result.AddPair('title', Metadata.Title); + end; + if Resource.Description <> '' then + Result.AddPair('description', Resource.Description); + if Resource.MimeType <> '' then + Result.AddPair('mimeType', Resource.MimeType); + if Assigned(Metadata) then + begin + if Metadata.Size >= 0 then + Result.AddPair('size', TJSONNumber.Create(Metadata.Size)); + if Assigned(Metadata.Annotations) then + Result.AddPair('annotations', TJSONObject(Metadata.Annotations.Clone)); end; end; -function TMCPResourcesManager.ListResources: TValue; +function TMCPResourcesManager.CreateResourceTemplateJSON(const Template: IMCPResourceTemplate): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('uriTemplate', Template.UriTemplate); + Result.AddPair('name', Template.Name); + if Template.Title <> '' then + Result.AddPair('title', Template.Title); + if Template.Description <> '' then + Result.AddPair('description', Template.Description); + if Template.MimeType <> '' then + Result.AddPair('mimeType', Template.MimeType); +end; + +function TMCPResourcesManager.CreateContentsItem(const Resource: IMCPResource): TJSONObject; var - Resource: IMCPResource; - ResourcesArray: TJSONArray; - ResourceObj: TJSONObject; - ResultJSON: TJSONObject; + Binary: IMCPBinaryResource; +begin + Result := TJSONObject.Create; + try + Result.AddPair('uri', Resource.URI); + if Resource.MimeType <> '' then + Result.AddPair('mimeType', Resource.MimeType); + + if Supports(Resource, IMCPBinaryResource, Binary) then + Result.AddPair('blob', EncodeBase64Blob(Binary.ReadBinary)) + else + Result.AddPair('text', Resource.Read); + except + Result.Free; + raise; + end; +end; + +function TMCPResourcesManager.ListResources: TValue; +begin + Result := ListResources(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPResourcesManager.ListResources(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; begin TLogger.Info('MCP ListResources called'); + CheckCursor(Params); - ResultJSON := TJSONObject.Create; + var ResultJSON := TJSONObject.Create; try - ResourcesArray := TJSONArray.Create; + var ResourcesArray := TJSONArray.Create; ResultJSON.AddPair('resources', ResourcesArray); - - for Resource in FResources.Values do - begin - ResourceObj := TJSONObject.Create; - ResourceObj.AddPair('uri', Resource.URI); - ResourceObj.AddPair('name', Resource.Name); - ResourceObj.AddPair('description', Resource.Description); - ResourceObj.AddPair('mimeType', Resource.MimeType); - ResourcesArray.AddElement(ResourceObj); + FLock.Enter; + try + for var URI in FOrder do + begin + ResourcesArray.AddElement(CreateResourceJSON(FResources[URI])); + end; + finally + FLock.Leave; end; - + AddListCacheHints(ResultJSON, Era); + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -122,53 +383,58 @@ function TMCPResourcesManager.ListResources: TValue; end; function TMCPResourcesManager.ReadResource(const Params: System.JSON.TJSONObject): TValue; +begin + Result := ReadResource(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPResourcesManager.ReadResource(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; var - ContentItem: TJSONObject; - ContentsArray: TJSONArray; Resource: IMCPResource; - ResourceText: string; - ResultJSON: TJSONObject; - URI: string; - URIValue: TJSONValue; -begin - URIValue := Params.GetValue('uri'); - if Assigned(URIValue) then - URI := URIValue.Value - else - URI := ''; + Cacheable: IMCPCacheableResource; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.uri is required'); + var URIValue := Params.GetValue('uri'); + if not (URIValue is TJSONString) or (TJSONString(URIValue).Value = '') then + raise EMCPError.InvalidParams('params.uri is required and must be a non-empty string'); + var URI := TJSONString(URIValue).Value; TLogger.Info('MCP ReadResource called for URI: ' + URI); - ResultJSON := TJSONObject.Create; + Resource := FindResource(URI); + if not Assigned(Resource) then + raise EMCPError.ResourceNotFound(URI, Era); + + var ResultJSON := TJSONObject.Create; try - ContentsArray := TJSONArray.Create; + var ContentsArray := TJSONArray.Create; ResultJSON.AddPair('contents', ContentsArray); + try + ContentsArray.AddElement(CreateContentsItem(Resource)); + except + on E: EMCPError do + raise; + on E: EMCPRequestCancelled do + raise; + on E: EMCPInputRequired do + raise; + on E: Exception do + raise EMCPError.InternalError('Error reading resource: ' + E.Message); + end; - ContentItem := TJSONObject.Create; - ContentsArray.AddElement(ContentItem); - - if FResources.TryGetValue(URI, Resource) then + if Era = TMCPProtocolEra.Modern then begin - ContentItem.AddPair('uri', Resource.URI); - ContentItem.AddPair('mimeType', Resource.MimeType); - - try - ResourceText := Resource.Read; - ContentItem.AddPair('text', ResourceText); - except - on E: Exception do - begin - ContentItem.AddPair('text', 'Error reading resource: ' + E.Message); - end; + var TtlMs := 0; + var CacheScope := MCP_CACHE_SCOPE_PRIVATE; + if Supports(Resource, IMCPCacheableResource, Cacheable) then + begin + TtlMs := Cacheable.TtlMs; + CacheScope := Cacheable.CacheScope; end; - end - else - begin - ContentItem.AddPair('uri', URI); - ContentItem.AddPair('mimeType', 'text/plain'); - ContentItem.AddPair('text', 'Error: Resource not found: ' + URI); + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(TtlMs)); + ResultJSON.AddPair('cacheScope', CacheScope); end; - + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -177,19 +443,29 @@ function TMCPResourcesManager.ReadResource(const Params: System.JSON.TJSONObject end; function TMCPResourcesManager.ListResourceTemplates: TValue; -var - ResourceTemplatesArray: TJSONArray; - ResultJSON: TJSONObject; +begin + Result := ListResourceTemplates(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPResourcesManager.ListResourceTemplates(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; begin TLogger.Info('MCP ListResourceTemplates called'); - - ResultJSON := TJSONObject.Create; + CheckCursor(Params); + + var ResultJSON := TJSONObject.Create; try - ResourceTemplatesArray := TJSONArray.Create; - ResultJSON.AddPair('resourceTemplates', ResourceTemplatesArray); - - // Return empty array since this server doesn't support resource templates - + var TemplatesArray := TJSONArray.Create; + ResultJSON.AddPair('resourceTemplates', TemplatesArray); + FLock.Enter; + try + for var Template in FTemplates do + begin + TemplatesArray.AddElement(CreateResourceTemplateJSON(Template)); + end; + finally + FLock.Leave; + end; + AddListCacheHints(ResultJSON, Era); Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -197,4 +473,4 @@ function TMCPResourcesManager.ListResourceTemplates: TValue; end; end; -end. \ No newline at end of file +end. diff --git a/src/Managers/MCPServer.SubscriptionsManager.pas b/src/Managers/MCPServer.SubscriptionsManager.pas new file mode 100644 index 0000000..4333c00 --- /dev/null +++ b/src/Managers/MCPServer.SubscriptionsManager.pas @@ -0,0 +1,405 @@ +unit MCPServer.SubscriptionsManager; + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + System.JSON, + System.Rtti, + System.Generics.Collections, + MCPServer.Types; + +type + TMCPSubscriptionFilter = record + ToolsListChanged: Boolean; + PromptsListChanged: Boolean; + ResourcesListChanged: Boolean; + ResourceSubscriptions: TArray; + class function FromJson(const Notifications: TJSONValue): TMCPSubscriptionFilter; static; + function ToJson: TJSONObject; + function WantsResource(const Uri: string): Boolean; + function Wants(const Method, Uri: string): Boolean; + end; + + IMCPSubscription = interface + ['{5A1C7E2B-9D3F-4B6A-8C0E-2F1D3B5A7C9E}'] + function GetFilter: TMCPSubscriptionFilter; + function GetSink: IMCPMessageSink; + function GetClosed: TEvent; + procedure Close; + function Notification(const Method: string): TJSONObject; + property Filter: TMCPSubscriptionFilter read GetFilter; + property Sink: IMCPMessageSink read GetSink; + property Closed: TEvent read GetClosed; + end; + + TMCPSubscriptionsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, + IMCPSubscriptionHub) + public + const DEFAULT_KEEP_ALIVE_INTERVAL_MS = 15000; + const POLL_INTERVAL_MS = 250; + strict private + FLock: TCriticalSection; + FSubscriptions: TList; + FKeepAliveIntervalMs: Integer; + function Snapshot: TArray; + procedure Deliver(const Method, Uri: string); + function Listen(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; + procedure Acknowledge(const Subscription: IMCPSubscription); + function CompletionResult(const Subscription: IMCPSubscription): TJSONObject; + public + constructor Create; + destructor Destroy; override; + + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + + property KeepAliveIntervalMs: Integer read FKeepAliveIntervalMs write FKeepAliveIntervalMs; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.Logger; + +const + JSONRPC_VERSION = '2.0'; + FILTER_TOOLS = 'toolsListChanged'; + FILTER_PROMPTS = 'promptsListChanged'; + FILTER_RESOURCES = 'resourcesListChanged'; + FILTER_RESOURCE_SUBSCRIPTIONS = 'resourceSubscriptions'; + PARAM_NOTIFICATIONS = 'notifications'; + +type + TMCPSubscription = class(TInterfacedObject, IMCPSubscription) + strict private + FId: TJSONValue; + FFilter: TMCPSubscriptionFilter; + FSink: IMCPMessageSink; + FClosed: TEvent; + public + constructor Create(const Id: TJSONValue; const Filter: TMCPSubscriptionFilter; const Sink: IMCPMessageSink); + destructor Destroy; override; + function GetFilter: TMCPSubscriptionFilter; + function GetSink: IMCPMessageSink; + function GetClosed: TEvent; + procedure Close; + function Notification(const Method: string): TJSONObject; + end; + +{ TMCPSubscriptionFilter } + +class function TMCPSubscriptionFilter.FromJson(const Notifications: TJSONValue): TMCPSubscriptionFilter; +begin + Result := Default(TMCPSubscriptionFilter); + if not (Notifications is TJSONObject) then + Exit; + + var Filter := TJSONObject(Notifications); + Result.ToolsListChanged := Filter.GetValue(FILTER_TOOLS) is TJSONTrue; + Result.PromptsListChanged := Filter.GetValue(FILTER_PROMPTS) is TJSONTrue; + Result.ResourcesListChanged := Filter.GetValue(FILTER_RESOURCES) is TJSONTrue; + + var Uris := Filter.GetValue(FILTER_RESOURCE_SUBSCRIPTIONS); + if Uris is TJSONArray then + begin + for var Item in TJSONArray(Uris) do + begin + if IsJsonString(Item) and (TJSONString(Item).Value <> '') then + Result.ResourceSubscriptions := Result.ResourceSubscriptions + [TJSONString(Item).Value]; + end; + end; +end; + +function TMCPSubscriptionFilter.ToJson: TJSONObject; +begin + Result := TJSONObject.Create; + if ToolsListChanged then + Result.AddPair(FILTER_TOOLS, TJSONBool.Create(True)); + if PromptsListChanged then + Result.AddPair(FILTER_PROMPTS, TJSONBool.Create(True)); + if ResourcesListChanged then + Result.AddPair(FILTER_RESOURCES, TJSONBool.Create(True)); + if Length(ResourceSubscriptions) > 0 then + begin + var Uris := TJSONArray.Create; + Result.AddPair(FILTER_RESOURCE_SUBSCRIPTIONS, Uris); + for var Uri in ResourceSubscriptions do + begin + Uris.Add(Uri); + end; + end; +end; + +function TMCPSubscriptionFilter.WantsResource(const Uri: string): Boolean; +begin + for var Subscribed in ResourceSubscriptions do + begin + if Subscribed = Uri then + Exit(True); + end; + Result := False; +end; + +function TMCPSubscriptionFilter.Wants(const Method, Uri: string): Boolean; +begin + if Method = MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED then + Result := ToolsListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED then + Result := PromptsListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED then + Result := ResourcesListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED then + Result := WantsResource(Uri) + else + Result := False; +end; + +{ TMCPSubscription } + +constructor TMCPSubscription.Create(const Id: TJSONValue; const Filter: TMCPSubscriptionFilter; + const Sink: IMCPMessageSink); +begin + inherited Create; + FId := TJSONValue(Id.Clone); + FFilter := Filter; + FSink := Sink; + FClosed := TEvent.Create(nil, True, False, ''); +end; + +destructor TMCPSubscription.Destroy; +begin + FClosed.Free; + FId.Free; + inherited; +end; + +function TMCPSubscription.GetFilter: TMCPSubscriptionFilter; +begin + Result := FFilter; +end; + +function TMCPSubscription.GetSink: IMCPMessageSink; +begin + Result := FSink; +end; + +function TMCPSubscription.GetClosed: TEvent; +begin + Result := FClosed; +end; + +procedure TMCPSubscription.Close; +begin + FClosed.SetEvent; +end; + +function TMCPSubscription.Notification(const Method: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('jsonrpc', JSONRPC_VERSION); + Result.AddPair('method', Method); + var Params := TJSONObject.Create; + Result.AddPair('params', Params); + var Meta := TJSONObject.Create; + Params.AddPair('_meta', Meta); + Meta.AddPair(MCP_META_SUBSCRIPTION_ID, TJSONValue(FId.Clone)); +end; + +{ TMCPSubscriptionsManager } + +constructor TMCPSubscriptionsManager.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FSubscriptions := TList.Create; + FKeepAliveIntervalMs := DEFAULT_KEEP_ALIVE_INTERVAL_MS; +end; + +destructor TMCPSubscriptionsManager.Destroy; +begin + CloseAll('subscriptions manager destroyed'); + FSubscriptions.Free; + FLock.Free; + inherited; +end; + +function TMCPSubscriptionsManager.GetCapabilityName: string; +begin + Result := 'subscriptions'; +end; + +function TMCPSubscriptionsManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = MCP_METHOD_SUBSCRIPTIONS_LISTEN; +end; + +function TMCPSubscriptionsManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, nil); +end; + +function TMCPSubscriptionsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method <> MCP_METHOD_SUBSCRIPTIONS_LISTEN then + raise EMCPError.MethodNotFound(Method); + Result := Listen(Params, Context); +end; + +function TMCPSubscriptionsManager.Snapshot: TArray; +begin + FLock.Enter; + try + Result := FSubscriptions.ToArray; + finally + FLock.Leave; + end; +end; + +procedure TMCPSubscriptionsManager.Acknowledge(const Subscription: IMCPSubscription); +begin + var Notification := Subscription.Notification(MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED); + try + TJSONObject(Notification.GetValue('params')).AddPair(PARAM_NOTIFICATIONS, Subscription.Filter.ToJson); + Subscription.Sink.Send(Notification.ToJSON); + finally + Notification.Free; + end; +end; + +function TMCPSubscriptionsManager.CompletionResult(const Subscription: IMCPSubscription): TJSONObject; +begin + var Notification := Subscription.Notification(''); + try + Result := TJSONObject.Create; + Result.AddPair('_meta', TJSONObject(Notification.FindValue('params._meta').Clone)); + finally + Notification.Free; + end; +end; + +function TMCPSubscriptionsManager.Listen(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; +var + KeepAlive: IMCPKeepAlive; +begin + if not Assigned(Context) or not Assigned(Context.Sink) then + raise EMCPError.InvalidRequest(Format( + '%s needs a response stream: accept text/event-stream or use stdio', [MCP_METHOD_SUBSCRIPTIONS_LISTEN])); + + var Notifications: TJSONValue := nil; + if Assigned(Params) then + Notifications := Params.GetValue(PARAM_NOTIFICATIONS); + if Assigned(Notifications) and not (Notifications is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s must be an object', [PARAM_NOTIFICATIONS])); + + var Id := Context.RequestId.ToJson; + var Subscription: IMCPSubscription; + try + Subscription := TMCPSubscription.Create(Id, TMCPSubscriptionFilter.FromJson(Notifications), Context.Sink); + finally + Id.Free; + end; + + FLock.Enter; + try + FSubscriptions.Add(Subscription); + finally + FLock.Leave; + end; + try + Acknowledge(Subscription); + TLogger.Info(Format('Subscription %s opened', [Context.RequestId.AsText])); + + Supports(Context.Sink, IMCPKeepAlive, KeepAlive); + var SinceKeepAlive := 0; + while not Context.IsCancelled and (Subscription.Closed.WaitFor(POLL_INTERVAL_MS) = TWaitResult.wrTimeout) do + begin + Inc(SinceKeepAlive, POLL_INTERVAL_MS); + if Assigned(KeepAlive) and (SinceKeepAlive >= FKeepAliveIntervalMs) then + begin + SinceKeepAlive := 0; + KeepAlive.KeepAlive; + end; + end; + finally + FLock.Enter; + try + FSubscriptions.Remove(Subscription); + finally + FLock.Leave; + end; + end; + + TLogger.Info(Format('Subscription %s closed', [Context.RequestId.AsText])); + Result := TValue.From(CompletionResult(Subscription)); +end; + +procedure TMCPSubscriptionsManager.Deliver(const Method, Uri: string); +begin + for var Subscription in Snapshot do + begin + if not Subscription.Filter.Wants(Method, Uri) then + Continue; + + var Notification := Subscription.Notification(Method); + try + if Uri <> '' then + TJSONObject(Notification.GetValue('params')).AddPair('uri', Uri); + Subscription.Sink.Send(Notification.ToJSON); + finally + Notification.Free; + end; + end; +end; + +procedure TMCPSubscriptionsManager.ToolsListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.PromptsListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.ResourcesListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.ResourceUpdated(const Uri: string); +begin + Deliver(MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED, Uri); +end; + +procedure TMCPSubscriptionsManager.CloseAll(const Reason: string); +begin + var Open := Snapshot; + if Length(Open) > 0 then + TLogger.Info(Format('Closing %d subscription(s): %s', [Length(Open), Reason])); + for var Subscription in Open do + begin + Subscription.Close; + end; +end; + +function TMCPSubscriptionsManager.ActiveCount: Integer; +begin + Result := Integer(Length(Snapshot)); +end; + +end. diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index da937bb..407d468 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -5,6 +5,7 @@ interface uses System.SysUtils, System.Classes, + System.SyncObjs, System.JSON, System.Rtti, System.Generics.Collections, @@ -13,46 +14,105 @@ interface MCPServer.Tool.Base; type - TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager) + TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) strict private - function ExtractToolNameAndArguments(const Params: System.JSON.TJSONObject; out ToolName: string; out Arguments: TJSONObject): Boolean; - function ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject): TValue; - function BuildToolCallResponse(const ResultValue: TValue): TJSONObject; - function BuildToolListResponse: TJSONObject; + FTools: TDictionary; + FOrder: TList; + FLock: TCriticalSection; + FListTtlMs: Integer; + FListCacheScope: string; + FChangeNotifier: IMCPSubscriptionHub; + function TryGetTool(const Name: string; out Tool: IMCPTool): Boolean; + procedure NotifyListChanged; + function ErrorResult(const Message: string; Era: TMCPProtocolEra): TJSONObject; + function ResultToJson(const ResultValue: TValue; Era: TMCPProtocolEra): TJSONObject; + function ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject; Era: TMCPProtocolEra): TJSONObject; + function BuildToolListResponse(Era: TMCPProtocolEra): TJSONObject; function CreateToolJSON(const Tool: IMCPTool): TJSONObject; + procedure CheckCursor(const Params: TJSONObject); + procedure ValidateToolName(const Name: string); + procedure CheckRequiredScopes(const Tool: IMCPTool); + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; private - FTools: TDictionary; procedure RegisterTool(const Tool: IMCPTool); procedure RegisterBuiltInTools; public constructor Create; destructor Destroy; override; - + + procedure AddTool(const Tool: IMCPTool); + procedure RemoveTool(const Name: string); + function HasTool(const Name: string): Boolean; + function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; - - function ListTools: TValue; - function CallTool(const Params: System.JSON.TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + + function ListTools: TValue; overload; + function ListTools(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + function CallTool(const Params: System.JSON.TJSONObject): TValue; overload; + function CallTool(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; end; implementation uses - MCPServer.Registration; + System.RegularExpressions, + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Authorization, + MCPServer.Errors, + MCPServer.Mrtr, + MCPServer.Tool.Result, + MCPServer.Schema.Validator; + +const + TOOL_NAME_PATTERN = '^[A-Za-z0-9_.\-]{1,128}$'; + +{$IFDEF DEBUG} +procedure WarnIfStructuredContentMismatchesSchema(const Tool: IMCPTool; const Result: TJSONObject); +begin + var OutputSchema := Tool.OutputSchema; + try + var StructuredContent := Result.GetValue('structuredContent'); + if not Assigned(OutputSchema) or not Assigned(StructuredContent) then + Exit; + + var Errors: TArray; + if not TMCPSchemaValidator.Validate(OutputSchema, StructuredContent, Errors) then + TLogger.Warning(Format('Tool "%s" structuredContent does not match its outputSchema: %s', + [Tool.Name, string.Join('; ', Errors)])); + finally + OutputSchema.Free; + end; +end; +{$ENDIF} { TMCPToolsManager } constructor TMCPToolsManager.Create; begin inherited; + FLock := TCriticalSection.Create; FTools := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; RegisterBuiltInTools; end; destructor TMCPToolsManager.Destroy; begin FTools.Free; + FOrder.Free; + FLock.Free; inherited; end; @@ -66,126 +126,227 @@ function TMCPToolsManager.HandlesMethod(const Method: string): Boolean; Result := (Method = 'tools/list') or (Method = 'tools/call'); end; +procedure TMCPToolsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); + var Tools := TJSONObject.Create; + Tools.AddPair('listChanged', TJSONBool.Create(Announces)); + Capabilities.AddPair('tools', Tools); +end; + +function TMCPToolsManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + function TMCPToolsManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPToolsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'tools/list' then - Result := ListTools + Result := ListTools(Params, EraOf(Context)) else if Method = 'tools/call' then - Result := CallTool(Params) + Result := CallTool(Params, EraOf(Context)) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; +procedure TMCPToolsManager.CheckRequiredScopes(const Tool: IMCPTool); +begin + var Context := TMCPRequestContext.Current; + var RttiContext := TRttiContext.Create; + try + var ToolType := RttiContext.GetType((Tool as TObject).ClassType); + for var Attribute in ToolType.GetAttributes do + begin + if not (Attribute is RequiresScopeAttribute) then + Continue; + var Scope := RequiresScopeAttribute(Attribute).Scope; + var Granted := Assigned(Context) and Context.HasScope(Scope); + if not Granted then + raise EMCPError.InsufficientScope(Scope); + end; + finally + RttiContext.Free; + end; +end; + +procedure TMCPToolsManager.ValidateToolName(const Name: string); +begin + if not TRegEx.IsMatch(Name, TOOL_NAME_PATTERN) then + TLogger.Warning(Format('Tool name "%s" is outside the recommended form (1 to 128 characters from A-Z, a-z, 0-9, _, - and .)', [Name])); +end; + procedure TMCPToolsManager.RegisterTool(const Tool: IMCPTool); begin - FTools.Add(Tool.Name, Tool); + ValidateToolName(Tool.Name); + FLock.Enter; + try + if not FTools.ContainsKey(Tool.Name) then + FOrder.Add(Tool.Name); + FTools.AddOrSetValue(Tool.Name, Tool); + finally + FLock.Leave; + end; end; -procedure TMCPToolsManager.RegisterBuiltInTools; -var - Tool: IMCPTool; - ToolName: string; +function TMCPToolsManager.TryGetTool(const Name: string; out Tool: IMCPTool): Boolean; begin - for ToolName in TMCPRegistry.GetToolNames do - begin - Tool := TMCPRegistry.CreateTool(ToolName); - RegisterTool(Tool); + FLock.Enter; + try + Result := FTools.TryGetValue(Name, Tool); + finally + FLock.Leave; end; end; -function TMCPToolsManager.ExtractToolNameAndArguments(const Params: System.JSON.TJSONObject; out ToolName: string; out Arguments: TJSONObject): Boolean; +function TMCPToolsManager.HasTool(const Name: string): Boolean; var - ArgsValue: TJSONValue; - NameValue: TJSONValue; + Tool: IMCPTool; begin - Result := False; - ToolName := ''; - Arguments := nil; - - if not Assigned(Params) then - Exit; - - NameValue := Params.GetValue('name'); - if Assigned(NameValue) then - begin - ToolName := NameValue.Value; - Result := ToolName <> ''; + Result := TryGetTool(Name, Tool); +end; + +procedure TMCPToolsManager.RemoveTool(const Name: string); +begin + FLock.Enter; + try + if not FTools.ContainsKey(Name) then + Exit; + FTools.Remove(Name); + FOrder.Remove(Name); + finally + FLock.Leave; end; - - ArgsValue := Params.GetValue('arguments'); - if Assigned(ArgsValue) and (ArgsValue is TJSONObject) then - Arguments := ArgsValue as TJSONObject; + NotifyListChanged; +end; + +procedure TMCPToolsManager.NotifyListChanged; +begin + if Assigned(FChangeNotifier) then + FChangeNotifier.ToolsListChanged; +end; + +procedure TMCPToolsManager.RegisterBuiltInTools; +begin + for var ToolName in TMCPRegistry.GetToolNames do + RegisterTool(TMCPRegistry.CreateTool(ToolName)); +end; + +procedure TMCPToolsManager.AddTool(const Tool: IMCPTool); +begin + RegisterTool(Tool); + NotifyListChanged; +end; + +procedure TMCPToolsManager.CheckCursor(const Params: TJSONObject); +begin + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); end; -function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject): TValue; +function TMCPToolsManager.ErrorResult(const Message: string; Era: TMCPProtocolEra): TJSONObject; begin + var ToolResult := TMCPToolResult.Error(Message); try - Result := Tool.Execute(Arguments); - except - on E: Exception do - Result := 'Error executing tool: ' + E.Message; + Result := ToolResult.ToJson(Era); + finally + ToolResult.Free; end; end; -function TMCPToolsManager.BuildToolCallResponse(const ResultValue: TValue): TJSONObject; -var - ContentArray: TJSONArray; - ContentItem: TJSONObject; - ErrorValue: TJSONValue; - HasError: Boolean; - JsonResult: TJSONObject; - TextValue: string; +function TMCPToolsManager.ResultToJson(const ResultValue: TValue; Era: TMCPProtocolEra): TJSONObject; begin - Result := TJSONObject.Create; + if ResultValue.IsType then + begin + var ToolResult := ResultValue.AsType; + try + Exit(ToolResult.ToJson(Era)); + finally + ToolResult.Free; + end; + end; if ResultValue.IsType then begin - // The tool already produced a content array (e.g. text plus an image item); - // take ownership so it is passed through verbatim and freed with the - // response (no clone, no leak of the original array). + Result := TJSONObject.Create; Result.AddPair('content', ResultValue.AsType); - end - else if ResultValue.IsType then - begin - TextValue := ResultValue.AsString; - HasError := TextValue.StartsWith('Error:') or TextValue.StartsWith('Error executing tool:'); - - ContentArray := TJSONArray.Create; - Result.AddPair('content', ContentArray); - - ContentItem := TJSONObject.Create; - ContentArray.AddElement(ContentItem); - ContentItem.AddPair('type', 'text'); - ContentItem.AddPair('text', TextValue); - - if HasError then -{$IF COMPILERVERSION <= 29} - Result.AddPair('isError', TJSONTrue.Create); -{$ELSE} - Result.AddPair('isError', TJSONBool.Create(True)); -{$ENDIF} - end - else if ResultValue.IsType then + Exit; + end; + + var ToolResult := TMCPToolResult.Create; + try + if ResultValue.IsType then + begin + var Text := ResultValue.AsString; + ToolResult.AddText(Text); + ToolResult.IsError := Text.StartsWith('Error:') or Text.StartsWith('Error executing tool:'); + end + else if ResultValue.IsType then + begin + var Structured := ResultValue.AsType; + ToolResult.SetStructuredContent(Structured); + var ErrorValue := Structured.GetValue('error'); + ToolResult.IsError := Assigned(ErrorValue) and (ErrorValue.Value <> ''); + end + else if not ResultValue.IsEmpty then + ToolResult.AddText(ResultValue.ToString); + + Result := ToolResult.ToJson(Era); + finally + ToolResult.Free; + end; +end; + +function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject; + Era: TMCPProtocolEra): TJSONObject; +var + ResultValue: TValue; +begin + var OwnedArguments: TJSONObject := nil; + var EffectiveArguments := Arguments; + if not Assigned(EffectiveArguments) then begin - JsonResult := ResultValue.AsType; - Result.AddPair('structuredContent', TJSONObject(JsonResult.Clone)); - - ErrorValue := JsonResult.GetValue('error'); - HasError := Assigned(ErrorValue) and (ErrorValue.Value <> ''); - if HasError then -{$IF COMPILERVERSION <= 29} - Result.AddPair('isError', TJSONTrue.Create); -{$ELSE} - Result.AddPair('isError', TJSONBool.Create(True)); -{$ENDIF} + OwnedArguments := TJSONObject.Create; + EffectiveArguments := OwnedArguments; end; + try + try + ResultValue := Tool.Execute(EffectiveArguments); + except + on E: EMCPToolError do + Exit(ErrorResult(E.Message, Era)); + on E: EArgumentException do + Exit(ErrorResult('Invalid arguments: ' + E.Message, Era)); + on E: EMCPError do + raise; + on E: EMCPRequestCancelled do + raise; + on E: EMCPInputRequired do + raise; + on E: Exception do + Exit(ErrorResult('Error executing tool: ' + E.Message, Era)); + end; + Result := ResultToJson(ResultValue, Era); + {$IFDEF DEBUG} + WarnIfStructuredContentMismatchesSchema(Tool, Result); + {$ENDIF} + finally + OwnedArguments.Free; + end; end; function TMCPToolsManager.CreateToolJSON(const Tool: IMCPTool): TJSONObject; var - Schema: TJSONObject; - SchemaClone: TJSONObject; + Metadata: IMCPToolMetadata; begin Result := TJSONObject.Create; Result.AddPair('name', Tool.Name); @@ -193,67 +354,88 @@ function TMCPToolsManager.CreateToolJSON(const Tool: IMCPTool): TJSONObject; Result.AddPair('title', Tool.Title); Result.AddPair('description', Tool.Description); - Schema := Tool.InputSchema; + var Schema := Tool.InputSchema; if Assigned(Schema) then - begin - SchemaClone := TJSONObject.ParseJSONValue(Schema.ToJSON) as TJSONObject; - Result.AddPair('inputSchema', SchemaClone); - Schema.Free; - end; + Result.AddPair('inputSchema', Schema); + Schema := Tool.OutputSchema; if Assigned(Schema) then + Result.AddPair('outputSchema', Schema); + + if Supports(Tool, IMCPToolMetadata, Metadata) then begin - SchemaClone := TJSONObject.ParseJSONValue(Schema.ToJSON) as TJSONObject; - Result.AddPair('outputSchema', SchemaClone); - Schema.Free; + if Assigned(Metadata.Annotations) then + Result.AddPair('annotations', TJSONObject(Metadata.Annotations.Clone)); + if Assigned(Metadata.Icons) then + Result.AddPair('icons', TJSONArray(Metadata.Icons.Clone)); end; - end; -function TMCPToolsManager.BuildToolListResponse: TJSONObject; -var - Tool: IMCPTool; - ToolsArray: TJSONArray; - ToolJSON: TJSONObject; +function TMCPToolsManager.BuildToolListResponse(Era: TMCPProtocolEra): TJSONObject; begin Result := TJSONObject.Create; - ToolsArray := TJSONArray.Create; + var ToolsArray := TJSONArray.Create; Result.AddPair('tools', ToolsArray); - for Tool in FTools.Values do + FLock.Enter; + try + for var Name in FOrder do + begin + ToolsArray.AddElement(CreateToolJSON(FTools[Name])); + end; + finally + FLock.Leave; + end; + + if Era = TMCPProtocolEra.Modern then begin - ToolJSON := CreateToolJSON(Tool); - ToolsArray.AddElement(ToolJSON); + Result.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + Result.AddPair('cacheScope', FListCacheScope); end; end; +function TMCPToolsManager.ListTools: TValue; +begin + Result := ListTools(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPToolsManager.ListTools(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +begin + TLogger.Info('MCP ListTools called'); + CheckCursor(Params); + Result := TValue.From(BuildToolListResponse(Era)); +end; + function TMCPToolsManager.CallTool(const Params: System.JSON.TJSONObject): TValue; +begin + Result := CallTool(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPToolsManager.CallTool(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; var - Arguments: TJSONObject; - ResultValue: TValue; Tool: IMCPTool; - ToolName: string; begin - if not ExtractToolNameAndArguments(Params, ToolName, Arguments) then - begin - Result := TValue.From(BuildToolCallResponse('Error: Invalid tool parameters')); - Exit; - end; + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.name is required'); - TLogger.Info('MCP CallTool called for tool: ' + ToolName); + var NameValue := Params.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.name is required and must be a non-empty string'); + var ToolName := TJSONString(NameValue).Value; - if FTools.TryGetValue(ToolName, Tool) then - resultValue := ExecuteTool(Tool, Arguments) - else - ResultValue := TValue.From('Error: Tool not found: ' + ToolName); - - Result := TValue.From(BuildToolCallResponse(ResultValue)); -end; + var ArgumentsValue := Params.GetValue('arguments'); + if Assigned(ArgumentsValue) and not (ArgumentsValue is TJSONObject) and not (ArgumentsValue is TJSONNull) then + raise EMCPError.InvalidParams('params.arguments must be an object'); + var Arguments: TJSONObject := nil; + if ArgumentsValue is TJSONObject then + Arguments := TJSONObject(ArgumentsValue); -function TMCPToolsManager.ListTools: TValue; -begin - TLogger.Info('MCP ListTools called'); - Result := TValue.From(BuildToolListResponse); + if not TryGetTool(ToolName, Tool) then + raise EMCPError.UnknownTool(ToolName); + CheckRequiredScopes(Tool); + + TLogger.Info('MCP CallTool called for tool: ' + ToolName); + Result := TValue.From(ExecuteTool(Tool, Arguments, Era)); end; -end. \ No newline at end of file +end. diff --git a/src/Prompts/MCPServer.Prompt.Base.pas b/src/Prompts/MCPServer.Prompt.Base.pas new file mode 100644 index 0000000..b7c28cc --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.Base.pas @@ -0,0 +1,318 @@ +unit MCPServer.Prompt.Base; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Resource.Base; + +type + TMCPPromptArgument = record + Name: string; + Description: string; + Required: Boolean; + end; + + TMCPPromptMessages = class + strict private + FMessages: TJSONArray; + function AddMessage(const Role: string; const Content: TJSONObject): TMCPPromptMessages; + public + constructor Create; + destructor Destroy; override; + + function AddText(const Role, Text: string): TMCPPromptMessages; + function AddImage(const Role: string; const Data: TBytes; const MimeType: string): TMCPPromptMessages; overload; + function AddImage(const Role, Base64Data, MimeType: string): TMCPPromptMessages; overload; + function AddAudio(const Role: string; const Data: TBytes; const MimeType: string): TMCPPromptMessages; overload; + function AddAudio(const Role, Base64Data, MimeType: string): TMCPPromptMessages; overload; + function AddResourceLink(const Role, Uri, Name: string; const Description: string = ''; + const MimeType: string = ''): TMCPPromptMessages; + function AddEmbeddedText(const Role, Uri, MimeType, Text: string): TMCPPromptMessages; + function AddEmbeddedBlob(const Role, Uri, MimeType: string; const Data: TBytes): TMCPPromptMessages; + function AddEmbeddedResource(const Role: string; const Resource: IMCPResource): TMCPPromptMessages; + function WithAnnotations(const Annotations: TJSONObject): TMCPPromptMessages; + + function ToJson: TJSONArray; + end; + + IMCPPrompt = interface + ['{6B8DFAF4-D0E3-4A56-8637-8DFAF4D0E3A5}'] + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetArguments: TArray; + function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; + + property Name: string read GetName; + property Title: string read GetTitle; + property Description: string read GetDescription; + property Arguments: TArray read GetArguments; + end; + + TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) + protected + FName: string; + FTitle: string; + FDescription: string; + FArguments: TArray; + FIcons: TJSONArray; + public + constructor Create; virtual; + destructor Destroy; override; + + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetArguments: TArray; + function GetIcons: TJSONArray; + function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; virtual; abstract; + end; + + TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) + protected + FName: string; + FTitle: string; + FDescription: string; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T; Messages: TMCPPromptMessages): string; virtual; abstract; + public + constructor Create; virtual; + destructor Destroy; override; + + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetArguments: TArray; + function GetIcons: TJSONArray; + function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; + end; + +implementation + +uses + System.Classes, + System.Generics.Collections, + MCPServer.ContentBlocks, + MCPServer.Serializer; + +{ TMCPPromptMessages } + +constructor TMCPPromptMessages.Create; +begin + inherited Create; + FMessages := TJSONArray.Create; +end; + +destructor TMCPPromptMessages.Destroy; +begin + FMessages.Free; + inherited; +end; + +function TMCPPromptMessages.AddMessage(const Role: string; const Content: TJSONObject): TMCPPromptMessages; +begin + var Message := TJSONObject.Create; + Message.AddPair('role', Role); + Message.AddPair('content', Content); + FMessages.AddElement(Message); + Result := Self; +end; + +function TMCPPromptMessages.AddText(const Role, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateTextBlock(Text)); +end; + +function TMCPPromptMessages.AddImage(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddImage(Role, EncodeBase64Blob(Data), MimeType); +end; + +function TMCPPromptMessages.AddImage(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateImageBlock(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddAudio(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddAudio(Role, EncodeBase64Blob(Data), MimeType); +end; + +function TMCPPromptMessages.AddAudio(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateAudioBlock(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddResourceLink(const Role, Uri, Name, Description, + MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateResourceLinkBlock(Uri, Name, Description, MimeType)); +end; + +function TMCPPromptMessages.AddEmbeddedText(const Role, Uri, MimeType, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateEmbeddedTextBlock(Uri, MimeType, Text)); +end; + +function TMCPPromptMessages.AddEmbeddedBlob(const Role, Uri, MimeType: string; + const Data: TBytes): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateEmbeddedBlobBlock(Uri, MimeType, EncodeBase64Blob(Data))); +end; + +function TMCPPromptMessages.AddEmbeddedResource(const Role: string; const Resource: IMCPResource): TMCPPromptMessages; +var + Binary: IMCPBinaryResource; +begin + if Supports(Resource, IMCPBinaryResource, Binary) then + Result := AddEmbeddedBlob(Role, Resource.URI, Resource.MimeType, Binary.ReadBinary) + else + Result := AddEmbeddedText(Role, Resource.URI, Resource.MimeType, Resource.Read); +end; + +function TMCPPromptMessages.WithAnnotations(const Annotations: TJSONObject): TMCPPromptMessages; +begin + if FMessages.Count = 0 then + begin + Annotations.Free; + raise EInvalidOperation.Create('WithAnnotations needs a message to attach to'); + end; + var LastMessage := TJSONObject(FMessages.Items[FMessages.Count - 1]); + TJSONObject(LastMessage.GetValue('content')).AddPair('annotations', Annotations); + Result := Self; +end; + +function TMCPPromptMessages.ToJson: TJSONArray; +begin + Result := TJSONArray(FMessages.Clone); +end; + +{ TMCPPromptBase } + +constructor TMCPPromptBase.Create; +begin + inherited Create; +end; + +destructor TMCPPromptBase.Destroy; +begin + FIcons.Free; + inherited; +end; + +function TMCPPromptBase.GetName: string; +begin + Result := FName; +end; + +function TMCPPromptBase.GetTitle: string; +begin + if FTitle <> '' then + Result := FTitle + else + Result := FName; +end; + +function TMCPPromptBase.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPPromptBase.GetArguments: TArray; +begin + Result := FArguments; +end; + +function TMCPPromptBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +{ TMCPPromptBase } + +constructor TMCPPromptBase.Create; +begin + inherited Create; +end; + +destructor TMCPPromptBase.Destroy; +begin + FIcons.Free; + inherited; +end; + +function TMCPPromptBase.GetName: string; +begin + Result := FName; +end; + +function TMCPPromptBase.GetTitle: string; +begin + if FTitle <> '' then + Result := FTitle + else + Result := FName; +end; + +function TMCPPromptBase.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPPromptBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +function TMCPPromptBase.GetArguments: TArray; +begin + var Ctx := TRttiContext.Create; + try + var List := TList.Create; + try + for var Prop in Ctx.GetType(T).GetProperties do + begin + if not (Prop.IsReadable and Prop.IsWritable) then + Continue; + + var Arg: TMCPPromptArgument; + Arg.Name := TMCPSerializer.GetWireName(Prop); + Arg.Description := ''; + Arg.Required := True; + for var Attr in Prop.GetAttributes do + begin + if Attr is OptionalAttribute then + Arg.Required := False + else if Attr is SchemaDescriptionAttribute then + Arg.Description := SchemaDescriptionAttribute(Attr).Description; + end; + List.Add(Arg); + end; + Result := List.ToArray; + finally + List.Free; + end; + finally + Ctx.Free; + end; +end; + +function TMCPPromptBase.Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; +var + ParamsInstance: T; +begin + ParamsInstance := TMCPSerializer.Deserialize(Arguments); + try + Result := ExecuteWithParams(ParamsInstance, Messages); + finally + ParamsInstance.Free; + end; +end; + +end. diff --git a/src/Prompts/MCPServer.Prompt.ContentSamples.pas b/src/Prompts/MCPServer.Prompt.ContentSamples.pas new file mode 100644 index 0000000..e3958c4 --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.ContentSamples.pas @@ -0,0 +1,195 @@ +unit MCPServer.Prompt.ContentSamples; + +interface + +uses + System.SysUtils, + MCPServer.Types, + MCPServer.Prompt.Base, + MCPServer.Tool.ContentSamples; + +type + TArgumentsPromptParams = class + private + FArg1: string; + FArg2: string; + public + [SchemaDescription('First test argument')] + property Arg1: string read FArg1 write FArg1; + [SchemaDescription('Second test argument')] + property Arg2: string read FArg2 write FArg2; + end; + + TEmbeddedResourcePromptParams = class + private + FResourceUri: string; + public + [SchemaName('resourceUri')] + [SchemaDescription('URI of the resource to embed')] + property ResourceUri: string read FResourceUri write FResourceUri; + end; + + TSimplePrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TArgumentsPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TArgumentsPromptParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TEmbeddedResourcePrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TEmbeddedResourcePromptParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TImagePrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TInputRequiredPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + +implementation + +uses + System.JSON, + MCPServer.Mrtr, + MCPServer.RequestContext, + MCPServer.Registration; + +const + KEY_USER_CONTEXT = 'user_context'; + FIELD_CONTEXT = 'context'; + +{ TSimplePrompt } + +constructor TSimplePrompt.Create; +begin + inherited; + FName := 'test_simple_prompt'; + FDescription := 'A simple prompt with no arguments'; +end; + +function TSimplePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', 'This is a simple prompt for testing.'); + Result := 'Simple prompt'; +end; + +{ TArgumentsPrompt } + +constructor TArgumentsPrompt.Create; +begin + inherited; + FName := 'test_prompt_with_arguments'; + FDescription := 'A prompt that substitutes its arguments into the message'; +end; + +function TArgumentsPrompt.ExecuteWithParams(const Params: TArgumentsPromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', Format('Prompt with arguments: arg1=''%s'', arg2=''%s''', [Params.Arg1, Params.Arg2])); + Result := 'Prompt with arguments'; +end; + +{ TEmbeddedResourcePrompt } + +constructor TEmbeddedResourcePrompt.Create; +begin + inherited; + FName := 'test_prompt_with_embedded_resource'; + FDescription := 'A prompt that embeds the resource named by its argument'; +end; + +function TEmbeddedResourcePrompt.ExecuteWithParams(const Params: TEmbeddedResourcePromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddEmbeddedText('user', Params.ResourceUri, 'text/plain', 'Embedded resource content for testing.'); + Messages.AddText('user', 'Please process the embedded resource above.'); + Result := 'Prompt with embedded resource'; +end; + +{ TImagePrompt } + +constructor TImagePrompt.Create; +begin + inherited; + FName := 'test_prompt_with_image'; + FDescription := 'A prompt that returns an image content block'; +end; + +function TImagePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddImage('user', SAMPLE_PNG_BASE64, 'image/png'); + Messages.AddText('user', 'Please analyze the image above.'); + Result := 'Prompt with image'; +end; + +{ TInputRequiredPrompt } + +constructor TInputRequiredPrompt.Create; +begin + inherited; + FName := 'test_input_required_result_prompt'; + FDescription := 'Asks the client which context to use before it renders'; +end; + +function TInputRequiredPrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +var + Response: TJSONObject; +begin + var UserContext := ''; + var Context := TMCPRequestContext.Current; + if Assigned(Context) and Context.TryGetInputResponse(KEY_USER_CONTEXT, Response) then + UserContext := TMCPInputResponse.ElicitationField(Response, FIELD_CONTEXT); + if UserContext = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create.AddElicitation(KEY_USER_CONTEXT, + 'What context should the prompt use?', TMCPInputRequests.FieldSchema(FIELD_CONTEXT))); + + Messages.AddText('user', Format('Use this context: %s', [UserContext])); + Result := 'Prompt with client-provided context'; +end; + +initialization + TMCPRegistry.RegisterPrompt('test_simple_prompt', + function: IMCPPrompt + begin + Result := TSimplePrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_arguments', + function: IMCPPrompt + begin + Result := TArgumentsPrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_embedded_resource', + function: IMCPPrompt + begin + Result := TEmbeddedResourcePrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_image', + function: IMCPPrompt + begin + Result := TImagePrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_input_required_result_prompt', + function: IMCPPrompt + begin + Result := TInputRequiredPrompt.Create; + end); + +end. diff --git a/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas new file mode 100644 index 0000000..f5f3a01 --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas @@ -0,0 +1,114 @@ +unit MCPServer.Prompt.SummarizeLogs; + +interface + +uses + System.SysUtils, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Prompt.Base; + +type + TSummarizeLogsParams = class + private + FLevel: string; + public + [Optional] + [SchemaDescription('Only include entries at this level (e.g. INFO, WARNING); all levels when omitted')] + property Level: string read FLevel write FLevel; + end; + + TSummarizeLogsPrompt = class(TMCPPromptBase, IMCPCompletable) + protected + function ExecuteWithParams(const Params: TSummarizeLogsParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + function Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; + end; + +implementation + +uses + System.Classes, + MCPServer.Registration, + MCPServer.Resource.Logs; + +{ TSummarizeLogsPrompt } + +constructor TSummarizeLogsPrompt.Create; +begin + inherited; + FName := 'summarize_logs'; + FDescription := 'Summarizes the server''s recent log entries, optionally filtered by level'; +end; + +function TSummarizeLogsPrompt.ExecuteWithParams(const Params: TSummarizeLogsParams; + Messages: TMCPPromptMessages): string; +var + Entries: TObjectList; + ResourceUri, ResourceText: string; +begin + if Params.Level = '' then + begin + Messages.AddText('user', 'Summarize the server''s recent log entries, calling out anything unusual.'); + ResourceUri := 'logs://recent'; + end + else + begin + Messages.AddText('user', Format( + 'Summarize the server''s recent "%s" log entries, calling out anything unusual.', [Params.Level])); + ResourceUri := 'logs://' + Params.Level; + end; + + Entries := TLogBuffer.Instance.GetLogs(100, Params.Level); + try + var Lines := TStringList.Create; + try + for var Entry in Entries do + Lines.Add(Format('[%s] [%s] %s: %s', [FormatDateTime('yyyy-mm-dd hh:nn:ss', Entry.Timestamp), + Entry.Level, Entry.Category, Entry.Message])); + ResourceText := Lines.Text; + finally + Lines.Free; + end; + finally + Entries.Free; + end; + + Messages.AddEmbeddedText('user', ResourceUri, 'text/plain', ResourceText); + Result := 'Log summary request'; +end; + +function TSummarizeLogsPrompt.Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; +begin + if ArgumentName <> 'level' then + Exit(TMCPCompletion.Create(nil)); + + var Levels := TStringList.Create; + try + Levels.Sorted := True; + Levels.Duplicates := dupIgnore; + var Entries := TLogBuffer.Instance.GetLogs(1000); + try + for var Entry in Entries do + if Entry.Level.StartsWith(Value, True) then + Levels.Add(Entry.Level); + finally + Entries.Free; + end; + Result := TMCPCompletion.Create(Levels.ToStringArray, Levels.Count); + finally + Levels.Free; + end; +end; + +initialization + TMCPRegistry.RegisterPrompt('summarize_logs', + function: IMCPPrompt + begin + Result := TSummarizeLogsPrompt.Create; + end); + +end. diff --git a/src/Protocol/MCPServer.Capabilities.pas b/src/Protocol/MCPServer.Capabilities.pas new file mode 100644 index 0000000..59d23b2 --- /dev/null +++ b/src/Protocol/MCPServer.Capabilities.pas @@ -0,0 +1,57 @@ +unit MCPServer.Capabilities; + +interface + +uses + System.JSON, + MCPServer.Types; + +type + TMCPCapabilityBuilder = class + public + class function Build(const Registry: IMCPManagerRegistry; Era: TMCPProtocolEra): TJSONObject; + class procedure AddDefaultCapabilities(const Capabilities: TJSONObject); + end; + +implementation + +uses + System.SysUtils; + +{ TMCPCapabilityBuilder } + +class procedure TMCPCapabilityBuilder.AddDefaultCapabilities(const Capabilities: TJSONObject); +begin + var Tools := TJSONObject.Create; + Tools.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('tools', Tools); + + var Resources := TJSONObject.Create; + Resources.AddPair('subscribe', TJSONBool.Create(False)); + Resources.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('resources', Resources); +end; + +class function TMCPCapabilityBuilder.Build(const Registry: IMCPManagerRegistry; Era: TMCPProtocolEra): TJSONObject; +var + Enumerator: IMCPManagerEnumerator; + Provider: IMCPCapabilityProvider; +begin + Result := TJSONObject.Create; + try + if not Supports(Registry, IMCPManagerEnumerator, Enumerator) then + begin + AddDefaultCapabilities(Result); + Exit; + end; + + for var Manager in Enumerator.GetManagers do + if Supports(Manager, IMCPCapabilityProvider, Provider) then + Provider.DescribeCapabilities(Result, Era); + except + Result.Free; + raise; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.ContentBlocks.pas b/src/Protocol/MCPServer.ContentBlocks.pas new file mode 100644 index 0000000..72d8be6 --- /dev/null +++ b/src/Protocol/MCPServer.ContentBlocks.pas @@ -0,0 +1,91 @@ +unit MCPServer.ContentBlocks; + +interface + +uses + System.SysUtils, + System.JSON; + +function CreateTextBlock(const Text: string): TJSONObject; +function CreateImageBlock(const Base64Data, MimeType: string): TJSONObject; +function CreateAudioBlock(const Base64Data, MimeType: string): TJSONObject; +function CreateResourceLinkBlock(const Uri, Name: string; const Description: string = ''; + const MimeType: string = ''): TJSONObject; +function CreateEmbeddedTextBlock(const Uri, MimeType, Text: string): TJSONObject; +function CreateEmbeddedBlobBlock(const Uri, MimeType, Base64Blob: string): TJSONObject; + +function EncodeBase64Blob(const Data: TBytes): string; + +implementation + +uses + System.NetEncoding; + +function EncodeBase64Blob(const Data: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Data); + finally + Encoding.Free; + end; +end; + +function CreateTextBlock(const Text: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'text'); + Result.AddPair('text', Text); +end; + +function CreateImageBlock(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'image'); + Result.AddPair('data', Base64Data); + Result.AddPair('mimeType', MimeType); +end; + +function CreateAudioBlock(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'audio'); + Result.AddPair('data', Base64Data); + Result.AddPair('mimeType', MimeType); +end; + +function CreateResourceLinkBlock(const Uri, Name, Description, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'resource_link'); + Result.AddPair('uri', Uri); + Result.AddPair('name', Name); + if Description <> '' then + Result.AddPair('description', Description); + if MimeType <> '' then + Result.AddPair('mimeType', MimeType); +end; + +function CreateEmbeddedTextBlock(const Uri, MimeType, Text: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('text', Text); + Result := TJSONObject.Create; + Result.AddPair('type', 'resource'); + Result.AddPair('resource', Resource); +end; + +function CreateEmbeddedBlobBlock(const Uri, MimeType, Base64Blob: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('blob', Base64Blob); + Result := TJSONObject.Create; + Result.AddPair('type', 'resource'); + Result.AddPair('resource', Resource); +end; + +end. diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas new file mode 100644 index 0000000..cf56ef5 --- /dev/null +++ b/src/Protocol/MCPServer.Errors.pas @@ -0,0 +1,171 @@ +unit MCPServer.Errors; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +type + EMCPError = class(Exception) + private + FCode: Integer; + FData: TJSONValue; + FHttpStatus: Integer; + public + constructor Create(ACode: Integer; const AMessage: string; AData: TJSONValue = nil; + AHttpStatus: Integer = 0); reintroduce; + destructor Destroy; override; + + function DetachData: TJSONValue; + + class function ParseError(const AMessage: string): EMCPError; + class function InvalidRequest(const AMessage: string): EMCPError; + class function MethodNotFound(const Method: string): EMCPError; + class function InvalidParams(const AMessage: string; AData: TJSONValue = nil): EMCPError; + class function InternalError(const AMessage: string): EMCPError; + class function HeaderMismatch(const AMessage: string): EMCPError; + class function MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; + class function UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; + class function UnknownTool(const Name: string): EMCPError; + class function UnknownPrompt(const Name: string): EMCPError; + class function ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; + class function InsufficientScope(const Scope: string): EMCPError; + function RequiredScope: string; + + property Code: Integer read FCode; + property Data: TJSONValue read FData; + property HttpStatus: Integer read FHttpStatus write FHttpStatus; + end; + + EMCPToolError = class(Exception); + + EMCPTransportError = class(Exception) + end; + + EMCPRequestCancelled = class(Exception); + +const + HTTP_STATUS_OK = 200; + HTTP_STATUS_FORBIDDEN = 403; + HTTP_STATUS_ACCEPTED = 202; + HTTP_STATUS_BAD_REQUEST = 400; + HTTP_STATUS_NOT_FOUND = 404; + +implementation + +{ EMCPError } + +constructor EMCPError.Create(ACode: Integer; const AMessage: string; AData: TJSONValue; AHttpStatus: Integer); +begin + inherited Create(AMessage); + FCode := ACode; + FData := AData; + FHttpStatus := AHttpStatus; +end; + +destructor EMCPError.Destroy; +begin + FData.Free; + inherited; +end; + +function EMCPError.DetachData: TJSONValue; +begin + Result := FData; + FData := nil; +end; + +class function EMCPError.ParseError(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_PARSE_ERROR, AMessage); +end; + +class function EMCPError.InvalidRequest(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INVALID_REQUEST, AMessage); +end; + +class function EMCPError.MethodNotFound(const Method: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, + Format('Method [%s] not found. The method does not exist or is not available.', [Method])); +end; + +class function EMCPError.InvalidParams(const AMessage: string; AData: TJSONValue): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, AMessage, AData); +end; + +class function EMCPError.InternalError(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INTERNAL_ERROR, AMessage); +end; + +class function EMCPError.HeaderMismatch(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(MCP_ERROR_HEADER_MISMATCH, AMessage, nil, HTTP_STATUS_BAD_REQUEST); +end; + +class function EMCPError.MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('requiredCapabilities', RequiredCapabilities); + Result := EMCPError.Create(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, + 'Missing required client capability', Data, HTTP_STATUS_BAD_REQUEST); +end; + +class function EMCPError.UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; +begin + var SupportedArray := TJSONArray.Create; + for var Version in Supported do + SupportedArray.Add(Version); + + var Data := TJSONObject.Create; + Data.AddPair('supported', SupportedArray); + Data.AddPair('requested', Requested); + + Result := EMCPError.Create(MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION, + 'Unsupported protocol version', Data, HTTP_STATUS_BAD_REQUEST); +end; + +class function EMCPError.UnknownTool(const Name: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('name', Name); + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown tool: ' + Name, Data); +end; + +class function EMCPError.UnknownPrompt(const Name: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('name', Name); + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown prompt: ' + Name, Data); +end; + +function EMCPError.RequiredScope: string; +begin + Result := ''; + if Data is TJSONObject then + Result := TJSONObject(Data).GetValue('requiredScope', ''); +end; + +class function EMCPError.InsufficientScope(const Scope: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('requiredScope', Scope); + Result := EMCPError.Create(JSONRPC_INVALID_REQUEST, Format('The %s scope is required', [Scope]), Data, HTTP_STATUS_FORBIDDEN); +end; + +class function EMCPError.ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('uri', Uri); + if Era = TMCPProtocolEra.Modern then + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Resource not found', Data) + else + Result := EMCPError.Create(MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY, 'Resource not found', Data); +end; + +end. diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 8e9b4e6..4e59893 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -7,219 +7,815 @@ interface System.JSON, System.Rtti, MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.Mrtr, + MCPServer.Errors, + MCPServer.HttpHeaders, MCPServer.Logger; type + TMCPProcessResult = record + Body: string; + HttpStatus: Integer; + Era: TMCPProtocolEra; + IsNotification: Boolean; + Cancelled: Boolean; + RequiredScope: string; + end; + TMCPJsonRpcProcessor = class private FManagerRegistry: IMCPManagerRegistry; - class function ParseJSONRequest(const RequestBody: string): TJSONObject; - class function ExtractRequestID(JSONRequest: TJSONObject): TValue; - class function CreateJSONResponse(const RequestID: TValue): TJSONObject; - class procedure AddRequestIDToResponse(Response: TJSONObject; const RequestID: TValue); - class function ExecuteMethodCall(ManagerRegistry: IMCPManagerRegistry; const MethodName: string; Params: TJSONObject): TValue; - class function CreateErrorResponse(const RequestID: TValue; ErrorCode: Integer; const ErrorMessage: string): string; + FSettings: TMCPSettings; + FOwnsSettings: Boolean; + FStateSealer: TMCPRequestStateSealer; + procedure SetSettings(const Value: TMCPSettings); + function SupportedModernVersions: TArray; + function BuildServerInfo: TJSONObject; + function IsLegacyOnlyMethod(const Method: string): Boolean; + function IsModernOnlyMethod(const Method: string): Boolean; + function IsCacheableMethod(const Method: string): Boolean; + function IsInputRequiredMethod(const Method: string): Boolean; + function ClientInputResponses(const Params: TJSONObject): TJSONObject; + function OpenClientRequestState(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TJSONObject; + function NewContext(Era: TMCPProtocolEra; const Version, Method: string; const RequestId: TMCPRequestId; + const Meta: TJSONObject; const Hints: TMCPTransportHints; const InputResponses: TJSONObject = nil; + const RequestState: TJSONObject = nil): IMCPRequestContext; + function InputRequiredResult(const Context: IMCPRequestContext; const Params: TJSONObject; + const Hints: TMCPTransportHints; const Required: EMCPInputRequired): TMCPProcessResult; + function EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; + function EraFromMessage(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProtocolEra; + function ExtractMeta(const Params: TJSONObject): TJSONObject; + procedure ValidateModernMeta(const Meta: TJSONObject); + procedure ValidateMirroredHeaders(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints); + function ProcessNotification(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProcessResult; + procedure HandleCancelled(const Params: TJSONObject; const Hints: TMCPTransportHints); + function CancelledResult(Era: TMCPProtocolEra): TMCPProcessResult; + function DispatchRequest(const Context: IMCPRequestContext; const Params: TJSONObject): TValue; + function ResultToJson(const Value: TValue; const Context: IMCPRequestContext): TJSONValue; + procedure ApplyModernEnvelope(const ResultObject: TJSONObject; const Method: string); + function StatusForError(Era: TMCPProtocolEra; const Error: EMCPError): Integer; + function ErrorResult(Era: TMCPProtocolEra; const RequestId: TMCPRequestId; const Error: EMCPError): TMCPProcessResult; + function ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; public - constructor Create(ManagerRegistry: IMCPManagerRegistry); + constructor Create(ManagerRegistry: IMCPManagerRegistry); overload; + constructor Create(ManagerRegistry: IMCPManagerRegistry; Settings: TMCPSettings); overload; + destructor Destroy; override; + function ProcessRequest(const RequestBody: string; const SessionID: string): string; + function ProcessRequestEx(const RequestBody: string; const Hints: TMCPTransportHints): TMCPProcessResult; overload; + function ProcessRequestEx(const Message: TJSONValue; const Hints: TMCPTransportHints): TMCPProcessResult; overload; + + function BuildRequestContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; + function BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; + + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; + property Settings: TMCPSettings read FSettings write SetSettings; end; const - JSONRPC_PARSE_ERROR = -32700; - JSONRPC_INVALID_REQUEST = -32600; - JSONRPC_METHOD_NOT_FOUND = -32601; - JSONRPC_INVALID_PARAMS = -32602; - JSONRPC_INTERNAL_ERROR = -32603; + JSONRPC_PARSE_ERROR = MCPServer.Types.JSONRPC_PARSE_ERROR; + JSONRPC_INVALID_REQUEST = MCPServer.Types.JSONRPC_INVALID_REQUEST; + JSONRPC_METHOD_NOT_FOUND = MCPServer.Types.JSONRPC_METHOD_NOT_FOUND; + JSONRPC_INVALID_PARAMS = MCPServer.Types.JSONRPC_INVALID_PARAMS; + JSONRPC_INTERNAL_ERROR = MCPServer.Types.JSONRPC_INTERNAL_ERROR; implementation +const + JSONRPC_VERSION = '2.0'; + RESULT_TYPE_COMPLETE = 'complete'; + CACHE_SCOPE_PRIVATE = 'private'; + + LEGACY_ONLY_METHODS: array[0..4] of string = ( + 'ping', 'initialize', 'logging/setLevel', 'resources/subscribe', 'resources/unsubscribe'); + MODERN_ONLY_METHODS: array[0..1] of string = ('server/discover', 'subscriptions/listen'); + INPUT_REQUIRED_METHODS: array[0..2] of string = ('tools/call', 'resources/read', 'prompts/get'); + PARAM_INPUT_RESPONSES = 'inputResponses'; + PARAM_REQUEST_STATE = 'requestState'; + +function InArray(const Value: string; const Values: array of string): Boolean; +begin + for var Item in Values do + if Item = Value then + Exit(True); + Result := False; +end; + { TMCPJsonRpcProcessor } constructor TMCPJsonRpcProcessor.Create(ManagerRegistry: IMCPManagerRegistry); +begin + Create(ManagerRegistry, nil); +end; + +constructor TMCPJsonRpcProcessor.Create(ManagerRegistry: IMCPManagerRegistry; Settings: TMCPSettings); begin inherited Create; FManagerRegistry := ManagerRegistry; + SetSettings(Settings); +end; + +destructor TMCPJsonRpcProcessor.Destroy; +begin + FStateSealer.Free; + if FOwnsSettings then + FSettings.Free; + inherited; +end; + +procedure TMCPJsonRpcProcessor.SetSettings(const Value: TMCPSettings); +begin + if FOwnsSettings then + FreeAndNil(FSettings); + FOwnsSettings := False; + + if Assigned(Value) then + FSettings := Value + else + begin + FSettings := TMCPSettings.Create('', False); + FOwnsSettings := True; + end; + + FreeAndNil(FStateSealer); + FStateSealer := TMCPRequestStateSealer.Create(FSettings.RequestStateKey, FSettings.RequestStateTtlSeconds); +end; + +function TMCPJsonRpcProcessor.SupportedModernVersions: TArray; +begin + Result := nil; + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Result := Result + [Version]; + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Result := Result + [Version]; +end; + +function TMCPJsonRpcProcessor.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('name', FSettings.ServerName); + Result.AddPair('version', FSettings.ServerVersion); + if FSettings.ServerTitle <> '' then + Result.AddPair('title', FSettings.ServerTitle); + if FSettings.ServerDescription <> '' then + Result.AddPair('description', FSettings.ServerDescription); + if FSettings.ServerWebsiteUrl <> '' then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPJsonRpcProcessor.IsLegacyOnlyMethod(const Method: string): Boolean; +begin + Result := InArray(Method, LEGACY_ONLY_METHODS); + if Result and (Method = 'ping') and FSettings.LenientModernPing then + Result := False; +end; + +function TMCPJsonRpcProcessor.IsModernOnlyMethod(const Method: string): Boolean; +begin + Result := InArray(Method, MODERN_ONLY_METHODS); +end; + +function TMCPJsonRpcProcessor.IsCacheableMethod(const Method: string): Boolean; +begin + Result := InArray(Method, MCP_CACHEABLE_METHODS); +end; + +function TMCPJsonRpcProcessor.IsInputRequiredMethod(const Method: string): Boolean; +begin + Result := InArray(Method, INPUT_REQUIRED_METHODS); +end; + +function TMCPJsonRpcProcessor.ClientInputResponses(const Params: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var Value := Params.GetValue(PARAM_INPUT_RESPONSES); + if not Assigned(Value) then + Exit; + if not (Value is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s must be an object', [PARAM_INPUT_RESPONSES])); + + for var Pair in TJSONObject(Value) do + begin + if not (Pair.JsonValue is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s.%s must be an object', [PARAM_INPUT_RESPONSES, Pair.JsonString.Value])); + end; + Result := TJSONObject(Value); +end; + +function TMCPJsonRpcProcessor.OpenClientRequestState(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var Value := Params.GetValue(PARAM_REQUEST_STATE); + if not Assigned(Value) then + Exit; + if not IsJsonString(Value) then + raise EMCPError.InvalidParams(Format('params.%s must be a string', [PARAM_REQUEST_STATE])); + + Result := FStateSealer.Open(TJSONString(Value).Value, Method, TMCPRequestStateSealer.DigestOf(Params), Hints.Principal); +end; + +function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; +begin + if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader + and IsModernProtocolVersion(Hints.ProtocolVersionHeader) then + Result := TMCPProtocolEra.Modern + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPJsonRpcProcessor.EraFromMessage(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProtocolEra; +begin + Result := EraFromHeaders(Hints); + if (Result = TMCPProtocolEra.Modern) or not Assigned(Params) then + Exit; + + var MetaValue := Params.GetValue('_meta'); + if (MetaValue is TJSONObject) and (TJSONObject(MetaValue).GetValue(MCP_META_PROTOCOL_VERSION) is TJSONString) then + Result := TMCPProtocolEra.Modern; +end; + +function TMCPJsonRpcProcessor.ExtractMeta(const Params: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var MetaValue := Params.GetValue('_meta'); + if not Assigned(MetaValue) then + Exit; + if not (MetaValue is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, 'params._meta must be an object', nil, HTTP_STATUS_BAD_REQUEST); + Result := TJSONObject(MetaValue); +end; + +procedure TMCPJsonRpcProcessor.ValidateModernMeta(const Meta: TJSONObject); +begin + var Capabilities := Meta.GetValue(MCP_META_CLIENT_CAPABILITIES); + if not (Capabilities is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_CLIENT_CAPABILITIES + ' is required and must be an object', + nil, HTTP_STATUS_BAD_REQUEST); + + var ClientInfo := Meta.GetValue(MCP_META_CLIENT_INFO); + if Assigned(ClientInfo) and not (ClientInfo is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_CLIENT_INFO + ' must be an object', nil, HTTP_STATUS_BAD_REQUEST); + + var LogLevel := Meta.GetValue(MCP_META_LOG_LEVEL); + if Assigned(LogLevel) and (not IsJsonString(LogLevel) or not TMCPLogLevel.IsKnown(TJSONString(LogLevel).Value)) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_LOG_LEVEL + ' must be one of debug, info, notice, warning, error, critical, alert, emergency', + nil, HTTP_STATUS_BAD_REQUEST); end; -class function TMCPJsonRpcProcessor.ParseJSONRequest(const RequestBody: string): TJSONObject; +procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints); var - ParsedValue: TJSONValue; + Decoded: string; begin - ParsedValue := TJSONObject.ParseJSONValue(RequestBody); - if not Assigned(ParsedValue) then - raise Exception.Create('Invalid JSON'); + if not Hints.HasMethodHeader then + raise EMCPError.HeaderMismatch('Mcp-Method header is missing'); + if Hints.MethodHeader <> Method then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: Mcp-Method header value ''%s'' does not match body value ''%s''', + [Hints.MethodHeader, Method])); + + var SourceField := ''; + if (Method = 'tools/call') or (Method = 'prompts/get') then + SourceField := 'name' + else if Method = 'resources/read' then + SourceField := 'uri'; + if SourceField = '' then + Exit; + + if not Hints.HasNameHeader then + raise EMCPError.HeaderMismatch('Mcp-Name header is missing'); + if not TMCPHeaderValue.TryDecode(Hints.NameHeader, Decoded) then + raise EMCPError.HeaderMismatch('Mcp-Name header value is not a valid header value'); - if not (ParsedValue is TJSONObject) then + var BodyValue := ''; + if Assigned(Params) then begin - ParsedValue.Free; - raise Exception.Create('JSON-RPC request must be an object'); + var Source := Params.GetValue(SourceField); + if IsJsonString(Source) then + BodyValue := TJSONString(Source).Value; end; + if Decoded <> BodyValue then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: Mcp-Name header value ''%s'' does not match body value ''%s''', + [Decoded, BodyValue])); +end; - Result := ParsedValue as TJSONObject; +function TMCPJsonRpcProcessor.NewContext(Era: TMCPProtocolEra; const Version, Method: string; + const RequestId: TMCPRequestId; const Meta: TJSONObject; const Hints: TMCPTransportHints; + const InputResponses: TJSONObject; const RequestState: TJSONObject): IMCPRequestContext; +begin + Result := TMCPRequestContext.Create(Era, Version, Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry, + Hints.Sink, InputResponses, RequestState, Hints.Principal, Hints.Scopes); end; -class function TMCPJsonRpcProcessor.ExtractRequestID(JSONRequest: TJSONObject): TValue; +function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; var - IdValue: TJSONValue; + Version: string; begin - // JSONRequest is nil when the request body failed to parse; there is no id - // to extract. Without this guard the nil dereference surfaces as - // "Access violation ... Read of address 0000000000000010" for any - // syntactically invalid request. - if not Assigned(JSONRequest) then + var Meta := ExtractMeta(Params); + + var VersionValue: TJSONValue := nil; + if Assigned(Meta) then + VersionValue := Meta.GetValue(MCP_META_PROTOCOL_VERSION); + + if VersionValue is TJSONString then + begin + Version := TJSONString(VersionValue).Value; + + if Hints.HasHeaderLayer then + begin + if not Hints.HasProtocolVersionHeader then + raise EMCPError.HeaderMismatch('MCP-Protocol-Version header is missing'); + if Hints.ProtocolVersionHeader <> Version then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: MCP-Protocol-Version header value ''%s'' does not match body value ''%s''', + [Hints.ProtocolVersionHeader, Version])); + end; + + if not IsModernProtocolVersion(Version) then + raise EMCPError.UnsupportedProtocolVersion(Version, SupportedModernVersions); + + if Hints.HasHeaderLayer then + ValidateMirroredHeaders(Method, Params, Hints); + + ValidateModernMeta(Meta); + + if IsLegacyOnlyMethod(Method) then + begin + var NotFound := EMCPError.MethodNotFound(Method); + NotFound.HttpStatus := HTTP_STATUS_NOT_FOUND; + raise NotFound; + end; + + var InputResponses: TJSONObject := nil; + var RequestState: TJSONObject := nil; + if IsInputRequiredMethod(Method) then + begin + InputResponses := ClientInputResponses(Params); + RequestState := OpenClientRequestState(Method, Params, Hints); + end; + Exit(NewContext(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, Hints, InputResponses, RequestState)); + end; + + if Method = 'initialize' then begin - Result := TValue.Empty; + var Requested := ''; + if Assigned(Params) then + begin + var RequestedValue := Params.GetValue('protocolVersion'); + if IsJsonString(RequestedValue) then + Requested := TJSONString(RequestedValue).Value; + end; + Exit(NewContext(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), Method, RequestId, Meta, Hints)); + end; + + if IsModernOnlyMethod(Method) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('%s requires params._meta.%s', [Method, MCP_META_PROTOCOL_VERSION]), nil, HTTP_STATUS_BAD_REQUEST); + + if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader then + begin + var Header := Hints.ProtocolVersionHeader; + if IsModernProtocolVersion(Header) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('MCP-Protocol-Version %s requires params._meta.%s', [Header, MCP_META_PROTOCOL_VERSION]), + nil, HTTP_STATUS_BAD_REQUEST); + if not IsLegacyProtocolVersion(Header) and (Header <> MCP_PROTOCOL_VERSION_2025_03_26) then + raise EMCPError.Create(JSONRPC_INVALID_REQUEST, + 'Unsupported MCP-Protocol-Version header: ' + Header, nil, HTTP_STATUS_BAD_REQUEST); + + Exit(NewContext(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, Hints)); + end; + + Version := ''; + if Assigned(Hints.LegacySession) then + Version := Hints.LegacySession.ProtocolVersion; + if Version = '' then + Version := MCP_LATEST_LEGACY_PROTOCOL_VERSION; + + Result := NewContext(TMCPProtocolEra.Legacy, Version, Method, RequestId, Meta, Hints); +end; + +function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProcessResult; +begin + Result.Body := ''; + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := EraFromHeaders(Hints); + Result.IsNotification := True; + + TLogger.Info('Notification received: ' + Method); + + if Method = MCP_METHOD_NOTIFICATIONS_CANCELLED then + begin + HandleCancelled(Params, Hints); + Exit; + end; + + var Manager: IMCPCapabilityManager := nil; + if Assigned(FManagerRegistry) then + Manager := FManagerRegistry.GetManagerForMethod(Method); + if not Assigned(Manager) then Exit; + + try + Manager.ExecuteMethod(Method, Params); + except + on E: Exception do + TLogger.Error('Notification ' + Method + ' failed: ' + E.Message); end; +end; - IdValue := JSONRequest.GetValue('id'); - if not Assigned(IdValue) then +procedure TMCPJsonRpcProcessor.HandleCancelled(const Params: TJSONObject; const Hints: TMCPTransportHints); +begin + if not Assigned(Hints.Tracker) or not Assigned(Params) then + Exit; + + var RequestId := TMCPRequestId.FromJson(Params.GetValue('requestId')); + if not RequestId.IsPresent then begin - Result := TValue.Empty; + TLogger.Warning('notifications/cancelled without a usable requestId'); Exit; end; - if IdValue is TJSONNumber then - Result := TValue.From((IdValue as TJSONNumber).AsInt64) - else if IdValue is TJSONString then - Result := TValue.From((IdValue as TJSONString).Value) - else - Result := TValue.Empty; + var Reason := ''; + var ReasonValue := Params.GetValue('reason'); + if IsJsonString(ReasonValue) then + Reason := TJSONString(ReasonValue).Value; + + if not Hints.Tracker.TryCancel(RequestId, Reason) then + TLogger.Debug('notifications/cancelled for unknown or finished request ' + RequestId.AsText); end; -class function TMCPJsonRpcProcessor.CreateJSONResponse(const RequestID: TValue): TJSONObject; +function TMCPJsonRpcProcessor.CancelledResult(Era: TMCPProtocolEra): TMCPProcessResult; begin - Result := TJSONObject.Create; - Result.AddPair('jsonrpc', '2.0'); - AddRequestIDToResponse(Result, RequestID); + Result := Default(TMCPProcessResult); + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Era; + Result.Cancelled := True; end; -class procedure TMCPJsonRpcProcessor.AddRequestIDToResponse(Response: TJSONObject; const RequestID: TValue); +function TMCPJsonRpcProcessor.InputRequiredResult(const Context: IMCPRequestContext; const Params: TJSONObject; + const Hints: TMCPTransportHints; const Required: EMCPInputRequired): TMCPProcessResult; begin - if RequestID.IsEmpty then + if Context.Era = TMCPProtocolEra.Legacy then + raise EMCPError.InternalError(Format( + '%s needs input from the client, which protocol version %s cannot deliver', + [Context.Method, Context.ProtocolVersion])); + if not IsInputRequiredMethod(Context.Method) then + raise EMCPError.InternalError(Format('%s must not answer with an InputRequiredResult', [Context.Method])); + if (Required.Requests.Count = 0) and not Assigned(Required.State) then + raise EMCPError.InternalError('An InputRequiredResult needs inputRequests or requestState'); + + for var Method in Required.Requests.Methods do begin - Response.AddPair('id', TJSONNull.Create); - Exit; + var Capability := TMCPInputRequests.RequiredCapability(Method); + if Capability = '' then + raise EMCPError.InternalError(Format('%s is not a request a client can answer', [Method])); + Context.RequireClientCapability(Capability); end; - if RequestID.Kind in [tkString, tkUString, tkWString, tkLString] then - Response.AddPair('id', RequestID.AsString) - else if RequestID.Kind in [tkInteger, tkInt64] then - Response.AddPair('id', TJSONNumber.Create(RequestID.AsInt64)) - else - Response.AddPair('id', TJSONNull.Create); + var ResultObject := TJSONObject.Create; + try + ResultObject.AddPair('resultType', RESULT_TYPE_INPUT_REQUIRED); + if Required.Requests.Count > 0 then + ResultObject.AddPair('inputRequests', Required.Requests.ToJson); + if Assigned(Required.State) then + ResultObject.AddPair(PARAM_REQUEST_STATE, FStateSealer.Seal(Required.State, Context.Method, + TMCPRequestStateSealer.DigestOf(Params), Hints.Principal)); + ApplyModernEnvelope(ResultObject, Context.Method); + + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', Context.RequestId.ToJson); + Response.AddPair('result', TJSONObject(ResultObject.Clone)); + Result.Body := Response.ToJSON; + finally + Response.Free; + end; + finally + ResultObject.Free; + end; + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Context.Era; + Result.IsNotification := False; + Result.Cancelled := False; +end; + +function TMCPJsonRpcProcessor.BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; +begin + Result := ErrorResult(TMCPProtocolEra.Legacy, RequestId, Error).Body; end; -class function TMCPJsonRpcProcessor.ExecuteMethodCall(ManagerRegistry: IMCPManagerRegistry; - const MethodName: string; Params: TJSONObject): TValue; +function TMCPJsonRpcProcessor.DispatchRequest(const Context: IMCPRequestContext; const Params: TJSONObject): TValue; var - Manager: IMCPCapabilityManager; + ManagerEx: IMCPCapabilityManagerEx; begin - if not Assigned(ManagerRegistry) then - raise Exception.Create('Manager registry not initialized'); + if not Assigned(FManagerRegistry) then + raise EMCPError.InternalError('Manager registry not initialized'); - Manager := ManagerRegistry.GetManagerForMethod(MethodName); + var Manager := FManagerRegistry.GetManagerForMethod(Context.Method); if not Assigned(Manager) then - raise Exception.CreateFmt('Method [%s] not found. The method does not exist or is not available.', [MethodName]); + raise EMCPError.MethodNotFound(Context.Method); + + TMCPRequestContext.SetCurrent(Context); + try + if Supports(Manager, IMCPCapabilityManagerEx, ManagerEx) then + Result := ManagerEx.ExecuteMethodWithContext(Context.Method, Params, Context) + else + Result := Manager.ExecuteMethod(Context.Method, Params); + finally + TMCPRequestContext.SetCurrent(nil); + end; +end; + +procedure TMCPJsonRpcProcessor.ApplyModernEnvelope(const ResultObject: TJSONObject; const Method: string); +begin + if not Assigned(ResultObject.GetValue('resultType')) then + ResultObject.AddPair('resultType', RESULT_TYPE_COMPLETE); + + var MetaValue := ResultObject.GetValue('_meta'); + var Meta: TJSONObject := nil; + if MetaValue is TJSONObject then + Meta := TJSONObject(MetaValue) + else if not Assigned(MetaValue) then + begin + Meta := TJSONObject.Create; + ResultObject.AddPair('_meta', Meta); + end; + if Assigned(Meta) and not Assigned(Meta.GetValue(MCP_META_SERVER_INFO)) then + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); - Result := Manager.ExecuteMethod(MethodName, Params); + var ResultType := ResultObject.GetValue('resultType'); + if IsCacheableMethod(Method) and (ResultType is TJSONString) + and (TJSONString(ResultType).Value = RESULT_TYPE_COMPLETE) then + begin + if not Assigned(ResultObject.GetValue('ttlMs')) then + ResultObject.AddPair('ttlMs', TJSONNumber.Create(0)); + if not Assigned(ResultObject.GetValue('cacheScope')) then + ResultObject.AddPair('cacheScope', CACHE_SCOPE_PRIVATE); + end; end; -class function TMCPJsonRpcProcessor.CreateErrorResponse(const RequestID: TValue; - ErrorCode: Integer; const ErrorMessage: string): string; -var - ErrorObj: TJSONObject; - JSONResponse: TJSONObject; +function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: IMCPRequestContext): TJSONValue; begin - JSONResponse := CreateJSONResponse(RequestID); + if Context.Era = TMCPProtocolEra.Legacy then + begin + if Value.IsEmpty then + Result := nil + else if Value.IsType then + Result := Value.AsType + else if Value.IsType then + Result := TJSONString.Create(Value.AsString) + else + Result := TJSONString.Create(Value.ToString); + Exit; + end; + + var ResultObject: TJSONObject; + if Value.IsType then + ResultObject := Value.AsType + else + begin + ResultObject := TJSONObject.Create; + if not Value.IsEmpty then + ResultObject.AddPair('value', Value.ToString); + end; + + ApplyModernEnvelope(ResultObject, Context.Method); + Result := ResultObject; +end; + +function TMCPJsonRpcProcessor.StatusForError(Era: TMCPProtocolEra; const Error: EMCPError): Integer; +begin + if Era = TMCPProtocolEra.Legacy then + begin + if (Error.HttpStatus = HTTP_STATUS_BAD_REQUEST) or (Error.HttpStatus = HTTP_STATUS_FORBIDDEN) then + Exit(Error.HttpStatus); + Exit(HTTP_STATUS_OK); + end; + + if Error.HttpStatus <> 0 then + Exit(Error.HttpStatus); + + case Error.Code of + JSONRPC_PARSE_ERROR, JSONRPC_INVALID_REQUEST, + MCP_ERROR_HEADER_MISMATCH, MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, + MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION: + Result := HTTP_STATUS_BAD_REQUEST; + JSONRPC_METHOD_NOT_FOUND: + Result := HTTP_STATUS_NOT_FOUND; + else + Result := HTTP_STATUS_OK; + end; +end; + +function TMCPJsonRpcProcessor.ErrorResult(Era: TMCPProtocolEra; const RequestId: TMCPRequestId; + const Error: EMCPError): TMCPProcessResult; +begin + TLogger.Error('Error processing request: ' + Error.Message); + var RequiredScope := ''; + if Error.HttpStatus = HTTP_STATUS_FORBIDDEN then + RequiredScope := Error.RequiredScope; + + var Response := TJSONObject.Create; try - ErrorObj := TJSONObject.Create; - JSONResponse.AddPair('error', ErrorObj); - ErrorObj.AddPair('code', TJSONNumber.Create(ErrorCode)); - ErrorObj.AddPair('message', ErrorMessage); - Result := JSONResponse.ToJSON; + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', RequestId.ToJson); + + var ErrorObject := TJSONObject.Create; + Response.AddPair('error', ErrorObject); + ErrorObject.AddPair('code', TJSONNumber.Create(Error.Code)); + ErrorObject.AddPair('message', Error.Message); + if Assigned(Error.Data) then + ErrorObject.AddPair('data', Error.DetachData); + + Result.Body := Response.ToJSON; finally - JSONResponse.Free; + Response.Free; end; + + Result.HttpStatus := StatusForError(Era, Error); + Result.Era := Era; + Result.IsNotification := False; + Result.Cancelled := False; + Result.RequiredScope := RequiredScope; +end; + +function TMCPJsonRpcProcessor.ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; +begin + if (Era = TMCPProtocolEra.Legacy) and (Pos('not found', E.Message) > 0) then + Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, E.Message) + else + Result := EMCPError.InternalError(E.Message); end; function TMCPJsonRpcProcessor.ProcessRequest(const RequestBody: string; const SessionID: string): string; +begin + Result := ProcessRequestEx(RequestBody, TMCPTransportHints.None).Body; +end; + +function TMCPJsonRpcProcessor.ProcessRequestEx(const RequestBody: string; + const Hints: TMCPTransportHints): TMCPProcessResult; +begin + var Message := TJSONObject.ParseJSONValue(RequestBody); + try + Result := ProcessRequestEx(Message, Hints); + finally + Message.Free; + end; +end; + +function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; + const Hints: TMCPTransportHints): TMCPProcessResult; var - ErrorCode: Integer; - ExecuteResult: TValue; - JSONRequest: TJSONObject; - JSONResponse: TJSONObject; - MethodName: string; - MethodValue: TJSONValue; - Params: TJSONObject; - ParamsValue: TJSONValue; - RequestID: TValue; -begin - Result := ''; - JSONRequest := nil; - JSONResponse := nil; + RequestId: TMCPRequestId; + Era: TMCPProtocolEra; + Context: IMCPRequestContext; +begin + RequestId := TMCPRequestId.FromJson(nil); + Era := EraFromHeaders(Hints); + Context := nil; try try - JSONRequest := ParseJSONRequest(RequestBody); - - RequestID := ExtractRequestID(JSONRequest); + if not Assigned(Message) then + raise EMCPError.ParseError('Invalid JSON'); + if Message is TJSONArray then + raise EMCPError.InvalidRequest('JSON-RPC batch requests are not supported'); + if not (Message is TJSONObject) then + raise EMCPError.InvalidRequest('JSON-RPC message must be an object'); + + var Request := TJSONObject(Message); + + RequestId := TMCPRequestId.FromJson(Request.GetValue('id')); + if RequestId.Kind = TMCPRequestIdKind.Null then + raise EMCPError.InvalidRequest('id must not be null'); + if RequestId.Kind = TMCPRequestIdKind.Invalid then + begin + RequestId := TMCPRequestId.FromJson(nil); + raise EMCPError.InvalidRequest('id must be a string or an integer'); + end; - MethodValue := JSONRequest.GetValue('method'); - MethodName := ''; - if Assigned(MethodValue) then - MethodName := MethodValue.Value; + var JsonRpc := Request.GetValue('jsonrpc'); + if not IsJsonString(JsonRpc) or (TJSONString(JsonRpc).Value <> JSONRPC_VERSION) then + raise EMCPError.InvalidRequest('jsonrpc must be "2.0"'); - // Notifications (requests without id) should not have a response - if RequestID.IsEmpty then + var MethodValue := Request.GetValue('method'); + if not IsJsonString(MethodValue) then begin - if MethodName = 'notifications/initialized' then - TLogger.Info('MCP Initialized notification received') - else - TLogger.Info('Notification received: ' + MethodName); - Exit; + if Assigned(Request.GetValue('result')) or Assigned(Request.GetValue('error')) then + begin + if Era = TMCPProtocolEra.Modern then + raise EMCPError.InvalidRequest('JSON-RPC responses are not accepted'); + Result.Body := ''; + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := Era; + Result.IsNotification := True; + Exit; + end; + raise EMCPError.InvalidRequest('method must be a string'); end; + var Method := TJSONString(MethodValue).Value; - JSONResponse := CreateJSONResponse(RequestID); - - ParamsValue := JSONRequest.GetValue('params'); - Params := nil; - if Assigned(ParamsValue) and (ParamsValue is TJSONObject) then - Params := ParamsValue as TJSONObject; + var ParamsValue := Request.GetValue('params'); + var Params: TJSONObject := nil; + if Assigned(ParamsValue) then + begin + if not (ParamsValue is TJSONObject) then + begin + if Era = TMCPProtocolEra.Modern then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, 'params must be an object', nil, HTTP_STATUS_BAD_REQUEST); + raise EMCPError.InvalidParams('params must be an object'); + end; + Params := TJSONObject(ParamsValue); + end; - ExecuteResult := ExecuteMethodCall(FManagerRegistry, MethodName, Params); + if RequestId.Kind = TMCPRequestIdKind.None then + Exit(ProcessNotification(Method, Params, Hints)); + + Era := EraFromMessage(Method, Params, Hints); + Context := BuildRequestContext(Method, Params, RequestId, Hints); + Era := Context.Era; + + var ExecuteResult: TValue; + if Assigned(Hints.Tracker) then + Hints.Tracker.Track(Context); + try + try + ExecuteResult := DispatchRequest(Context, Params); + except + on E: EMCPInputRequired do + Exit(InputRequiredResult(Context, Params, Hints, E)); + end; + finally + if Assigned(Hints.Tracker) then + Hints.Tracker.Untrack(Context); + end; - if not ExecuteResult.IsEmpty then + if Context.IsCancelled then begin - if ExecuteResult.IsType then - JSONResponse.AddPair('result', ExecuteResult.AsType) - else if ExecuteResult.IsType then - JSONResponse.AddPair('result', ExecuteResult.AsString) - else - JSONResponse.AddPair('result', ExecuteResult.ToString); + if ExecuteResult.IsObject then + ExecuteResult.AsObject.Free; + Exit(CancelledResult(Era)); end; - Result := JSONResponse.ToJSON; - + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', RequestId.ToJson); + var ResultJson := ResultToJson(ExecuteResult, Context); + if Assigned(ResultJson) then + Response.AddPair('result', ResultJson); + Result.Body := Response.ToJSON; + finally + Response.Free; + end; + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Era; + Result.IsNotification := False; except + on E: EMCPRequestCancelled do + Result := CancelledResult(Era); + on E: EMCPError do + Result := ErrorResult(Era, RequestId, E); on E: Exception do begin - TLogger.Error('Error processing request: ' + E.Message); - - // If parsing failed, JSONRequest is still nil: report a JSON-RPC parse - // error (-32700). ExtractRequestID is nil-safe and yields a null id. - ErrorCode := JSONRPC_INTERNAL_ERROR; - if not Assigned(JSONRequest) then - ErrorCode := JSONRPC_PARSE_ERROR - else if Pos('not found', E.Message) > 0 then - ErrorCode := JSONRPC_METHOD_NOT_FOUND; - - Result := CreateErrorResponse(ExtractRequestID(JSONRequest), ErrorCode, E.Message); + var Error := ExceptionToError(Era, E); + try + Result := ErrorResult(Era, RequestId, Error); + finally + Error.Free; + end; end; end; finally - JSONRequest.Free; - JSONResponse.Free; + Context := nil; end; end; diff --git a/src/Protocol/MCPServer.Mrtr.pas b/src/Protocol/MCPServer.Mrtr.pas new file mode 100644 index 0000000..6346be8 --- /dev/null +++ b/src/Protocol/MCPServer.Mrtr.pas @@ -0,0 +1,229 @@ +unit MCPServer.Mrtr; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +const + RESULT_TYPE_INPUT_REQUIRED = 'input_required'; + MCP_METHOD_ELICITATION_CREATE = 'elicitation/create'; + MCP_METHOD_SAMPLING_CREATE_MESSAGE = 'sampling/createMessage'; + MCP_METHOD_ROOTS_LIST = 'roots/list'; + ELICITATION_MODE_FORM = 'form'; + ELICITATION_ACTION_ACCEPT = 'accept'; + +type + TMCPInputRequests = class + strict private + FRequests: TJSONObject; + function AddRequest(const Key, Method: string; const Params: TJSONObject): TMCPInputRequests; + public + constructor Create; + destructor Destroy; override; + + function AddElicitation(const Key, Message: string; const RequestedSchema: TJSONObject): TMCPInputRequests; + function AddSampling(const Key, UserText: string; MaxTokens: Integer; + const SystemPrompt: string = ''): TMCPInputRequests; + function AddListRoots(const Key: string): TMCPInputRequests; + + function Count: Integer; + function Methods: TArray; + class function RequiredCapability(const Method: string): string; static; + class function FieldSchema(const Field: string; const FieldType: string = 'string'): TJSONObject; static; + function ToJson: TJSONObject; + end; + + TMCPInputResponse = record + class function ElicitationContent(const Response: TJSONObject): TJSONObject; static; + class function ElicitationField(const Response: TJSONObject; const Field: string): string; static; + class function SamplingText(const Response: TJSONObject): string; static; + class function Roots(const Response: TJSONObject): TJSONArray; static; + end; + + EMCPInputRequired = class(Exception) + strict private + FRequests: TMCPInputRequests; + FState: TJSONObject; + public + constructor Create(Requests: TMCPInputRequests; State: TJSONObject = nil); + destructor Destroy; override; + property Requests: TMCPInputRequests read FRequests; + property State: TJSONObject read FState; + end; + +implementation + +{ TMCPInputRequests } + +class function TMCPInputRequests.FieldSchema(const Field: string; const FieldType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'object'); + var Properties := TJSONObject.Create; + Result.AddPair('properties', Properties); + var Schema := TJSONObject.Create; + Schema.AddPair('type', FieldType); + Properties.AddPair(Field, Schema); + var Required := TJSONArray.Create; + Required.Add(Field); + Result.AddPair('required', Required); +end; + +constructor TMCPInputRequests.Create; +begin + inherited Create; + FRequests := TJSONObject.Create; +end; + +destructor TMCPInputRequests.Destroy; +begin + FRequests.Free; + inherited; +end; + +function TMCPInputRequests.AddRequest(const Key, Method: string; const Params: TJSONObject): TMCPInputRequests; +begin + var Request := TJSONObject.Create; + Request.AddPair('method', Method); + Request.AddPair('params', Params); + FRequests.AddPair(Key, Request); + Result := Self; +end; + +function TMCPInputRequests.AddElicitation(const Key, Message: string; + const RequestedSchema: TJSONObject): TMCPInputRequests; +begin + var Params := TJSONObject.Create; + Params.AddPair('mode', ELICITATION_MODE_FORM); + Params.AddPair('message', Message); + Params.AddPair('requestedSchema', RequestedSchema); + Result := AddRequest(Key, MCP_METHOD_ELICITATION_CREATE, Params); +end; + +function TMCPInputRequests.AddSampling(const Key, UserText: string; MaxTokens: Integer; + const SystemPrompt: string): TMCPInputRequests; +begin + var Params := TJSONObject.Create; + var Messages := TJSONArray.Create; + Params.AddPair('messages', Messages); + var Message := TJSONObject.Create; + Messages.AddElement(Message); + Message.AddPair('role', 'user'); + var Content := TJSONObject.Create; + Message.AddPair('content', Content); + Content.AddPair('type', 'text'); + Content.AddPair('text', UserText); + if SystemPrompt <> '' then + Params.AddPair('systemPrompt', SystemPrompt); + Params.AddPair('maxTokens', TJSONNumber.Create(MaxTokens)); + Result := AddRequest(Key, MCP_METHOD_SAMPLING_CREATE_MESSAGE, Params); +end; + +function TMCPInputRequests.AddListRoots(const Key: string): TMCPInputRequests; +begin + Result := AddRequest(Key, MCP_METHOD_ROOTS_LIST, TJSONObject.Create); +end; + +function TMCPInputRequests.Count: Integer; +begin + Result := FRequests.Count; +end; + +function TMCPInputRequests.Methods: TArray; +begin + Result := nil; + for var Pair in FRequests do + Result := Result + [TJSONObject(Pair.JsonValue).GetValue('method')]; +end; + +class function TMCPInputRequests.RequiredCapability(const Method: string): string; +begin + if Method = MCP_METHOD_ELICITATION_CREATE then + Result := 'elicitation' + else if Method = MCP_METHOD_SAMPLING_CREATE_MESSAGE then + Result := 'sampling' + else if Method = MCP_METHOD_ROOTS_LIST then + Result := 'roots' + else + Result := ''; +end; + +function TMCPInputRequests.ToJson: TJSONObject; +begin + Result := TJSONObject(FRequests.Clone); +end; + +{ TMCPInputResponse } + +class function TMCPInputResponse.ElicitationContent(const Response: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Response) then + Exit; + + var Action := Response.GetValue('action'); + var Content := Response.GetValue('content'); + var Accepted := IsJsonString(Action) and (TJSONString(Action).Value = ELICITATION_ACTION_ACCEPT); + if Accepted and (Content is TJSONObject) then + Result := TJSONObject(Content); +end; + +class function TMCPInputResponse.ElicitationField(const Response: TJSONObject; const Field: string): string; +begin + Result := ''; + var Content := ElicitationContent(Response); + if not Assigned(Content) then + Exit; + + var Value := Content.GetValue(Field); + if IsJsonString(Value) then + Result := TJSONString(Value).Value + else if Assigned(Value) and not (Value is TJSONNull) then + Result := Value.ToJSON; +end; + +class function TMCPInputResponse.SamplingText(const Response: TJSONObject): string; +begin + Result := ''; + if not Assigned(Response) then + Exit; + + var Content := Response.GetValue('content'); + if not (Content is TJSONObject) then + Exit; + var Text := TJSONObject(Content).GetValue('text'); + if IsJsonString(Text) then + Result := TJSONString(Text).Value; +end; + +class function TMCPInputResponse.Roots(const Response: TJSONObject): TJSONArray; +begin + Result := nil; + if not Assigned(Response) then + Exit; + + var Value := Response.GetValue('roots'); + if Value is TJSONArray then + Result := TJSONArray(Value); +end; + +{ EMCPInputRequired } + +constructor EMCPInputRequired.Create(Requests: TMCPInputRequests; State: TJSONObject); +begin + inherited Create('Input from the client is required to complete this request'); + FRequests := Requests; + FState := State; +end; + +destructor EMCPInputRequired.Destroy; +begin + FRequests.Free; + FState.Free; + inherited; +end; + +end. diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas new file mode 100644 index 0000000..13ed78f --- /dev/null +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -0,0 +1,434 @@ +unit MCPServer.RequestContext; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types; + +const + PROGRESS_MIN_INTERVAL_MS = 50; + +type + TMCPTransportHints = record + HasHeaderLayer: Boolean; + HasProtocolVersionHeader: Boolean; + ProtocolVersionHeader: string; + HasMethodHeader: Boolean; + MethodHeader: string; + HasNameHeader: Boolean; + NameHeader: string; + RemoteAddress: string; + Principal: string; + Scopes: TArray; + LegacySession: TMCPLegacySession; + Sink: IMCPMessageSink; + Tracker: IMCPRequestTracker; + + class function None: TMCPTransportHints; static; + class function ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; overload; static; + class function ForStdio(const Session: TMCPLegacySession; const Sink: IMCPMessageSink; + const Tracker: IMCPRequestTracker): TMCPTransportHints; overload; static; + class function ForHttp(const HasVersionHeader: Boolean; const VersionHeader: string): TMCPTransportHints; static; + end; + + TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) + private + FEra: TMCPProtocolEra; + FProtocolVersion: string; + FMethod: string; + FRequestId: TMCPRequestId; + FMeta: TJSONObject; + FLegacySession: TMCPLegacySession; + FManagerRegistry: IMCPManagerRegistry; + FSink: IMCPMessageSink; + FInputResponses: TJSONObject; + FRequestState: TJSONObject; + FPrincipal: string; + FScopes: TArray; + FCancelled: Integer; + FProgressSent: Boolean; + FLastProgress: Double; + FLastProgressTick: UInt64; + function MetaObject(const Key: string): TJSONObject; + public + constructor Create(Era: TMCPProtocolEra; const ProtocolVersion, Method: string; + const RequestId: TMCPRequestId; const Meta: TJSONObject; + const LegacySession: TMCPLegacySession; const ManagerRegistry: IMCPManagerRegistry; + const Sink: IMCPMessageSink = nil; const InputResponses: TJSONObject = nil; + const RequestState: TJSONObject = nil; const Principal: string = ''; + const Scopes: TArray = nil); + destructor Destroy; override; + + function GetEra: TMCPProtocolEra; + function GetProtocolVersion: string; + function GetMethod: string; + function GetRequestId: TMCPRequestId; + function GetMeta: TJSONObject; + function GetClientCapabilities: TJSONObject; + function GetClientInfo: TJSONObject; + function GetLogLevel: string; + function GetProgressToken: TJSONValue; + function GetLegacySession: TMCPLegacySession; + function GetManagerRegistry: IMCPManagerRegistry; + function GetInputResponses: TJSONObject; + function GetRequestState: TJSONObject; + function GetSink: IMCPMessageSink; + function GetPrincipal: string; + function GetScopes: TArray; + function HasClientCapability(const Path: string): Boolean; + function HasScope(const Scope: string): Boolean; + procedure RequireClientCapability(const Path: string); + function IsCancelled: Boolean; + procedure CheckCancelled; + procedure Cancel; + function HasProgressToken: Boolean; + procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); + function TryGetInputResponse(const Key: string; out Response: TJSONObject): Boolean; + procedure Log(const Level, Text: string; const Logger: string = ''); + procedure LogJson(const Level: string; const Data: TJSONValue; const Logger: string = ''); + + class function Current: IMCPRequestContext; + class procedure SetCurrent(const Value: IMCPRequestContext); + end; + +implementation + +uses + MCPServer.Errors; + +threadvar + CurrentContextPointer: Pointer; + +{ TMCPTransportHints } + +class function TMCPTransportHints.None: TMCPTransportHints; +begin + Result := Default(TMCPTransportHints); +end; + +class function TMCPTransportHints.ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; +begin + Result := Default(TMCPTransportHints); + Result.LegacySession := Session; +end; + +class function TMCPTransportHints.ForStdio(const Session: TMCPLegacySession; const Sink: IMCPMessageSink; + const Tracker: IMCPRequestTracker): TMCPTransportHints; +begin + Result := ForStdio(Session); + Result.Sink := Sink; + Result.Tracker := Tracker; +end; + +class function TMCPTransportHints.ForHttp(const HasVersionHeader: Boolean; const VersionHeader: string): TMCPTransportHints; +begin + Result := Default(TMCPTransportHints); + Result.HasHeaderLayer := True; + Result.HasProtocolVersionHeader := HasVersionHeader; + Result.ProtocolVersionHeader := VersionHeader; +end; + +{ TMCPRequestContext } + +constructor TMCPRequestContext.Create(Era: TMCPProtocolEra; const ProtocolVersion, Method: string; + const RequestId: TMCPRequestId; const Meta: TJSONObject; const LegacySession: TMCPLegacySession; + const ManagerRegistry: IMCPManagerRegistry; const Sink: IMCPMessageSink; const InputResponses: TJSONObject; + const RequestState: TJSONObject; const Principal: string; const Scopes: TArray); +begin + inherited Create; + FEra := Era; + FProtocolVersion := ProtocolVersion; + FMethod := Method; + FRequestId := RequestId; + if Assigned(Meta) then + FMeta := TJSONObject(Meta.Clone); + FLegacySession := LegacySession; + FManagerRegistry := ManagerRegistry; + FSink := Sink; + if Assigned(InputResponses) then + FInputResponses := TJSONObject(InputResponses.Clone); + FRequestState := RequestState; + FPrincipal := Principal; + FScopes := Scopes; +end; + +destructor TMCPRequestContext.Destroy; +begin + FMeta.Free; + FInputResponses.Free; + FRequestState.Free; + inherited; +end; + +function TMCPRequestContext.MetaObject(const Key: string): TJSONObject; +begin + Result := nil; + if not Assigned(FMeta) then + Exit; + + var Value := FMeta.GetValue(Key); + if Value is TJSONObject then + Result := TJSONObject(Value); +end; + +function TMCPRequestContext.GetEra: TMCPProtocolEra; +begin + Result := FEra; +end; + +function TMCPRequestContext.GetProtocolVersion: string; +begin + Result := FProtocolVersion; +end; + +function TMCPRequestContext.GetMethod: string; +begin + Result := FMethod; +end; + +function TMCPRequestContext.GetRequestId: TMCPRequestId; +begin + Result := FRequestId; +end; + +function TMCPRequestContext.GetMeta: TJSONObject; +begin + Result := FMeta; +end; + +function TMCPRequestContext.GetClientCapabilities: TJSONObject; +begin + Result := MetaObject(MCP_META_CLIENT_CAPABILITIES); +end; + +function TMCPRequestContext.GetClientInfo: TJSONObject; +begin + Result := MetaObject(MCP_META_CLIENT_INFO); +end; + +function TMCPRequestContext.GetLogLevel: string; +begin + Result := ''; + if not Assigned(FMeta) then + Exit; + + var Value := FMeta.GetValue(MCP_META_LOG_LEVEL); + if IsJsonString(Value) then + Result := TJSONString(Value).Value; +end; + +function TMCPRequestContext.GetProgressToken: TJSONValue; +begin + Result := nil; + if Assigned(FMeta) then + Result := FMeta.GetValue(MCP_META_PROGRESS_TOKEN); +end; + +function TMCPRequestContext.GetLegacySession: TMCPLegacySession; +begin + Result := FLegacySession; +end; + +function TMCPRequestContext.GetManagerRegistry: IMCPManagerRegistry; +begin + Result := FManagerRegistry; +end; + +function TMCPRequestContext.GetInputResponses: TJSONObject; +begin + Result := FInputResponses; +end; + +function TMCPRequestContext.GetRequestState: TJSONObject; +begin + Result := FRequestState; +end; + +function TMCPRequestContext.GetSink: IMCPMessageSink; +begin + Result := FSink; +end; + +function TMCPRequestContext.GetPrincipal: string; +begin + Result := FPrincipal; +end; + +function TMCPRequestContext.GetScopes: TArray; +begin + Result := FScopes; +end; + +function TMCPRequestContext.HasScope(const Scope: string): Boolean; +begin + for var Granted in FScopes do + begin + if (Granted = Scope) or (Granted = MCP_SCOPE_ANY) then + Exit(True); + end; + Result := False; +end; + +function TMCPRequestContext.TryGetInputResponse(const Key: string; out Response: TJSONObject): Boolean; +begin + Response := nil; + if not Assigned(FInputResponses) then + Exit(False); + + var Value := FInputResponses.GetValue(Key); + if Value is TJSONObject then + Response := TJSONObject(Value); + Result := Assigned(Response); +end; + +function TMCPRequestContext.HasClientCapability(const Path: string): Boolean; +begin + Result := False; + var Node: TJSONValue := GetClientCapabilities; + if not Assigned(Node) then + Exit; + + for var Segment in Path.Split(['.']) do + begin + if not (Node is TJSONObject) then + Exit; + Node := TJSONObject(Node).GetValue(Segment); + if not Assigned(Node) then + Exit; + end; + Result := True; +end; + +procedure TMCPRequestContext.RequireClientCapability(const Path: string); +begin + if HasClientCapability(Path) then + Exit; + + var Required := TJSONObject.Create; + var Node := Required; + for var Segment in Path.Split(['.']) do + begin + var Child := TJSONObject.Create; + Node.AddPair(Segment, Child); + Node := Child; + end; + raise EMCPError.MissingRequiredClientCapability(Required); +end; + +function TMCPRequestContext.IsCancelled: Boolean; +begin + Result := AtomicCmpExchange(FCancelled, 0, 0) <> 0; +end; + +procedure TMCPRequestContext.CheckCancelled; +begin + if IsCancelled then + raise EMCPRequestCancelled.CreateFmt('Request %s was cancelled by the client', [FRequestId.AsText]); +end; + +procedure TMCPRequestContext.Cancel; +begin + AtomicExchange(FCancelled, 1); +end; + +function TMCPRequestContext.HasProgressToken: Boolean; +begin + var Token := GetProgressToken; + if not Assigned(Token) then + Exit(False); + if Token is TJSONNumber then + Exit(Frac(TJSONNumber(Token).AsDouble) = 0); + Result := Token is TJSONString; +end; + +procedure TMCPRequestContext.ReportProgress(const Progress, Total: Double; const Message: string); +const + JSON_RPC_VERSION = '2.0'; +begin + if not Assigned(FSink) or not HasProgressToken or IsCancelled then + Exit; + + var Completes := (Total >= 0) and (Progress >= Total); + var Tick := TThread.GetTickCount64; + if FProgressSent then + begin + if Progress <= FLastProgress then + Exit; + if (Tick - FLastProgressTick < PROGRESS_MIN_INTERVAL_MS) and not Completes then + Exit; + end; + FProgressSent := True; + FLastProgress := Progress; + FLastProgressTick := Tick; + + var Notification := TJSONObject.Create; + try + Notification.AddPair('jsonrpc', JSON_RPC_VERSION); + Notification.AddPair('method', MCP_METHOD_NOTIFICATIONS_PROGRESS); + var Params := TJSONObject.Create; + Notification.AddPair('params', Params); + Params.AddPair(MCP_META_PROGRESS_TOKEN, TJSONValue(GetProgressToken.Clone)); + Params.AddPair('progress', TJSONNumber.Create(Progress)); + if Total >= 0 then + Params.AddPair('total', TJSONNumber.Create(Total)); + if Message <> '' then + Params.AddPair('message', Message); + FSink.Send(Notification.ToJSON); + finally + Notification.Free; + end; +end; + +procedure TMCPRequestContext.Log(const Level, Text: string; const Logger: string); +begin + LogJson(Level, TJSONString.Create(Text), Logger); +end; + +procedure TMCPRequestContext.LogJson(const Level: string; const Data: TJSONValue; const Logger: string); +const + JSON_RPC_VERSION = '2.0'; +begin + var Threshold := GetLogLevel; + var Wanted := Assigned(FSink) and (Threshold <> '') and not IsCancelled + and (TMCPLogLevel.Rank(Level) >= TMCPLogLevel.Rank(Threshold)); + if not Wanted then + begin + Data.Free; + Exit; + end; + + var Notification := TJSONObject.Create; + try + Notification.AddPair('jsonrpc', JSON_RPC_VERSION); + Notification.AddPair('method', MCP_METHOD_NOTIFICATIONS_MESSAGE); + var Params := TJSONObject.Create; + Notification.AddPair('params', Params); + Params.AddPair('level', Level); + if Logger <> '' then + Params.AddPair('logger', Logger); + Params.AddPair('data', Data); + FSink.Send(Notification.ToJSON); + finally + Notification.Free; + end; +end; + +class function TMCPRequestContext.Current: IMCPRequestContext; +begin + Result := IMCPRequestContext(CurrentContextPointer); +end; + +class procedure TMCPRequestContext.SetCurrent(const Value: IMCPRequestContext); +begin + if Assigned(CurrentContextPointer) then + IMCPRequestContext(CurrentContextPointer)._Release; + + CurrentContextPointer := Pointer(Value); + if Assigned(Value) then + Value._AddRef; +end; + +end. diff --git a/src/Protocol/MCPServer.RequestState.pas b/src/Protocol/MCPServer.RequestState.pas new file mode 100644 index 0000000..06fc53c --- /dev/null +++ b/src/Protocol/MCPServer.RequestState.pas @@ -0,0 +1,245 @@ +unit MCPServer.RequestState; + +interface + +uses + System.SysUtils, + System.JSON; + +type + TMCPRequestStateSealer = class + public + const DEFAULT_TTL_SECONDS = 600; + const TOKEN_VERSION = 1; + strict private + FKey: TBytes; + FTtlSeconds: Integer; + FKeyIsEphemeral: Boolean; + function Signature(const Payload: TBytes): TBytes; + class function Base64Url(const Bytes: TBytes): string; static; + class function TryFromBase64Url(const Text: string; out Bytes: TBytes): Boolean; static; + class function CanonicalJson(const Value: TJSONValue): string; static; + public + constructor Create(const Key: string; TtlSeconds: Integer = DEFAULT_TTL_SECONDS); + + function Seal(const State: TJSONObject; const Method, ArgumentDigest, Principal: string): string; + function Open(const Token, Method, ArgumentDigest, Principal: string): TJSONObject; + + class function DigestOf(const Params: TJSONObject): string; static; + + property KeyIsEphemeral: Boolean read FKeyIsEphemeral; + property TtlSeconds: Integer read FTtlSeconds; + end; + +implementation + +uses + System.Classes, + System.Hash, + System.DateUtils, + System.NetEncoding, + System.Generics.Collections, + System.Generics.Defaults, + MCPServer.Types, + MCPServer.Errors, + MCPServer.Logger; + +const + KEY_BYTES = 32; + TOKEN_SEPARATOR = '.'; + PAYLOAD_VERSION = 'v'; + PAYLOAD_METHOD = 'm'; + PAYLOAD_DIGEST = 'a'; + PAYLOAD_EXPIRY = 'exp'; + PAYLOAD_PRINCIPAL = 'p'; + PAYLOAD_STATE = 's'; + EXCLUDED_MEMBERS: array[0..2] of string = ('_meta', 'inputResponses', 'requestState'); + +{ TMCPRequestStateSealer } + +constructor TMCPRequestStateSealer.Create(const Key: string; TtlSeconds: Integer); +begin + inherited Create; + FTtlSeconds := TtlSeconds; + if Key.Trim <> '' then + FKey := TEncoding.UTF8.GetBytes(Key) + else + begin + SetLength(FKey, KEY_BYTES); + Randomize; + for var I := 0 to High(FKey) do + FKey[I] := Byte(Random(256)); + FKeyIsEphemeral := True; + TLogger.Warning('[Security] RequestStateKey is not set: requestState tokens are sealed with a random key ' + + 'and stop verifying after a restart or on another instance'); + end; +end; + +function TMCPRequestStateSealer.Signature(const Payload: TBytes): TBytes; +begin + Result := THashSHA2.GetHMACAsBytes(Payload, FKey, THashSHA2.TSHA2Version.SHA256); +end; + +class function TMCPRequestStateSealer.Base64Url(const Bytes: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Bytes).Replace('+', '-').Replace('/', '_').TrimRight(['=']); + finally + Encoding.Free; + end; +end; + +class function TMCPRequestStateSealer.TryFromBase64Url(const Text: string; out Bytes: TBytes): Boolean; +begin + Bytes := nil; + if Text = '' then + Exit(False); + for var C in Text do + if not (CharInSet(C, ['A'..'Z', 'a'..'z', '0'..'9', '-', '_'])) then + Exit(False); + + var Standard := Text.Replace('-', '+').Replace('_', '/'); + while Length(Standard) mod 4 <> 0 do + Standard := Standard + '='; + try + Bytes := TNetEncoding.Base64.DecodeStringToBytes(Standard); + Result := Length(Bytes) > 0; + except + Result := False; + end; +end; + +class function TMCPRequestStateSealer.CanonicalJson(const Value: TJSONValue): string; +begin + if Value is TJSONObject then + begin + var Names := TList.Create; + try + for var Pair in TJSONObject(Value) do + Names.Add(Pair.JsonString.Value); + Names.Sort(TComparer.Construct( + function(const Left, Right: string): Integer + begin + Result := CompareStr(Left, Right); + end)); + var Parts := TStringBuilder.Create; + try + Parts.Append('{'); + for var I := 0 to Names.Count - 1 do + begin + if I > 0 then + Parts.Append(','); + Parts.Append(TJSONString.Create(Names[I]).ToJSON).Append(':') + .Append(CanonicalJson(TJSONObject(Value).GetValue(Names[I]))); + end; + Parts.Append('}'); + Result := Parts.ToString; + finally + Parts.Free; + end; + finally + Names.Free; + end; + end + else if Value is TJSONArray then + begin + var Parts := TStringBuilder.Create; + try + Parts.Append('['); + for var I := 0 to TJSONArray(Value).Count - 1 do + begin + if I > 0 then + Parts.Append(','); + Parts.Append(CanonicalJson(TJSONArray(Value).Items[I])); + end; + Parts.Append(']'); + Result := Parts.ToString; + finally + Parts.Free; + end; + end + else if Assigned(Value) then + Result := Value.ToJSON + else + Result := 'null'; +end; + +class function TMCPRequestStateSealer.DigestOf(const Params: TJSONObject): string; +begin + var Salient := TJSONObject.Create; + try + if Assigned(Params) then + for var Pair in Params do + begin + var Excluded := False; + for var Name in EXCLUDED_MEMBERS do + if Pair.JsonString.Value = Name then + Excluded := True; + if not Excluded then + Salient.AddPair(Pair.JsonString.Value, TJSONValue(Pair.JsonValue.Clone)); + end; + Result := THashSHA2.GetHashString(CanonicalJson(Salient), THashSHA2.TSHA2Version.SHA256); + finally + Salient.Free; + end; +end; + +function TMCPRequestStateSealer.Seal(const State: TJSONObject; const Method, ArgumentDigest, + Principal: string): string; +begin + var Payload := TJSONObject.Create; + try + Payload.AddPair(PAYLOAD_VERSION, TJSONNumber.Create(TOKEN_VERSION)); + Payload.AddPair(PAYLOAD_METHOD, Method); + Payload.AddPair(PAYLOAD_DIGEST, ArgumentDigest); + Payload.AddPair(PAYLOAD_EXPIRY, TJSONNumber.Create(DateTimeToUnix(Now, False) + FTtlSeconds)); + Payload.AddPair(PAYLOAD_PRINCIPAL, Principal); + if Assigned(State) then + Payload.AddPair(PAYLOAD_STATE, TJSONObject(State.Clone)) + else + Payload.AddPair(PAYLOAD_STATE, TJSONObject.Create); + + var PayloadBytes := TEncoding.UTF8.GetBytes(Payload.ToJSON); + Result := Base64Url(PayloadBytes) + TOKEN_SEPARATOR + Base64Url(Signature(PayloadBytes)); + finally + Payload.Free; + end; +end; + +function TMCPRequestStateSealer.Open(const Token, Method, ArgumentDigest, Principal: string): TJSONObject; +var + PayloadBytes, SignatureBytes: TBytes; +begin + var Separator := Token.LastIndexOf(TOKEN_SEPARATOR); + if (Separator <= 0) or not TryFromBase64Url(Token.Substring(0, Separator), PayloadBytes) + or not TryFromBase64Url(Token.Substring(Separator + 1), SignatureBytes) + or not TMCPConstantTime.SameBytes(SignatureBytes, Signature(PayloadBytes)) then + raise EMCPError.InvalidParams('requestState failed integrity verification'); + + var Payload := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(PayloadBytes)) as TJSONObject; + if not Assigned(Payload) then + raise EMCPError.InvalidParams('requestState failed integrity verification'); + try + if Payload.GetValue(PAYLOAD_VERSION, 0) <> TOKEN_VERSION then + raise EMCPError.InvalidParams('requestState has an unsupported version'); + if Payload.GetValue(PAYLOAD_METHOD, '') <> Method then + raise EMCPError.InvalidParams('requestState belongs to another method'); + if Payload.GetValue(PAYLOAD_DIGEST, '') <> ArgumentDigest then + raise EMCPError.InvalidParams('requestState belongs to another request'); + if Payload.GetValue(PAYLOAD_PRINCIPAL, '') <> Principal then + raise EMCPError.InvalidParams('requestState belongs to another principal'); + if Payload.GetValue(PAYLOAD_EXPIRY, 0) < DateTimeToUnix(Now, False) then + raise EMCPError.InvalidParams('requestState has expired'); + + var State := Payload.GetValue(PAYLOAD_STATE); + if State is TJSONObject then + Result := TJSONObject(State.Clone) + else + Result := TJSONObject.Create; + finally + Payload.Free; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.Schema.Generator.pas b/src/Protocol/MCPServer.Schema.Generator.pas index 1f5e04b..1ed2ed3 100644 --- a/src/Protocol/MCPServer.Schema.Generator.pas +++ b/src/Protocol/MCPServer.Schema.Generator.pas @@ -11,10 +11,15 @@ interface type TMCPSchemaGenerator = class private - class function GetJsonTypeFromRttiType(RttiType: TRttiType): string; - class function GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; + const MAX_NESTING_DEPTH = 8; + class function GetPropertyJsonName(Prop: TRttiProperty): string; class function IsRequiredProperty(Prop: TRttiProperty): Boolean; class function CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; + class function ListItemType(RttiType: TRttiType): TRttiType; + class function TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function ObjectSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function NumberValue(const Value: Double): TJSONNumber; + class procedure ApplyAttributes(Prop: TRttiProperty; const PropSchema: TJSONObject); public class function GenerateSchema(Cls: TClass): TJSONObject; class function GenerateSchemaFromInstance(Instance: TObject): TJSONObject; @@ -26,147 +31,259 @@ implementation System.Generics.Collections, MCPServer.Types; +var + RttiContext: TRttiContext; + { TMCPSchemaGenerator } class function TMCPSchemaGenerator.GenerateSchema(Cls: TClass): TJSONObject; -var - Attr: TCustomAttribute; - EnumArray: TJSONArray; - JsonName: string; - JsonType: string; - Properties: TJSONObject; - PropSchema: TJSONObject; - RequiredArray: TJSONArray; - RttiContext: TRttiContext; - RttiProp: TRttiProperty; - RttiType: TRttiType; - Value: string; begin - Result := TJSONObject.Create; - Result.AddPair('type', 'object'); + Result := ObjectSchema(RttiContext.GetType(Cls), 0); +end; - Properties := TJSONObject.Create; - Result.AddPair('properties', Properties); - RequiredArray := TJSONArray.Create; +class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; +begin + Result := GenerateSchema(Instance.ClassType); +end; - RttiContext := TRttiContext.Create; - try - RttiType := RttiContext.GetType(Cls); +class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty): string; +begin + for var Attr in Prop.GetAttributes do + if Attr is SchemaNameAttribute then + Exit(SchemaNameAttribute(Attr).Name); + Result := LowerCase(Prop.Name); +end; - for RttiProp in RttiType.GetProperties do - begin - if RttiProp.IsReadable and RttiProp.IsWritable then - begin - JsonName := GetPropertyJsonName(RttiProp, RttiType); +class function TMCPSchemaGenerator.IsRequiredProperty(Prop: TRttiProperty): Boolean; +begin + for var Attr in Prop.GetAttributes do + if Attr is OptionalAttribute then + Exit(False); + Result := True; +end; - PropSchema := TJSONObject.Create; - Properties.AddPair(JsonName, PropSchema); +class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; +begin + Result := nil; + if not (RttiType is TRttiEnumerationType) or (RttiType.Handle = TypeInfo(Boolean)) then + Exit; - JsonType := GetJsonTypeFromRttiType(RttiProp.PropertyType); - PropSchema.AddPair('type', JsonType); + var EnumType := TRttiEnumerationType(RttiType); + Result := TJSONArray.Create; + for var Ordinal := EnumType.MinValue to EnumType.MaxValue do + Result.Add(GetEnumName(RttiType.Handle, Ordinal)); +end; - if JsonType = 'array' then - PropSchema.AddPair('items', TJSONObject.Create); +class function TMCPSchemaGenerator.ListItemType(RttiType: TRttiType): TRttiType; +begin + Result := nil; + var ItemsProp := RttiType.GetIndexedProperty('Items'); + if not Assigned(ItemsProp) or not Assigned(ItemsProp.ReadMethod) then + Exit; + var Parameters := ItemsProp.ReadMethod.GetParameters; + if (Length(Parameters) = 1) and (Parameters[0].ParamType.TypeKind in [tkInteger, tkInt64]) then + Result := ItemsProp.PropertyType; +end; - EnumArray := nil; +class function TMCPSchemaGenerator.TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; +begin + Result := TJSONObject.Create; + try + case RttiType.TypeKind of + tkInteger, tkInt64: + Result.AddPair('type', 'integer'); - for Attr in RttiProp.GetAttributes do + tkFloat: + if RttiType.Handle = TypeInfo(TDateTime) then begin - if Attr is SchemaDescriptionAttribute then - begin - PropSchema.AddPair('description', SchemaDescriptionAttribute(Attr).Description); - end - else if Attr is SchemaEnumAttribute then - begin - EnumArray := TJSONArray.Create; - for Value in SchemaEnumAttribute(Attr).Values do - EnumArray.Add(Value); - end; + Result.AddPair('type', 'string'); + Result.AddPair('format', 'date-time'); + end + else if RttiType.Handle = TypeInfo(TDate) then + begin + Result.AddPair('type', 'string'); + Result.AddPair('format', 'date'); + end + else if RttiType.Handle = TypeInfo(TTime) then + begin + Result.AddPair('type', 'string'); + Result.AddPair('format', 'time'); + end + else + Result.AddPair('type', 'number'); + + tkString, tkLString, tkWString, tkUString, tkChar, tkWChar: + Result.AddPair('type', 'string'); + + tkEnumeration: + if RttiType.Handle = TypeInfo(Boolean) then + Result.AddPair('type', 'boolean') + else + begin + Result.AddPair('type', 'string'); + Result.AddPair('enum', CreateEnumValuesArray(RttiType)); end; - if not Assigned(EnumArray) then - EnumArray := CreateEnumValuesArray(RttiProp.PropertyType); + tkSet: + begin + Result.AddPair('type', 'array'); + var Items := TJSONObject.Create; + Result.AddPair('items', Items); + Items.AddPair('type', 'string'); + var ElementType := TRttiSetType(RttiType).ElementType; + var Names := CreateEnumValuesArray(ElementType); + if Assigned(Names) then + Items.AddPair('enum', Names); + end; - if Assigned(EnumArray) then - PropSchema.AddPair('enum', EnumArray); + tkDynArray: + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(TRttiDynamicArrayType(RttiType).ElementType, Depth + 1)); + end; - if IsRequiredProperty(RttiProp) then - RequiredArray.Add(JsonName); - end; - end; + tkArray: + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(TRttiArrayType(RttiType).ElementType, Depth + 1)); + end; - if RequiredArray.Count > 0 then - Result.AddPair('required', RequiredArray) + tkClass: + begin + var Metaclass := TRttiInstanceType(RttiType).MetaclassType; + if Metaclass.InheritsFrom(TJSONArray) then + Result.AddPair('type', 'array') + else if Metaclass.InheritsFrom(TJSONValue) then + Result.AddPair('type', 'object') + else + begin + var ItemType := ListItemType(RttiType); + if Assigned(ItemType) then + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(ItemType, Depth + 1)); + end + else if Depth < MAX_NESTING_DEPTH then + begin + Result.Free; + Result := ObjectSchema(RttiType, Depth + 1); + end + else + Result.AddPair('type', 'object'); + end; + end; else - RequiredArray.Free; - finally - RttiContext.Free; + Result.AddPair('type', 'string'); + end; + except + Result.Free; + raise; end; end; -class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; -begin - Result := GenerateSchema(Instance.ClassType); -end; - -class function TMCPSchemaGenerator.GetJsonTypeFromRttiType(RttiType: TRttiType): string; +class function TMCPSchemaGenerator.NumberValue(const Value: Double): TJSONNumber; begin - case RttiType.TypeKind of - tkInteger, tkInt64: Result := 'number'; - tkFloat: Result := 'number'; - tkString, tkLString, tkWString, tkUString: Result := 'string'; - tkEnumeration: - if RttiType.Name = 'Boolean' then - Result := 'boolean' - else - Result := 'string'; - tkSet: Result := 'array'; - tkClass: - if RttiType.Name = 'TJSONArray' then - Result := 'array' - else - Result := 'object'; - tkArray, tkDynArray: Result := 'array'; + if Frac(Value) = 0 then + Result := TJSONNumber.Create(Trunc(Value)) else - Result := 'string'; - end; + Result := TJSONNumber.Create(Value); end; -class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; +class procedure TMCPSchemaGenerator.ApplyAttributes(Prop: TRttiProperty; const PropSchema: TJSONObject); begin - Result := LowerCase(Prop.Name); -end; - -class function TMCPSchemaGenerator.IsRequiredProperty(Prop: TRttiProperty): Boolean; -var - Attr: TCustomAttribute; -begin - for Attr in Prop.GetAttributes do + for var Attr in Prop.GetAttributes do begin - if Attr is OptionalAttribute then - Exit(False); + if Attr is SchemaDescriptionAttribute then + PropSchema.AddPair('description', SchemaDescriptionAttribute(Attr).Description) + else if Attr is SchemaTitleAttribute then + PropSchema.AddPair('title', SchemaTitleAttribute(Attr).Title) + else if Attr is SchemaFormatAttribute then + begin + PropSchema.RemovePair('format').Free; + PropSchema.AddPair('format', SchemaFormatAttribute(Attr).Format); + end + else if Attr is SchemaMinimumAttribute then + PropSchema.AddPair('minimum', NumberValue(SchemaMinimumAttribute(Attr).Minimum)) + else if Attr is SchemaMaximumAttribute then + PropSchema.AddPair('maximum', NumberValue(SchemaMaximumAttribute(Attr).Maximum)) + else if Attr is SchemaEnumAttribute then + begin + PropSchema.RemovePair('enum').Free; + var EnumArray := TJSONArray.Create; + for var Value in SchemaEnumAttribute(Attr).Values do + EnumArray.Add(Value); + PropSchema.AddPair('enum', EnumArray); + end + else if Attr is SchemaMinLengthAttribute then + PropSchema.AddPair('minLength', TJSONNumber.Create(SchemaMinLengthAttribute(Attr).MinLength)) + else if Attr is SchemaMaxLengthAttribute then + PropSchema.AddPair('maxLength', TJSONNumber.Create(SchemaMaxLengthAttribute(Attr).MaxLength)) + else if Attr is SchemaPatternAttribute then + PropSchema.AddPair('pattern', SchemaPatternAttribute(Attr).Pattern) + else if Attr is SchemaDefaultAttribute then + begin + var DefaultValue := TJSONObject.ParseJSONValue(SchemaDefaultAttribute(Attr).Json); + if not Assigned(DefaultValue) then + raise EArgumentException.CreateFmt('[SchemaDefault] on %s is not valid JSON: %s', + [Prop.Name, SchemaDefaultAttribute(Attr).Json]); + PropSchema.AddPair('default', DefaultValue); + end; end; - Result := True; end; -class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; -var - EnumType: TRttiEnumerationType; - Ordinal: Integer; +class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; begin - Result := nil; + Result := TJSONObject.Create; + try + if Depth = 0 then + for var Attr in RttiType.GetAttributes do + if Attr is SchemaDialectAttribute then + Result.AddPair('$schema', SchemaDialectAttribute(Attr).Uri); - if not (RttiType is TRttiEnumerationType) then - Exit; + Result.AddPair('type', 'object'); + var Properties := TJSONObject.Create; + Result.AddPair('properties', Properties); + var RequiredArray := TJSONArray.Create; - if RttiType.Handle = TypeInfo(Boolean) then - Exit; + for var RttiProp in RttiType.GetProperties do + begin + if not (RttiProp.IsReadable and RttiProp.IsWritable) then + Continue; - EnumType := TRttiEnumerationType(RttiType); + var JsonName := GetPropertyJsonName(RttiProp); + var PropSchema := TypeSchema(RttiProp.PropertyType, Depth); + Properties.AddPair(JsonName, PropSchema); + ApplyAttributes(RttiProp, PropSchema); - Result := TJSONArray.Create; - for Ordinal := EnumType.MinValue to EnumType.MaxValue do - Result.Add(GetEnumName(RttiType.Handle, Ordinal)); + if IsRequiredProperty(RttiProp) then + RequiredArray.Add(JsonName); + end; + + if RequiredArray.Count > 0 then + Result.AddPair('required', RequiredArray) + else + RequiredArray.Free; + + var ExplicitAdditionalProperties := False; + for var Attr in RttiType.GetAttributes do + if Attr is SchemaAdditionalPropertiesAttribute then + begin + Result.AddPair('additionalProperties', TJSONBool.Create(SchemaAdditionalPropertiesAttribute(Attr).Allowed)); + ExplicitAdditionalProperties := True; + end; + + if not ExplicitAdditionalProperties and (Properties.Count = 0) then + Result.AddPair('additionalProperties', TJSONBool.Create(False)); + except + Result.Free; + raise; + end; end; -end. \ No newline at end of file +initialization + RttiContext := TRttiContext.Create; + +finalization + RttiContext.Free; + +end. diff --git a/src/Protocol/MCPServer.Schema.Validator.pas b/src/Protocol/MCPServer.Schema.Validator.pas new file mode 100644 index 0000000..8b142f2 --- /dev/null +++ b/src/Protocol/MCPServer.Schema.Validator.pas @@ -0,0 +1,304 @@ +unit MCPServer.Schema.Validator; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON; + +type + TMCPSchemaValidator = class + public + const MAX_DEPTH = 32; + + class function Validate(const Schema: TJSONObject; const Instance: TJSONValue; + out Errors: TArray): Boolean; + private + class function ValidateNode(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; + class function ResolveRef(const RootSchema: TJSONObject; const Ref: string; + out Resolved: TJSONObject): Boolean; + class function MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; + class function CheckType(const Schema: TJSONObject; const Instance: TJSONValue; + out ErrorMessage: string): Boolean; + class function JsonEquals(A, B: TJSONValue): Boolean; + class procedure AddError(Errors: TStrings; const Path, Message: string); + end; + +implementation + +uses + System.Generics.Collections, + System.RegularExpressions; + +{ TMCPSchemaValidator } + +class procedure TMCPSchemaValidator.AddError(Errors: TStrings; const Path, Message: string); +begin + if Path = '' then + Errors.Add(Message) + else + Errors.Add(Path + ': ' + Message); +end; + +class function TMCPSchemaValidator.MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; +begin + if TypeName = 'null' then + Result := not Assigned(Instance) or (Instance is TJSONNull) + else if TypeName = 'boolean' then + Result := Instance is TJSONBool + else if TypeName = 'integer' then + Result := (Instance is TJSONNumber) and (Frac(TJSONNumber(Instance).AsDouble) = 0) + else if TypeName = 'number' then + Result := Instance is TJSONNumber + else if TypeName = 'string' then + Result := (Instance is TJSONString) and not (Instance is TJSONNumber) + else if TypeName = 'object' then + Result := Instance is TJSONObject + else if TypeName = 'array' then + Result := Instance is TJSONArray + else + Result := False; +end; + +class function TMCPSchemaValidator.CheckType(const Schema: TJSONObject; const Instance: TJSONValue; + out ErrorMessage: string): Boolean; +begin + Result := True; + ErrorMessage := ''; + var TypeValue := Schema.GetValue('type'); + if not Assigned(TypeValue) then + Exit; + + if (TypeValue is TJSONString) and not (TypeValue is TJSONNumber) then + begin + Result := MatchesType(Instance, TJSONString(TypeValue).Value); + if not Result then + ErrorMessage := 'expected ' + TJSONString(TypeValue).Value; + Exit; + end; + + if TypeValue is TJSONArray then + begin + var Names := TStringList.Create; + try + for var Item in TJSONArray(TypeValue) do + if (Item is TJSONString) and not (Item is TJSONNumber) then + begin + Names.Add(TJSONString(Item).Value); + if MatchesType(Instance, TJSONString(Item).Value) then + Exit(True); + end; + Result := False; + ErrorMessage := 'expected one of: ' + Names.CommaText; + finally + Names.Free; + end; + end; +end; + +class function TMCPSchemaValidator.JsonEquals(A, B: TJSONValue): Boolean; +begin + if not Assigned(A) or not Assigned(B) then + Exit(not Assigned(A) and not Assigned(B)); + if (A is TJSONNull) or (B is TJSONNull) then + Exit((A is TJSONNull) and (B is TJSONNull)); + if (A is TJSONBool) or (B is TJSONBool) then + Exit((A is TJSONBool) and (B is TJSONBool) and (TJSONBool(A).AsBoolean = TJSONBool(B).AsBoolean)); + if (A is TJSONNumber) or (B is TJSONNumber) then + Exit((A is TJSONNumber) and (B is TJSONNumber) and (TJSONNumber(A).AsDouble = TJSONNumber(B).AsDouble)); + if (A is TJSONString) or (B is TJSONString) then + Exit((A is TJSONString) and (B is TJSONString) and (TJSONString(A).Value = TJSONString(B).Value)); + Result := A.ToJSON = B.ToJSON; +end; + +class function TMCPSchemaValidator.ResolveRef(const RootSchema: TJSONObject; const Ref: string; + out Resolved: TJSONObject): Boolean; +const + DEFS_PREFIX = '#/$defs/'; + DEFINITIONS_PREFIX = '#/definitions/'; +begin + Resolved := nil; + + var DefsValue: TJSONValue; + var Name := ''; + if Ref.StartsWith(DEFS_PREFIX) then + begin + Name := Copy(Ref, Length(DEFS_PREFIX) + 1, MaxInt); + DefsValue := RootSchema.GetValue('$defs'); + end + else if Ref.StartsWith(DEFINITIONS_PREFIX) then + begin + Name := Copy(Ref, Length(DEFINITIONS_PREFIX) + 1, MaxInt); + DefsValue := RootSchema.GetValue('definitions'); + end + else + Exit(False); + + if not (DefsValue is TJSONObject) then + Exit(False); + var Entry := TJSONObject(DefsValue).GetValue(Name); + if not (Entry is TJSONObject) then + Exit(False); + + Resolved := TJSONObject(Entry); + Result := True; +end; + +class function TMCPSchemaValidator.ValidateNode(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; +begin + Result := True; + if Depth > MAX_DEPTH then + begin + AddError(Errors, Path, 'schema nested too deeply'); + Exit(False); + end; + + var ResolvedSchema := Schema; + var RefValue := Schema.GetValue('$ref'); + if (RefValue is TJSONString) and not (RefValue is TJSONNumber) then + begin + if not ResolveRef(RootSchema, TJSONString(RefValue).Value, ResolvedSchema) then + begin + AddError(Errors, Path, 'unsupported $ref "' + TJSONString(RefValue).Value + '"'); + Exit(False); + end; + end; + + var ConstValue := ResolvedSchema.GetValue('const'); + if Assigned(ConstValue) and not JsonEquals(ConstValue, Instance) then + begin + AddError(Errors, Path, 'does not match const'); + Result := False; + end; + + var EnumValue := ResolvedSchema.GetValue('enum'); + if EnumValue is TJSONArray then + begin + var Found := False; + for var Item in TJSONArray(EnumValue) do + if JsonEquals(Item, Instance) then + begin + Found := True; + Break; + end; + if not Found then + begin + AddError(Errors, Path, 'not one of the allowed values'); + Result := False; + end; + end; + + var TypeError: string; + if not CheckType(ResolvedSchema, Instance, TypeError) then + begin + AddError(Errors, Path, TypeError); + Exit(False); + end; + + if (Instance is TJSONString) and not (Instance is TJSONNumber) then + begin + var Text := TJSONString(Instance).Value; + var MinLengthValue := ResolvedSchema.GetValue('minLength'); + if (MinLengthValue is TJSONNumber) and (Length(Text) < TJSONNumber(MinLengthValue).AsInt) then + begin + AddError(Errors, Path, 'shorter than minLength'); + Result := False; + end; + var MaxLengthValue := ResolvedSchema.GetValue('maxLength'); + if (MaxLengthValue is TJSONNumber) and (Length(Text) > TJSONNumber(MaxLengthValue).AsInt) then + begin + AddError(Errors, Path, 'longer than maxLength'); + Result := False; + end; + var PatternValue := ResolvedSchema.GetValue('pattern'); + if (PatternValue is TJSONString) and not (PatternValue is TJSONNumber) + and not TRegEx.IsMatch(Text, TJSONString(PatternValue).Value) then + begin + AddError(Errors, Path, 'does not match pattern'); + Result := False; + end; + end; + + if Instance is TJSONNumber then + begin + var NumberValue := TJSONNumber(Instance).AsDouble; + var MinimumValue := ResolvedSchema.GetValue('minimum'); + if (MinimumValue is TJSONNumber) and (NumberValue < TJSONNumber(MinimumValue).AsDouble) then + begin + AddError(Errors, Path, 'less than minimum'); + Result := False; + end; + var MaximumValue := ResolvedSchema.GetValue('maximum'); + if (MaximumValue is TJSONNumber) and (NumberValue > TJSONNumber(MaximumValue).AsDouble) then + begin + AddError(Errors, Path, 'greater than maximum'); + Result := False; + end; + end; + + if Instance is TJSONObject then + begin + var Obj := TJSONObject(Instance); + + var RequiredValue := ResolvedSchema.GetValue('required'); + if RequiredValue is TJSONArray then + for var Item in TJSONArray(RequiredValue) do + if (Item is TJSONString) and not (Item is TJSONNumber) + and not Assigned(Obj.GetValue(TJSONString(Item).Value)) then + begin + AddError(Errors, Path, 'missing required property "' + TJSONString(Item).Value + '"'); + Result := False; + end; + + var PropSchemas: TJSONObject := nil; + var PropertiesValue := ResolvedSchema.GetValue('properties'); + if PropertiesValue is TJSONObject then + PropSchemas := TJSONObject(PropertiesValue); + + if Assigned(PropSchemas) then + for var Pair in Obj do + begin + var PropSchemaValue := PropSchemas.GetValue(Pair.JsonString.Value); + if PropSchemaValue is TJSONObject then + if not ValidateNode(TJSONObject(PropSchemaValue), Pair.JsonValue, Path + '.' + Pair.JsonString.Value, + Depth + 1, RootSchema, Errors) then + Result := False; + end; + + var AdditionalValue := ResolvedSchema.GetValue('additionalProperties'); + if (AdditionalValue is TJSONBool) and not TJSONBool(AdditionalValue).AsBoolean then + for var Pair in Obj do + if not (Assigned(PropSchemas) and Assigned(PropSchemas.GetValue(Pair.JsonString.Value))) then + begin + AddError(Errors, Path, 'unexpected property "' + Pair.JsonString.Value + '"'); + Result := False; + end; + end; + + if Instance is TJSONArray then + begin + var ItemsValue := ResolvedSchema.GetValue('items'); + if ItemsValue is TJSONObject then + for var I := 0 to TJSONArray(Instance).Count - 1 do + if not ValidateNode(TJSONObject(ItemsValue), TJSONArray(Instance).Items[I], Format('%s[%d]', [Path, I]), + Depth + 1, RootSchema, Errors) then + Result := False; + end; +end; + +class function TMCPSchemaValidator.Validate(const Schema: TJSONObject; const Instance: TJSONValue; + out Errors: TArray): Boolean; +begin + var ErrorList := TStringList.Create; + try + Result := ValidateNode(Schema, Instance, 'value', 0, Schema, ErrorList); + Errors := ErrorList.ToStringArray; + finally + ErrorList.Free; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.Serializer.pas b/src/Protocol/MCPServer.Serializer.pas index d3ea794..8249c3b 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -18,27 +18,27 @@ TMCPSerializer = class class procedure DeserializeObject(Instance: TObject; const Json: TJSONObject); class function DeserializeArray(RttiType: TRttiType; const JsonArray: TJSONArray): TValue; - // Extracted type conversion methods class function ConvertJsonToValue(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; class function ConvertJsonToEnum(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; class function GetEnumValueNames(const EnumType: TRttiEnumerationType): string; class function ConvertValueToJson(const Value: TValue; const RttiType: TRttiType): TJSONValue; + class function TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; class function CreateInstanceFromType(const RttiType: TRttiType): TObject; - // Array deserialization helpers class function DeserializeDynamicArray(const DynArrayType: TRttiDynamicArrayType; const JsonArray: TJSONArray): TValue; class function DeserializeGenericList(const ListType: TRttiInstanceType; const JsonArray: TJSONArray): TValue; class function FindAddMethod(const ListType: TRttiInstanceType): TRttiMethod; - // Case-insensitive JSON value lookup class function GetJsonValueCaseInsensitive(const Json: TJSONObject; const PropName: string): TJSONValue; - // Single normalization rule shared by lookup and validation class function NormalizeKey(const Name: string): string; inline; + class function IsRequiredProperty(const Prop: TRttiProperty): Boolean; public class constructor Create; class destructor Destroy; + class function GetWireName(const Prop: TRttiProperty): string; + class function Deserialize(const Json: TJSONObject): T; class procedure Serialize(Obj: TObject; Json: TJSONObject); @@ -47,6 +47,11 @@ TMCPSerializer = class implementation +uses + System.Math, + System.DateUtils, + MCPServer.Types; + { TMCPSerializer } class constructor TMCPSerializer.Create; @@ -106,7 +111,7 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: try for RttiProp in RttiType.GetProperties do if RttiProp.IsWritable then - KnownNorms.Add(NormalizeKey(RttiProp.Name)); + KnownNorms.Add(NormalizeKey(GetWireName(RttiProp))); for Pair in Json do begin @@ -125,16 +130,20 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: if not RttiProp.IsWritable then Continue; - JsonValue := GetJsonValueCaseInsensitive(Json, RttiProp.Name); + JsonValue := GetJsonValueCaseInsensitive(Json, GetWireName(RttiProp)); - if not Assigned(JsonValue) then + if not Assigned(JsonValue) or (JsonValue is TJSONNull) then + begin + if IsRequiredProperty(RttiProp) then + raise EArgumentException.CreateFmt('Missing required parameter "%s"', [GetWireName(RttiProp)]); Continue; + end; try PropValue := ConvertJsonToValue(JsonValue, RttiProp.PropertyType); except on E: EArgumentException do - raise EArgumentException.CreateFmt('Parameter "%s": %s', [LowerCase(RttiProp.Name), E.Message]); + raise EArgumentException.CreateFmt('Parameter "%s": %s', [GetWireName(RttiProp), E.Message]); end; if not PropValue.IsEmpty then @@ -146,6 +155,22 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: end; end; +class function TMCPSerializer.IsRequiredProperty(const Prop: TRttiProperty): Boolean; +begin + for var Attr in Prop.GetAttributes do + if Attr is OptionalAttribute then + Exit(False); + Result := True; +end; + +class function TMCPSerializer.GetWireName(const Prop: TRttiProperty): string; +begin + for var Attr in Prop.GetAttributes do + if Attr is SchemaNameAttribute then + Exit(SchemaNameAttribute(Attr).Name); + Result := LowerCase(Prop.Name); +end; + class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); var JsonValue: TJSONValue; @@ -161,13 +186,13 @@ class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); if not RttiProp.IsReadable then Continue; - PropName := LowerCase(RttiProp.Name); + PropName := GetWireName(RttiProp); {$WARN UNSAFE_CAST OFF} PropValue := RttiProp.GetValue(Obj); {$WARN UNSAFE_CAST ON} - + JsonValue := ConvertValueToJson(PropValue, RttiProp.PropertyType); - + if Assigned(JsonValue) then Json.AddPair(PropName, JsonValue); end; @@ -191,53 +216,58 @@ class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; co NestedInstance: TObject; begin Result := TValue.Empty; - + if not Assigned(JsonValue) then Exit; - + case RttiType.TypeKind of - tkInteger: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsInt - else - Result := StrToIntDef(JsonValue.Value, 0); + tkInteger, tkInt64: + begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected an integer'); + var Number := TJSONNumber(JsonValue); + if Frac(Number.AsDouble) <> 0 then + raise EArgumentException.Create('expected an integer'); + if RttiType.TypeKind = tkInt64 then + Result := Number.AsInt64 + else + Result := TValue.FromOrdinal(RttiType.Handle, Number.AsInt64); + end; - tkInt64: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsInt64 - else - Result := StrToInt64Def(JsonValue.Value, 0); - tkFloat: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsDouble + if RttiType.Handle = TypeInfo(TDateTime) then + begin + if not (JsonValue is TJSONString) then + raise EArgumentException.Create('expected a date-time string'); + try + Result := TValue.From(ISO8601ToDate(JsonValue.Value, False)); + except + raise EArgumentException.Create('expected an ISO 8601 date-time'); + end; + end else -{$IF COMPILERVERSION <= 28} - Result := StrToFloatDef(JsonValue.Value, 0, TFormatSettings.Create('en-US')); -{$ELSE} - Result := StrToFloatDef(JsonValue.Value, 0, FormatSettings.Invariant); -{$ENDIF} + begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected a number'); + Result := TJSONNumber(JsonValue).AsDouble; + end; tkString, tkLString, tkWString, tkUString: - Result := JsonValue.Value; - + begin + if not (JsonValue is TJSONString) or (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected a string'); + Result := JsonValue.Value; + end; + tkEnumeration: if RttiType.Handle = TypeInfo(Boolean) then begin -{$IF COMPILERVERSION <= 29} - if (JsonValue is TJSONTrue) or (JsonValue is TJSONFalse) then - Result := JsonValue is TJSONTrue -{$ELSE} - if JsonValue is TJSONBool then - Result := (JsonValue as TJSONBool).AsBoolean -{$ENDIF} - else - Result := LowerCase(JsonValue.Value) = 'true'; + if not (JsonValue is TJSONBool) then + raise EArgumentException.Create('expected a boolean'); + Result := TJSONBool(JsonValue).AsBoolean; end else - begin Result := ConvertJsonToEnum(JsonValue, RttiType); - end; tkClass: if JsonValue is TJSONObject then @@ -245,16 +275,26 @@ class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; co NestedInstance := CreateInstanceFromType(RttiType); if Assigned(NestedInstance) then begin - DeserializeObject(NestedInstance, JsonValue as TJSONObject); + try + DeserializeObject(NestedInstance, JsonValue as TJSONObject); + except + NestedInstance.Free; + raise; + end; Result := NestedInstance; end; end else if JsonValue is TJSONArray then - Result := DeserializeArray(RttiType, JsonValue as TJSONArray); - + Result := DeserializeArray(RttiType, JsonValue as TJSONArray) + else + raise EArgumentException.Create('expected an object'); + tkDynArray: - if JsonValue is TJSONArray then + begin + if not (JsonValue is TJSONArray) then + raise EArgumentException.Create('expected an array'); Result := DeserializeArray(RttiType, JsonValue as TJSONArray); + end; end; end; @@ -309,12 +349,12 @@ class function TMCPSerializer.CreateInstanceFromType(const RttiType: TRttiType): MetaClass: TClass; begin Result := nil; - + if RttiType is TRttiInstanceType then begin InstanceType := TRttiInstanceType(RttiType); MetaClass := InstanceType.MetaclassType; - + if Assigned(MetaClass) then Result := MetaClass.Create; end; @@ -326,33 +366,66 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti Obj: TObject; begin Result := nil; - + if Value.IsEmpty then + begin + case RttiType.TypeKind of + tkClass: + Result := TJSONNull.Create; + tkDynArray: + Result := TJSONArray.Create; + end; Exit; - + end; + case RttiType.TypeKind of tkInteger: Result := TJSONNumber.Create(Value.AsInteger); tkInt64: Result := TJSONNumber.Create(Value.AsInt64); - + tkFloat: - Result := TJSONNumber.Create(Value.AsExtended); - - tkString, tkLString, tkWString, tkUString: + if RttiType.Handle = TypeInfo(TDateTime) then + Result := TJSONString.Create(DateToISO8601(Value.AsType, False)) + else + Result := TJSONNumber.Create(Value.AsExtended); + + tkString, tkLString, tkWString, tkUString, tkChar, tkWChar: Result := TJSONString.Create(Value.AsString); - + tkEnumeration: + if RttiType.Handle = TypeInfo(Boolean) then + Result := TJSONBool.Create(Value.AsBoolean) + else + Result := TJSONString.Create(GetEnumName(RttiType.Handle, Integer(Value.AsOrdinal))); + + tkSet: begin -{$IF COMPILERVERSION <= 29} - if Value.AsBoolean then - Result := TJSONTrue.Create - else - Result := TJSONFalse.Create; -{$ELSE} - Result := TJSONBool.Create(Value.AsBoolean); -{$ENDIF} + var Names := TJSONArray.Create; + var ElementType := TRttiEnumerationType(TRttiSetType(RttiType).ElementType); + var SetBits: Int64 := 0; + Move(Value.GetReferenceToRawData^, SetBits, Min(Value.DataSize, SizeOf(SetBits))); + var FirstBit := ElementType.MinValue and not 7; + for var Ordinal := ElementType.MinValue to ElementType.MaxValue do + if (SetBits and (Int64(1) shl (Ordinal - FirstBit))) <> 0 then + Names.Add(GetEnumName(ElementType.Handle, Ordinal)); + Result := Names; + end; + + tkDynArray: + begin + var Items := TJSONArray.Create; + var ElementType := TRttiDynamicArrayType(RttiType).ElementType; + for var I := 0 to Value.GetArrayLength - 1 do + begin + var Item := ConvertValueToJson(Value.GetArrayElement(I), ElementType); + if Assigned(Item) then + Items.AddElement(Item) + else + Items.AddElement(TJSONNull.Create); + end; + Result := Items; end; tkClass: @@ -364,23 +437,69 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti begin Result := TJSONValue(Obj).Clone as TJSONValue; end - else + else if not TrySerializeList(Obj, Result) then begin ChildJson := TJSONObject.Create; Serialize(Obj, ChildJson); Result := ChildJson; end; - end; + end + else + Result := TJSONNull.Create; end; end; +class function TMCPSerializer.TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; +var + ListType: TRttiType; + CountProp: TRttiProperty; + ItemsProp: TRttiIndexedProperty; + IndexParams: TArray; + Items: TJSONArray; + Item: TJSONValue; + Count: Integer; + I: Integer; +begin + Result := False; + Json := nil; + + ListType := FContext.GetType(Obj.ClassType); + CountProp := ListType.GetProperty('Count'); + ItemsProp := ListType.GetIndexedProperty('Items'); + if not Assigned(CountProp) or not Assigned(ItemsProp) or not ItemsProp.IsReadable + or not Assigned(ItemsProp.ReadMethod) then + Exit; + + IndexParams := ItemsProp.ReadMethod.GetParameters; + if (Length(IndexParams) <> 1) or not (IndexParams[0].ParamType.TypeKind in [tkInteger, tkInt64]) then + Exit; + + {$WARN UNSAFE_CAST OFF} + Count := Integer(CountProp.GetValue(Obj).AsInt64); + {$WARN UNSAFE_CAST ON} + Items := TJSONArray.Create; + for I := 0 to Count - 1 do + begin + {$WARN UNSAFE_CAST OFF} + Item := ConvertValueToJson(ItemsProp.GetValue(Obj, [I]), ItemsProp.PropertyType); + {$WARN UNSAFE_CAST ON} + if Assigned(Item) then + Items.AddElement(Item) + else + Items.AddElement(TJSONNull.Create); + end; + + Json := Items; + Result := True; +end; + class function TMCPSerializer.DeserializeArray(RttiType: TRttiType; const JsonArray: TJSONArray): TValue; begin Result := TValue.Empty; - + if RttiType is TRttiDynamicArrayType then Result := DeserializeDynamicArray(TRttiDynamicArrayType(RttiType), JsonArray) - else if (RttiType is TRttiInstanceType) and + else if (RttiType is TRttiInstanceType) and (TRttiInstanceType(RttiType).MetaclassType.InheritsFrom(TList)) then Result := DeserializeGenericList(TRttiInstanceType(RttiType), JsonArray); end; @@ -399,12 +518,12 @@ class function TMCPSerializer.DeserializeDynamicArray(const DynArrayType: TRttiD Result := TValue.Empty; TValue.Make(nil, DynArrayType.Handle, Result); DynArraySetLength(PPointer(Result.GetReferenceToRawData)^, Result.TypeInfo, 1, @ArrayLength); - + for I := 0 to ArrayLength - 1 do begin JsonElement := JsonArray.Items[Integer(I)]; ElementValue := ConvertJsonToValue(JsonElement, ElementType); - + if not ElementValue.IsEmpty then Result.SetArrayElement(I, ElementValue); end; @@ -420,25 +539,25 @@ class function TMCPSerializer.DeserializeGenericList(const ListType: TRttiInstan ParamType: TRttiType; begin ListInstance := ListType.MetaclassType.Create; - + AddMethod := FindAddMethod(ListType); if not Assigned(AddMethod) then begin ListInstance.Free; Exit(TValue.Empty); end; - + ParamType := AddMethod.GetParameters[0].ParamType; - + for I := 0 to JsonArray.Count - 1 do begin JsonElement := JsonArray.Items[I]; ElementValue := ConvertJsonToValue(JsonElement, ParamType); - + if not ElementValue.IsEmpty then AddMethod.Invoke(ListInstance, [ElementValue]); end; - + Result := ListInstance; end; @@ -447,7 +566,7 @@ class function TMCPSerializer.FindAddMethod(const ListType: TRttiInstanceType): Method: TRttiMethod; begin Result := nil; - + for Method in ListType.GetMethods do begin if SameText(Method.Name, 'Add') and (Length(Method.GetParameters) = 1) then diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index df0641f..038f92c 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -5,12 +5,87 @@ interface uses System.SysUtils, System.JSON, - System.Rtti; + System.Rtti, + System.Generics.Collections; const MCP_PROTOCOL_VERSION = '2025-06-18'; + MCP_PROTOCOL_VERSION_2025_03_26 = '2025-03-26'; + MCP_PROTOCOL_VERSION_2025_06_18 = '2025-06-18'; + MCP_PROTOCOL_VERSION_2025_11_25 = '2025-11-25'; + MCP_PROTOCOL_VERSION_2026_07_28 = '2026-07-28'; + + MCP_LATEST_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2026_07_28; + MCP_LATEST_LEGACY_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2025_11_25; + + MCP_LEGACY_PROTOCOL_VERSIONS: array[0..1] of string = ( + MCP_PROTOCOL_VERSION_2025_11_25, + MCP_PROTOCOL_VERSION_2025_06_18 + ); + MCP_MODERN_PROTOCOL_VERSIONS: array[0..0] of string = ( + MCP_PROTOCOL_VERSION_2026_07_28 + ); + + JSONRPC_PARSE_ERROR = -32700; + JSONRPC_INVALID_REQUEST = -32600; + JSONRPC_METHOD_NOT_FOUND = -32601; + JSONRPC_INVALID_PARAMS = -32602; + JSONRPC_INTERNAL_ERROR = -32603; + + MCP_ERROR_HEADER_MISMATCH = -32020; + MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY = -32021; + MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION = -32022; + MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY = -32002; + + MCP_META_PROTOCOL_VERSION = 'io.modelcontextprotocol/protocolVersion'; + MCP_META_CLIENT_CAPABILITIES = 'io.modelcontextprotocol/clientCapabilities'; + MCP_META_CLIENT_INFO = 'io.modelcontextprotocol/clientInfo'; + MCP_META_LOG_LEVEL = 'io.modelcontextprotocol/logLevel'; + MCP_META_SERVER_INFO = 'io.modelcontextprotocol/serverInfo'; + MCP_META_SUBSCRIPTION_ID = 'io.modelcontextprotocol/subscriptionId'; + MCP_META_PROGRESS_TOKEN = 'progressToken'; + + MCP_METHOD_NOTIFICATIONS_CANCELLED = 'notifications/cancelled'; + MCP_METHOD_NOTIFICATIONS_PROGRESS = 'notifications/progress'; + + MCP_CACHE_SCOPE_PUBLIC = 'public'; + MCP_CACHE_SCOPE_PRIVATE = 'private'; + + MCP_CACHEABLE_METHODS: array[0..5] of string = ( + 'server/discover', + 'tools/list', + 'prompts/list', + 'resources/list', + 'resources/templates/list', + 'resources/read' + ); + + MCP_METHOD_NOTIFICATIONS_MESSAGE = 'notifications/message'; + MCP_SCOPE_ANY = '*'; + MCP_METHOD_SUBSCRIPTIONS_LISTEN = 'subscriptions/listen'; + MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED = 'notifications/subscriptions/acknowledged'; + MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED = 'notifications/tools/list_changed'; + MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED = 'notifications/prompts/list_changed'; + MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED = 'notifications/resources/list_changed'; + MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED = 'notifications/resources/updated'; + MCP_LOG_LEVELS: array[0..7] of string = ( + 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); + +function IsLegacyProtocolVersion(const Version: string): Boolean; +function IsModernProtocolVersion(const Version: string): Boolean; +function NegotiateLegacyProtocolVersion(const Requested: string): string; + type + TMCPLogLevel = record + class function Rank(const Level: string): Integer; static; + class function IsKnown(const Level: string): Boolean; static; + end; + + TMCPConstantTime = record + class function SameBytes(const A, B: TBytes): Boolean; static; + end; + OptionalAttribute = class(TCustomAttribute) end; @@ -22,6 +97,38 @@ SchemaDescriptionAttribute = class(TCustomAttribute) property Description: string read FDescription; end; + SchemaTitleAttribute = class(TCustomAttribute) + private + FTitle: string; + public + constructor Create(const ATitle: string); + property Title: string read FTitle; + end; + + SchemaFormatAttribute = class(TCustomAttribute) + private + FFormat: string; + public + constructor Create(const AFormat: string); + property Format: string read FFormat; + end; + + SchemaMinimumAttribute = class(TCustomAttribute) + private + FMinimum: Double; + public + constructor Create(const AMinimum: Double); + property Minimum: Double read FMinimum; + end; + + SchemaMaximumAttribute = class(TCustomAttribute) + private + FMaximum: Double; + public + constructor Create(const AMaximum: Double); + property Maximum: Double read FMaximum; + end; + SchemaEnumAttribute = class(TCustomAttribute) private FValues: TArray; @@ -34,21 +141,254 @@ SchemaEnumAttribute = class(TCustomAttribute) property Values: TArray read FValues; end; + SchemaMinLengthAttribute = class(TCustomAttribute) + private + FMinLength: Integer; + public + constructor Create(const AMinLength: Integer); + property MinLength: Integer read FMinLength; + end; + + SchemaMaxLengthAttribute = class(TCustomAttribute) + private + FMaxLength: Integer; + public + constructor Create(const AMaxLength: Integer); + property MaxLength: Integer read FMaxLength; + end; + + SchemaPatternAttribute = class(TCustomAttribute) + private + FPattern: string; + public + constructor Create(const APattern: string); + property Pattern: string read FPattern; + end; + + SchemaDefaultAttribute = class(TCustomAttribute) + private + FJson: string; + public + constructor Create(const AJson: string); + property Json: string read FJson; + end; + + SchemaNameAttribute = class(TCustomAttribute) + private + FName: string; + public + constructor Create(const AName: string); + property Name: string read FName; + end; + + SchemaAdditionalPropertiesAttribute = class(TCustomAttribute) + private + FAllowed: Boolean; + public + constructor Create(const AAllowed: Boolean); + property Allowed: Boolean read FAllowed; + end; + + SchemaDialectAttribute = class(TCustomAttribute) + private + FUri: string; + public + constructor Create(const AUri: string); + property Uri: string read FUri; + end; + TMCPToolsCapability = class; - + IMCPCapabilityManager = interface ['{E5F7C3A1-8B4D-4F6E-9C2A-1D3E5F7A9B8C}'] function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; end; - + IMCPManagerRegistry = interface ['{A2B4C6D8-1E3F-5A7B-9C8D-2F4E6A8C0B2D}'] procedure RegisterManager(const Manager: IMCPCapabilityManager); function GetManagerForMethod(const Method: string): IMCPCapabilityManager; end; - + + IMCPManagerEnumerator = interface + ['{6D1F0B2C-3A4E-4F5B-8C7D-9E0F1A2B3C4D}'] + function GetManagers: TArray; + end; + + IMCPRegistryAware = interface + ['{2B7C9D1E-4F6A-4B8C-9D0E-1F2A3B4C5D6E}'] + procedure SetManagerRegistry(const Registry: IMCPManagerRegistry); + end; + + {$SCOPEDENUMS ON} + TMCPProtocolEra = (Legacy, Modern); + + TMCPRequestIdKind = (None, Null, Text, Number, Invalid); + {$SCOPEDENUMS OFF} + + TMCPRequestId = record + Kind: TMCPRequestIdKind; + Text: string; + Number: Int64; + class function FromJson(const Value: TJSONValue): TMCPRequestId; static; + class function FromNumber(const Value: Int64): TMCPRequestId; static; + class function FromText(const Value: string): TMCPRequestId; static; + function IsPresent: Boolean; + function ToJson: TJSONValue; + function AsText: string; + end; + + TMCPLegacySession = class + private + FProtocolVersion: string; + FLock: TObject; + function GetProtocolVersion: string; + procedure SetProtocolVersion(const Value: string); + public + constructor Create; + destructor Destroy; override; + property ProtocolVersion: string read GetProtocolVersion write SetProtocolVersion; + end; + + IMCPMessageSink = interface + ['{2B7D4E90-6C1A-4F3B-9E8D-5A0C1B2D3E4F}'] + procedure Send(const Json: string); + end; + + IMCPKeepAlive = interface + ['{9C2E4A6B-1D3F-4E5A-B7C9-0D2E4F6A8B1C}'] + procedure KeepAlive; + end; + + IMCPSubscriptionHub = interface + ['{3E5A7C9B-2D4F-4A6B-8C1E-5F7A9B0C2D4E}'] + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + end; + + IMCPRequestContext = interface + ['{7E3A9C1B-5D2F-4A6E-8B0C-3D4E5F6A7B8C}'] + function GetEra: TMCPProtocolEra; + function GetProtocolVersion: string; + function GetMethod: string; + function GetRequestId: TMCPRequestId; + function GetMeta: TJSONObject; + function GetClientCapabilities: TJSONObject; + function GetClientInfo: TJSONObject; + function GetLogLevel: string; + function GetProgressToken: TJSONValue; + function GetLegacySession: TMCPLegacySession; + function GetManagerRegistry: IMCPManagerRegistry; + function GetInputResponses: TJSONObject; + function GetRequestState: TJSONObject; + function GetSink: IMCPMessageSink; + function GetPrincipal: string; + function GetScopes: TArray; + + function HasClientCapability(const Path: string): Boolean; + function HasScope(const Scope: string): Boolean; + procedure RequireClientCapability(const Path: string); + function IsCancelled: Boolean; + procedure CheckCancelled; + procedure Cancel; + function HasProgressToken: Boolean; + procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); + function TryGetInputResponse(const Key: string; out Response: TJSONObject): Boolean; + procedure Log(const Level, Text: string; const Logger: string = ''); + procedure LogJson(const Level: string; const Data: TJSONValue; const Logger: string = ''); + + property Era: TMCPProtocolEra read GetEra; + property ProtocolVersion: string read GetProtocolVersion; + property Method: string read GetMethod; + property RequestId: TMCPRequestId read GetRequestId; + property Meta: TJSONObject read GetMeta; + property ClientCapabilities: TJSONObject read GetClientCapabilities; + property ClientInfo: TJSONObject read GetClientInfo; + property LogLevel: string read GetLogLevel; + property ProgressToken: TJSONValue read GetProgressToken; + property LegacySession: TMCPLegacySession read GetLegacySession; + property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; + property InputResponses: TJSONObject read GetInputResponses; + property RequestState: TJSONObject read GetRequestState; + property Sink: IMCPMessageSink read GetSink; + property Principal: string read GetPrincipal; + property Scopes: TArray read GetScopes; + end; + + IMCPRequestTracker = interface + ['{8C5E1F2A-3B4D-4E6F-A1B2-C3D4E5F6A7B8}'] + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + end; + + IMCPCapabilityManagerEx = interface + ['{9F4B2D6A-1C3E-4E5F-A7B8-C9D0E1F2A3B4}'] + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + end; + + IMCPCapabilityProvider = interface + ['{C5D7E9F1-2A4B-4C6D-8E0F-1A2B3C4D5E6F}'] + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + end; + + IMCPToolMetadata = interface + ['{D2E4F6A8-1B3C-4D5E-9F0A-2B3C4D5E6F70}'] + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; + property Annotations: TJSONObject read GetAnnotations; + property Icons: TJSONArray read GetIcons; + end; + + IMCPBinaryResource = interface + ['{E3F5A7B9-2C4D-4E6F-A0B1-3C4D5E6F7081}'] + function ReadBinary: TBytes; + end; + + IMCPResourceMetadata = interface + ['{F4A6B8CA-3D5E-4F70-B1C2-4D5E6F708192}'] + function GetTitle: string; + function GetSize: Int64; + function GetAnnotations: TJSONObject; + property Title: string read GetTitle; + property Size: Int64 read GetSize; + property Annotations: TJSONObject read GetAnnotations; + end; + + IMCPCacheableResource = interface + ['{05B7C9DB-4E6F-4081-C2D3-5E6F708192A3}'] + function GetTtlMs: Integer; + function GetCacheScope: string; + property TtlMs: Integer read GetTtlMs; + property CacheScope: string read GetCacheScope; + end; + + IMCPPromptMetadata = interface + ['{16C8DAEC-5F70-4192-D3E4-6F708192A3B4}'] + function GetIcons: TJSONArray; + property Icons: TJSONArray read GetIcons; + end; + + TMCPCompletion = record + Values: TArray; + Total: Integer; + HasMore: Boolean; + class function Create(const Values: TArray; Total: Integer = -1): TMCPCompletion; static; + end; + + IMCPCompletable = interface + ['{27D9EBFD-6081-42A3-E4F5-708192A3B4C5}'] + function Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; + end; + TMCPCapabilities = class private FTools: TMCPToolsCapability; @@ -110,8 +450,181 @@ TMCPToolsResponse = class property Tools: TArray read FTools write FTools; end; +function IsJsonString(const Value: TJSONValue): Boolean; + implementation +class function TMCPLogLevel.Rank(const Level: string): Integer; +begin + for var I := Low(MCP_LOG_LEVELS) to High(MCP_LOG_LEVELS) do + begin + if MCP_LOG_LEVELS[I] = Level then + Exit(I); + end; + Result := -1; +end; + +class function TMCPLogLevel.IsKnown(const Level: string): Boolean; +begin + Result := Rank(Level) >= 0; +end; + +class function TMCPConstantTime.SameBytes(const A, B: TBytes): Boolean; +begin + var Difference := Length(A) xor Length(B); + var Longest := Length(A); + if Length(B) > Longest then + Longest := Length(B); + for var I := 0 to Longest - 1 do + begin + var Left := 0; + var Right := 0; + if I < Length(A) then + Left := A[I]; + if I < Length(B) then + Right := B[I]; + Difference := Difference or (Left xor Right); + end; + Result := Difference = 0; +end; + +function IsJsonString(const Value: TJSONValue): Boolean; +begin + Result := (Value is TJSONString) and not (Value is TJSONNumber); +end; + +{ TMCPLegacySession } + +constructor TMCPLegacySession.Create; +begin + inherited Create; + FLock := TObject.Create; +end; + +destructor TMCPLegacySession.Destroy; +begin + FLock.Free; + inherited; +end; + +function TMCPLegacySession.GetProtocolVersion: string; +begin + TMonitor.Enter(FLock); + try + Result := FProtocolVersion; + finally + TMonitor.Exit(FLock); + end; +end; + +procedure TMCPLegacySession.SetProtocolVersion(const Value: string); +begin + TMonitor.Enter(FLock); + try + FProtocolVersion := Value; + finally + TMonitor.Exit(FLock); + end; +end; + +function IsLegacyProtocolVersion(const Version: string): Boolean; +begin + for var Known in MCP_LEGACY_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +function IsModernProtocolVersion(const Version: string): Boolean; +begin + for var Known in MCP_MODERN_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +function NegotiateLegacyProtocolVersion(const Requested: string): string; +begin + if IsLegacyProtocolVersion(Requested) then + Result := Requested + else + Result := MCP_LATEST_LEGACY_PROTOCOL_VERSION; +end; + +{ TMCPRequestId } + +class function TMCPRequestId.FromJson(const Value: TJSONValue): TMCPRequestId; +begin + Result.Text := ''; + Result.Number := 0; + + if not Assigned(Value) then + Result.Kind := TMCPRequestIdKind.None + else if Value is TJSONNull then + Result.Kind := TMCPRequestIdKind.Null + else if Value is TJSONNumber then + begin + var Number := TJSONNumber(Value); + if Frac(Number.AsDouble) = 0 then + begin + Result.Kind := TMCPRequestIdKind.Number; + Result.Number := Number.AsInt64; + end + else + Result.Kind := TMCPRequestIdKind.Invalid; + end + else if Value is TJSONString then + begin + Result.Kind := TMCPRequestIdKind.Text; + Result.Text := TJSONString(Value).Value; + end + else + Result.Kind := TMCPRequestIdKind.Invalid; +end; + +class function TMCPRequestId.FromNumber(const Value: Int64): TMCPRequestId; +begin + Result.Kind := TMCPRequestIdKind.Number; + Result.Number := Value; + Result.Text := ''; +end; + +class function TMCPRequestId.FromText(const Value: string): TMCPRequestId; +begin + Result.Kind := TMCPRequestIdKind.Text; + Result.Number := 0; + Result.Text := Value; +end; + +function TMCPRequestId.IsPresent: Boolean; +begin + Result := Kind in [TMCPRequestIdKind.Text, TMCPRequestIdKind.Number]; +end; + +function TMCPRequestId.ToJson: TJSONValue; +begin + case Kind of + TMCPRequestIdKind.Text: + Result := TJSONString.Create(Text); + TMCPRequestIdKind.Number: + Result := TJSONNumber.Create(Number); + else + Result := TJSONNull.Create; + end; +end; + +function TMCPRequestId.AsText: string; +begin + case Kind of + TMCPRequestIdKind.Text: + Result := Text; + TMCPRequestIdKind.Number: + Result := Number.ToString; + else + Result := ''; + end; +end; + { SchemaDescriptionAttribute } constructor SchemaDescriptionAttribute.Create(const ADescription: string); @@ -120,6 +633,38 @@ constructor SchemaDescriptionAttribute.Create(const ADescription: string); FDescription := ADescription; end; +{ SchemaTitleAttribute } + +constructor SchemaTitleAttribute.Create(const ATitle: string); +begin + inherited Create; + FTitle := ATitle; +end; + +{ SchemaFormatAttribute } + +constructor SchemaFormatAttribute.Create(const AFormat: string); +begin + inherited Create; + FFormat := AFormat; +end; + +{ SchemaMinimumAttribute } + +constructor SchemaMinimumAttribute.Create(const AMinimum: Double); +begin + inherited Create; + FMinimum := AMinimum; +end; + +{ SchemaMaximumAttribute } + +constructor SchemaMaximumAttribute.Create(const AMaximum: Double); +begin + inherited Create; + FMaximum := AMaximum; +end; + { SchemaEnumAttribute } constructor SchemaEnumAttribute.Create(const AValues: array of string); @@ -166,6 +711,81 @@ constructor SchemaEnumAttribute.Create(const AValue1, AValue2, AValue3, AValue4: FValues[3] := AValue4; end; +{ SchemaMinLengthAttribute } + +constructor SchemaMinLengthAttribute.Create(const AMinLength: Integer); +begin + inherited Create; + FMinLength := AMinLength; +end; + +{ SchemaMaxLengthAttribute } + +constructor SchemaMaxLengthAttribute.Create(const AMaxLength: Integer); +begin + inherited Create; + FMaxLength := AMaxLength; +end; + +{ SchemaPatternAttribute } + +constructor SchemaPatternAttribute.Create(const APattern: string); +begin + inherited Create; + FPattern := APattern; +end; + +{ SchemaDefaultAttribute } + +constructor SchemaDefaultAttribute.Create(const AJson: string); +begin + inherited Create; + FJson := AJson; +end; + +{ SchemaNameAttribute } + +constructor SchemaNameAttribute.Create(const AName: string); +begin + inherited Create; + FName := AName; +end; + +{ SchemaAdditionalPropertiesAttribute } + +constructor SchemaAdditionalPropertiesAttribute.Create(const AAllowed: Boolean); +begin + inherited Create; + FAllowed := AAllowed; +end; + +{ SchemaDialectAttribute } + +constructor SchemaDialectAttribute.Create(const AUri: string); +begin + inherited Create; + FUri := AUri; +end; + +{ TMCPCompletion } + +class function TMCPCompletion.Create(const Values: TArray; Total: Integer): TMCPCompletion; +const + MAX_COMPLETION_VALUES = 100; +begin + if Length(Values) > MAX_COMPLETION_VALUES then + begin + Result.Values := Copy(Values, 0, MAX_COMPLETION_VALUES); + Result.HasMore := True; + end + else + begin + Result.Values := Values; + Result.HasMore := False; + end; + Result.Total := Total; +end; + { TMCPInitializeResponse } constructor TMCPInitializeResponse.Create; diff --git a/src/Resources/MCPServer.Resource.Base.pas b/src/Resources/MCPServer.Resource.Base.pas index 09aa327..f30175e 100644 --- a/src/Resources/MCPServer.Resource.Base.pas +++ b/src/Resources/MCPServer.Resource.Base.pas @@ -5,7 +5,11 @@ interface uses System.SysUtils, System.Rtti, - System.JSON; + System.JSON, + System.Generics.Collections, + System.RegularExpressions, + System.SyncObjs, + MCPServer.Types; type IMCPResource = interface @@ -15,28 +19,39 @@ interface function GetDescription: string; function GetMimeType: string; function Read: string; - + property URI: string read GetURI; property Name: string read GetName; property Description: string read GetDescription; property MimeType: string read GetMimeType; end; - - TMCPResourceBase = class(TInterfacedObject, IMCPResource) + + TMCPResourceBase = class(TInterfacedObject, IMCPResource, + IMCPResourceMetadata, IMCPCacheableResource) protected FURI: string; FName: string; FDescription: string; FMimeType: string; + FTitle: string; + FSize: Int64; + FAnnotations: TJSONObject; + FTtlMs: Integer; + FCacheScope: string; function GetResourceData: T; virtual; abstract; public constructor Create; virtual; destructor Destroy; override; - + function GetURI: string; function GetName: string; function GetDescription: string; function GetMimeType: string; + function GetTitle: string; + function GetSize: Int64; + function GetAnnotations: TJSONObject; + function GetTtlMs: Integer; + function GetCacheScope: string; function Read: string; end; @@ -51,6 +66,53 @@ TResourceContent = class property Text: string read FText write FText; end; + TMCPTemplateVars = TDictionary; + + IMCPResourceTemplate = interface + ['{3A5C7E91-8042-4A5B-B6C7-D8E9F0A1B2C3}'] + function GetUriTemplate: string; + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetMimeType: string; + function Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; + + property UriTemplate: string read GetUriTemplate; + property Name: string read GetName; + property Title: string read GetTitle; + property Description: string read GetDescription; + property MimeType: string read GetMimeType; + end; + + TMCPResourceTemplateBase = class(TInterfacedObject, IMCPResourceTemplate) + strict private + FPattern: string; + FVariableNames: TArray; + FCompiled: Boolean; + FCompileLock: TCriticalSection; + procedure EnsureCompiled; + class function PercentDecode(const Text: string): string; static; + class function CompilePattern(const UriTemplate: string; out VariableNames: TArray): string; static; + protected + FUriTemplate: string; + FName: string; + FTitle: string; + FDescription: string; + FMimeType: string; + public + constructor Create; virtual; + destructor Destroy; override; + + function GetUriTemplate: string; + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetMimeType: string; + function Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; virtual; abstract; + end; + implementation uses @@ -61,10 +123,14 @@ implementation constructor TMCPResourceBase.Create; begin inherited; + FSize := -1; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; end; destructor TMCPResourceBase.Destroy; begin + FAnnotations.Free; inherited; end; @@ -88,6 +154,31 @@ function TMCPResourceBase.GetMimeType: string; Result := FMimeType; end; +function TMCPResourceBase.GetTitle: string; +begin + Result := FTitle; +end; + +function TMCPResourceBase.GetSize: Int64; +begin + Result := FSize; +end; + +function TMCPResourceBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPResourceBase.GetTtlMs: Integer; +begin + Result := FTtlMs; +end; + +function TMCPResourceBase.GetCacheScope: string; +begin + Result := FCacheScope; +end; + function TMCPResourceBase.Read: string; var Ctx: TRttiContext; @@ -133,4 +224,149 @@ function TMCPResourceBase.Read: string; end; end; -end. \ No newline at end of file +{ TMCPResourceTemplateBase } + +constructor TMCPResourceTemplateBase.Create; +begin + inherited Create; + FMimeType := ''; + FCompileLock := TCriticalSection.Create; +end; + +destructor TMCPResourceTemplateBase.Destroy; +begin + FCompileLock.Free; + inherited; +end; + +class function TMCPResourceTemplateBase.PercentDecode(const Text: string): string; +begin + var Bytes: TBytes := nil; + var Utf8 := TEncoding.UTF8.GetBytes(Text); + var I := 0; + while I < Length(Utf8) do + begin + if (Utf8[I] = Ord('%')) and (I + 2 < Length(Utf8)) then + begin + var Hex := Char(Utf8[I + 1]) + Char(Utf8[I + 2]); + var Value := StrToIntDef('$' + Hex, -1); + if Value >= 0 then + begin + Bytes := Bytes + [Byte(Value)]; + Inc(I, 3); + Continue; + end; + end; + Bytes := Bytes + [Utf8[I]]; + Inc(I); + end; + Result := TEncoding.UTF8.GetString(Bytes); +end; + +class function TMCPResourceTemplateBase.CompilePattern(const UriTemplate: string; + out VariableNames: TArray): string; +var + Names: TList; + Position: Integer; + CloseBrace: Integer; + Expr, VarName, LiteralRun: string; +begin + Names := TList.Create; + try + Result := ''; + Position := 1; + while Position <= Length(UriTemplate) do + begin + if UriTemplate[Position] = '{' then + begin + CloseBrace := System.Pos('}', UriTemplate, Position); + if CloseBrace = 0 then + raise EArgumentException.CreateFmt('Unterminated "{" in URI template "%s"', [UriTemplate]); + + Expr := Copy(UriTemplate, Position + 1, CloseBrace - Position - 1); + if (Expr <> '') and (Expr[1] = '+') then + begin + VarName := Copy(Expr, 2, MaxInt); + Result := Result + Format('(?<%s>.+)', [VarName]); + end + else + begin + VarName := Expr; + Result := Result + Format('(?<%s>[^/]+)', [VarName]); + end; + if VarName = '' then + raise EArgumentException.CreateFmt('Empty variable name in URI template "%s"', [UriTemplate]); + for var C in VarName do + if not CharInSet(C, ['A'..'Z', 'a'..'z', '0'..'9', '_']) then + raise EArgumentException.CreateFmt('Variable name "%s" in URI template "%s" may only contain letters, digits and underscores', + [VarName, UriTemplate]); + + Names.Add(VarName); + Position := CloseBrace + 1; + end + else + begin + var LiteralStart := Position; + while (Position <= Length(UriTemplate)) and (UriTemplate[Position] <> '{') do + Inc(Position); + LiteralRun := Copy(UriTemplate, LiteralStart, Position - LiteralStart); + Result := Result + TRegEx.Escape(LiteralRun); + end; + end; + Result := '^' + Result + '$'; + VariableNames := Names.ToArray; + finally + Names.Free; + end; +end; + +procedure TMCPResourceTemplateBase.EnsureCompiled; +begin + FCompileLock.Enter; + try + if not FCompiled then + begin + FPattern := CompilePattern(FUriTemplate, FVariableNames); + FCompiled := True; + end; + finally + FCompileLock.Leave; + end; +end; + +function TMCPResourceTemplateBase.GetUriTemplate: string; +begin + Result := FUriTemplate; +end; + +function TMCPResourceTemplateBase.GetName: string; +begin + Result := FName; +end; + +function TMCPResourceTemplateBase.GetTitle: string; +begin + Result := FTitle; +end; + +function TMCPResourceTemplateBase.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPResourceTemplateBase.GetMimeType: string; +begin + Result := FMimeType; +end; + +function TMCPResourceTemplateBase.Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; +begin + EnsureCompiled; + var Match := TRegEx.Match(URI, FPattern); + Result := Match.Success; + if Result then + for var VarName in FVariableNames do + Vars.AddOrSetValue(VarName, PercentDecode(Match.Groups[VarName].Value)); +end; + +end. diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index cb5f02f..3366155 100644 --- a/src/Resources/MCPServer.Resource.Logs.pas +++ b/src/Resources/MCPServer.Resource.Logs.pas @@ -7,6 +7,7 @@ interface System.Classes, System.Generics.Collections, System.SyncObjs, + MCPServer.Types, MCPServer.Resource.Base; type @@ -33,7 +34,7 @@ TLogEntries = class public constructor Create; destructor Destroy; override; - + property Entries: TObjectList read FEntries write FEntries; property TotalCount: NativeInt read FTotalCount write FTotalCount; property FilteredCount: NativeInt read FFilteredCount write FFilteredCount; @@ -48,10 +49,10 @@ TLogBuffer = class public constructor Create; destructor Destroy; override; - + class function Instance: TLogBuffer; class procedure Finalize; - + procedure AddLog(const ALevel, AMessage, ACategory: string); function GetLogs(AMaxCount: NativeInt = 100; const ALevel: string = ''): TObjectList; end; @@ -63,6 +64,22 @@ TLogsRecentResource = class(TMCPResourceBase) constructor Create; override; end; + TLogsByLevelResource = class(TMCPResourceBase) + private + FLevel: string; + protected + function GetResourceData: TLogEntries; override; + public + constructor CreateForLevel(const AUri, ALevel: string); reintroduce; + end; + + TLogsByLevelTemplate = class(TMCPResourceTemplateBase, IMCPCompletable) + public + constructor Create; override; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; override; + function Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; + end; implementation @@ -74,6 +91,9 @@ implementation System.Math, MCPServer.Registration; +const + MAX_RECENT_LOG_ENTRIES = 100; + { TLogEntries } constructor TLogEntries.Create; @@ -143,10 +163,9 @@ procedure TLogBuffer.AddLog(const ALevel, AMessage, ACategory: string); {$ELSE} Entry.ThreadID := TThread.CurrentThread.ThreadID; {$ENDIF} - + FLogs.Add(Entry); - - // Remove earliest entries if buffer exceeds maximum capacity + while FLogs.Count > FMaxEntries do begin FLogs[0].Free; @@ -164,11 +183,11 @@ function TLogBuffer.GetLogs(AMaxCount: NativeInt; const ALevel: string): TObject StartIndex: NativeInt; begin Result := TObjectList.Create(True); - + FLock.Acquire; try StartIndex := Max(0, FLogs.Count - AMaxCount); - + for i := StartIndex to FLogs.Count - 1 do begin Entry := FLogs[i]; @@ -197,6 +216,8 @@ constructor TLogsRecentResource.Create; FName := 'Recent Logs'; FDescription := 'Recent log entries from all categories'; FMimeType := 'application/json'; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; end; function TLogsRecentResource.GetResourceData: TLogEntries; @@ -204,39 +225,112 @@ function TLogsRecentResource.GetResourceData: TLogEntries; Logs: TObjectList; begin Result := TLogEntries.Create; - - // Add access log entry - TLogBuffer.Instance.AddLog('INFO', 'Resource accessed: logs://recent', 'ACCESS'); - - Logs := TLogBuffer.Instance.GetLogs(100); + + Logs := TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES); + try + Result.Entries.AddRange(Logs); + Result.TotalCount := Logs.Count; + Result.FilteredCount := Logs.Count; + Logs.OwnsObjects := False; + finally + Logs.Free; + end; +end; + +{ TLogsByLevelResource } + +constructor TLogsByLevelResource.CreateForLevel(const AUri, ALevel: string); +begin + inherited Create; + FLevel := ALevel; + FURI := AUri; + FName := 'Recent logs (' + ALevel + ')'; + FDescription := 'Recent log entries at level ' + ALevel; + FMimeType := 'application/json'; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; +end; + +function TLogsByLevelResource.GetResourceData: TLogEntries; +var + Logs: TObjectList; +begin + Result := TLogEntries.Create; + + Logs := TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES, FLevel); try - Result.Entries.AddRange(Logs.ToArray); + Result.Entries.AddRange(Logs); Result.TotalCount := Logs.Count; Result.FilteredCount := Logs.Count; + Logs.OwnsObjects := False; finally Logs.Free; end; end; +{ TLogsByLevelTemplate } + +constructor TLogsByLevelTemplate.Create; +begin + inherited; + FUriTemplate := 'logs://{level}'; + FName := 'Recent logs by level'; + FDescription := 'Recent log entries at the given level, e.g. logs://INFO'; + FMimeType := 'application/json'; +end; + +function TLogsByLevelTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TLogsByLevelResource.CreateForLevel(URI, Vars['level']); +end; + +function TLogsByLevelTemplate.Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; +begin + if ArgumentName <> 'level' then + Exit(TMCPCompletion.Create(nil)); + + var Levels := TStringList.Create; + try + Levels.Sorted := True; + Levels.Duplicates := dupIgnore; + var Entries := TLogBuffer.Instance.GetLogs(1000); + try + for var Entry in Entries do + if Entry.Level.StartsWith(Value, True) then + Levels.Add(Entry.Level); + finally + Entries.Free; + end; + Result := TMCPCompletion.Create(Levels.ToStringArray, Levels.Count); + finally + Levels.Free; + end; +end; initialization TLogBuffer.FLock := TCriticalSection.Create; - - // Example initialization logs + TLogBuffer.Instance.AddLog('INFO', 'MCP Server started', 'SYSTEM'); TLogBuffer.Instance.AddLog('INFO', 'Resources manager initialized', 'SYSTEM'); TLogBuffer.Instance.AddLog('INFO', 'Tools manager initialized', 'SYSTEM'); TLogBuffer.Instance.AddLog('WARNING', 'Debug mode is enabled', 'CONFIG'); TLogBuffer.Instance.AddLog('INFO', 'Server listening on port 8080', 'SERVER'); - - // Register Logs resources + TMCPRegistry.RegisterResource('logs://recent', function: IMCPResource begin Result := TLogsRecentResource.Create; end ); - + + TMCPRegistry.RegisterResourceTemplate('logs://{level}', + function: IMCPResourceTemplate + begin + Result := TLogsByLevelTemplate.Create; + end + ); + finalization TLogBuffer.Finalize; diff --git a/src/Resources/MCPServer.Resource.Project.pas b/src/Resources/MCPServer.Resource.Project.pas index c719540..0d87f1c 100644 --- a/src/Resources/MCPServer.Resource.Project.pas +++ b/src/Resources/MCPServer.Resource.Project.pas @@ -25,7 +25,7 @@ TProjectInfo = class public constructor Create; destructor Destroy; override; - + property Name: string read FName write FName; property Version: string read FVersion write FVersion; property Description: string read FDescription write FDescription; @@ -59,12 +59,14 @@ TProjectReadmeResource = class(TMCPResourceBase) constructor Create; override; end; - implementation uses MCPServer.Registration; +const + PROJECT_RESOURCE_TTL_MS = 3600000; + { TProjectInfo } constructor TProjectInfo.Create; @@ -88,6 +90,8 @@ constructor TProjectInfoResource.Create; FName := 'Project Information'; FDescription := 'Basic information about the Delphi MCP Server project'; FMimeType := 'application/json'; + FTtlMs := PROJECT_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; end; function TProjectInfoResource.GetResourceData: TProjectInfo; @@ -98,7 +102,8 @@ function TProjectInfoResource.GetResourceData: TProjectInfo; Result.Description := 'A Model Context Protocol (MCP) server implementation in Delphi'; Result.Language := 'Delphi'; Result.Framework := 'Indy HTTP Server (TIdHTTPServer)'; - Result.Protocol := 'MCP ' + MCP_PROTOCOL_VERSION; + Result.Protocol := 'MCP ' + MCP_LATEST_PROTOCOL_VERSION + ' (initialize-based: ' + + MCP_PROTOCOL_VERSION_2025_11_25 + ', ' + MCP_PROTOCOL_VERSION_2025_06_18 + ')'; Result.Transport := 'Streamable HTTP'; Result.Author := 'GDK Software'; Result.Repository := 'https://github.com/GDKsoftware/delphi-mcp-server'; @@ -117,6 +122,8 @@ constructor TProjectReadmeResource.Create; FName := 'Project README'; FDescription := 'README.md file contents'; FMimeType := 'text/markdown'; + FTtlMs := PROJECT_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; end; function TProjectReadmeResource.GetResourceData: TTextContent; @@ -151,7 +158,6 @@ function TProjectReadmeResource.GetResourceData: TTextContent; ''''; end; - initialization TMCPRegistry.RegisterResource('project://info', function: IMCPResource @@ -159,13 +165,13 @@ initialization Result := TProjectInfoResource.Create; end ); - + TMCPRegistry.RegisterResource('project://readme', function: IMCPResource begin Result := TProjectReadmeResource.Create; end ); - + end. \ No newline at end of file diff --git a/src/Resources/MCPServer.Resource.Samples.pas b/src/Resources/MCPServer.Resource.Samples.pas new file mode 100644 index 0000000..71ba323 --- /dev/null +++ b/src/Resources/MCPServer.Resource.Samples.pas @@ -0,0 +1,167 @@ +unit MCPServer.Resource.Samples; + +interface + +uses + System.SysUtils, + MCPServer.Types, + MCPServer.Resource.Base; + +type + TStaticText = class + private + FContent: string; + public + property Content: string read FContent write FContent; + end; + + TStaticTextResource = class(TMCPResourceBase) + protected + function GetResourceData: TStaticText; override; + public + constructor Create; override; + end; + + TStaticBinaryResource = class(TMCPResourceBase, IMCPBinaryResource) + protected + function GetResourceData: TStaticText; override; + public + constructor Create; override; + function ReadBinary: TBytes; + end; + + TTemplateData = class + private + FId: string; + FTemplateTest: Boolean; + FData: string; + public + property Id: string read FId write FId; + property TemplateTest: Boolean read FTemplateTest write FTemplateTest; + property Data: string read FData write FData; + end; + + TTemplateDataResource = class(TMCPResourceBase) + private + FId: string; + protected + function GetResourceData: TTemplateData; override; + public + constructor CreateForId(const AUri, AId: string); + end; + + TTemplateDataResourceTemplate = class(TMCPResourceTemplateBase) + public + constructor Create; override; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; override; + end; + +implementation + +uses + System.NetEncoding, + MCPServer.Registration, + MCPServer.Tool.ContentSamples; + +const + SAMPLE_RESOURCE_TTL_MS = 3600000; + +{ TStaticTextResource } + +constructor TStaticTextResource.Create; +begin + inherited; + FURI := SAMPLE_TEXT_RESOURCE_URI; + FName := 'Static text'; + FTitle := 'Static text resource'; + FDescription := 'A fixed text resource'; + FMimeType := 'text/plain'; + FTtlMs := SAMPLE_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; +end; + +function TStaticTextResource.GetResourceData: TStaticText; +begin + Result := TStaticText.Create; + Result.Content := SAMPLE_TEXT_RESOURCE_CONTENT; +end; + +{ TStaticBinaryResource } + +constructor TStaticBinaryResource.Create; +begin + inherited; + FURI := 'test://static-binary'; + FName := 'Static binary'; + FTitle := 'Static binary resource'; + FDescription := 'A fixed PNG image'; + FMimeType := 'image/png'; + FTtlMs := SAMPLE_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; +end; + +function TStaticBinaryResource.GetResourceData: TStaticText; +begin + Result := TStaticText.Create; + Result.Content := SAMPLE_PNG_BASE64; +end; + +function TStaticBinaryResource.ReadBinary: TBytes; +begin + Result := TNetEncoding.Base64.DecodeStringToBytes(SAMPLE_PNG_BASE64); +end; + +{ TTemplateDataResource } + +constructor TTemplateDataResource.CreateForId(const AUri, AId: string); +begin + inherited Create; + FId := AId; + FURI := AUri; + FName := 'Template data'; + FDescription := 'Data keyed by the id captured from the template'; + FMimeType := 'application/json'; +end; + +function TTemplateDataResource.GetResourceData: TTemplateData; +begin + Result := TTemplateData.Create; + Result.Id := FId; + Result.TemplateTest := True; + Result.Data := 'Data for ID: ' + FId; +end; + +{ TTemplateDataResourceTemplate } + +constructor TTemplateDataResourceTemplate.Create; +begin + inherited; + FUriTemplate := 'test://template/{id}/data'; + FName := 'Template data'; + FDescription := 'Data keyed by an id path segment'; + FMimeType := 'application/json'; +end; + +function TTemplateDataResourceTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TTemplateDataResource.CreateForId(URI, Vars['id']); +end; + +initialization + TMCPRegistry.RegisterResource(SAMPLE_TEXT_RESOURCE_URI, + function: IMCPResource + begin + Result := TStaticTextResource.Create; + end); + TMCPRegistry.RegisterResource('test://static-binary', + function: IMCPResource + begin + Result := TStaticBinaryResource.Create; + end); + TMCPRegistry.RegisterResourceTemplate('test://template/{id}/data', + function: IMCPResourceTemplate + begin + Result := TTemplateDataResourceTemplate.Create; + end); + +end. diff --git a/src/Resources/MCPServer.Resource.Server.pas b/src/Resources/MCPServer.Resource.Server.pas index f627f37..d46648b 100644 --- a/src/Resources/MCPServer.Resource.Server.pas +++ b/src/Resources/MCPServer.Resource.Server.pas @@ -28,13 +28,13 @@ TServerStatus = class property ActiveConnections: Integer read FActiveConnections write FActiveConnections; end; - TServerStatusResource = class(TMCPResourceBase) private class var FServerStartTime: TDateTime; class var FRequestCount: Int64; class var FActiveConnections: Integer; class var FNamePrefix: string; + class function StatusURI: string; protected function GetResourceData: TServerStatus; override; public @@ -47,7 +47,6 @@ TServerStatusResource = class(TMCPResourceBase) class procedure ConnectionClosed; end; - implementation uses @@ -58,7 +57,6 @@ implementation System.Classes, MCPServer.Registration; - { TServerStatusResource } class procedure TServerStatusResource.Initialize; @@ -69,22 +67,21 @@ class procedure TServerStatusResource.Initialize; FNamePrefix := ''; end; +class function TServerStatusResource.StatusURI: string; +begin + Result := 'server://' + FNamePrefix + 'status'; +end; + class procedure TServerStatusResource.SetNamePrefix(const Prefix: string); begin + TMCPRegistry.UnregisterResource(StatusURI); FNamePrefix := Prefix; RegisterServerStatusResource; end; class procedure TServerStatusResource.RegisterServerStatusResource; -var - URI: string; begin - if FNamePrefix <> '' then - URI := 'server://' + FNamePrefix + 'status' - else - URI := 'server://status'; - - TMCPRegistry.RegisterResource(URI, + TMCPRegistry.RegisterResource(StatusURI, function: IMCPResource begin Result := TServerStatusResource.Create; @@ -94,33 +91,31 @@ class procedure TServerStatusResource.RegisterServerStatusResource; class procedure TServerStatusResource.IncrementRequestCount; begin - Inc(FRequestCount); + AtomicIncrement(FRequestCount); end; class procedure TServerStatusResource.ConnectionOpened; begin - Inc(FActiveConnections); + AtomicIncrement(FActiveConnections); end; class procedure TServerStatusResource.ConnectionClosed; begin - if FActiveConnections > 0 then - Dec(FActiveConnections); + var Current := AtomicCmpExchange(FActiveConnections, 0, 0); + while Current > 0 do + begin + var Previous := AtomicCmpExchange(FActiveConnections, Current - 1, Current); + if Previous = Current then + Exit; + Current := Previous; + end; end; constructor TServerStatusResource.Create; begin inherited; - if FNamePrefix <> '' then - begin - FURI := 'server://' + FNamePrefix + 'status'; - FName := FNamePrefix + 'server_status'; - end - else - begin - FURI := 'server://status'; - FName := 'server_status'; - end; + FURI := StatusURI; + FName := FNamePrefix + 'server_status'; FDescription := 'Current server status and health information'; FMimeType := 'application/json'; end; @@ -136,9 +131,9 @@ function TServerStatusResource.GetResourceData: TServerStatus; Result.StartTime := FServerStartTime; Result.CurrentTime := Now; Result.Uptime := SecondsBetween(Now, FServerStartTime); - Result.RequestCount := FRequestCount; - Result.ActiveConnections := FActiveConnections; - + Result.RequestCount := AtomicCmpExchange(FRequestCount, 0, 0); + Result.ActiveConnections := AtomicCmpExchange(FActiveConnections, 0, 0); + {$IFDEF MSWINDOWS} ProcessMemoryCounters.cb := SizeOf(ProcessMemoryCounters); if GetProcessMemoryInfo(GetCurrentProcess, @ProcessMemoryCounters, SizeOf(ProcessMemoryCounters)) then @@ -146,12 +141,12 @@ function TServerStatusResource.GetResourceData: TServerStatus; else Result.MemoryUsed := 0; {$ELSE} - Result.MemoryUsed := 0; // Not implemented for other platforms + Result.MemoryUsed := 0; {$ENDIF} end; - initialization TServerStatusResource.Initialize; + TServerStatusResource.RegisterServerStatusResource; end. \ No newline at end of file diff --git a/src/Server/MCPServer.HttpHeaders.pas b/src/Server/MCPServer.HttpHeaders.pas new file mode 100644 index 0000000..ccc2921 --- /dev/null +++ b/src/Server/MCPServer.HttpHeaders.pas @@ -0,0 +1,285 @@ +unit MCPServer.HttpHeaders; + +interface + +uses + System.SysUtils; + +type + TMCPHeaderValue = record + const SENTINEL_PREFIX = '=?base64?'; + const SENTINEL_SUFFIX = '?='; + + class function IsHeaderSafe(const Value: string): Boolean; static; + class function IsSentinel(const Value: string): Boolean; static; + class function TryDecodeBase64(const Text: string; out Bytes: TBytes): Boolean; static; + class function TryDecode(const Value: string; out Decoded: string): Boolean; static; + end; + + TMCPAcceptHeader = record + class function Accepts(const AcceptHeader, MediaType: string): Boolean; static; + end; + + TMCPOriginPolicy = record + const ALLOW_ALL = '*'; + + class function IsLoopback(const Origin: string): Boolean; static; + class function IsAllowed(const Origin: string; const AllowList: TArray): Boolean; static; + class function Matches(const Origin, Pattern: string): Boolean; static; + end; + + TMCPHostPolicy = record + class function IsAllowed(const HostHeader: string; const AllowList: TArray): Boolean; static; + class function Matches(const HostHeader, Pattern: string): Boolean; static; + end; + + TMCPJsonLimits = record + class function NestingDepth(const Json: string): Integer; static; + end; + +implementation + +uses + System.NetEncoding; + +{ TMCPHeaderValue } + +class function TMCPHeaderValue.IsHeaderSafe(const Value: string): Boolean; +begin + for var C in Value do + if not ((C = #9) or ((C >= #$20) and (C <= #$7E))) then + Exit(False); + Result := True; +end; + +class function TMCPHeaderValue.IsSentinel(const Value: string): Boolean; +begin + Result := (Length(Value) >= Length(SENTINEL_PREFIX) + Length(SENTINEL_SUFFIX)) + and Value.StartsWith(SENTINEL_PREFIX, False) and Value.EndsWith(SENTINEL_SUFFIX, False); +end; + +class function TMCPHeaderValue.TryDecodeBase64(const Text: string; out Bytes: TBytes): Boolean; +begin + Bytes := nil; + if (Text = '') or (Length(Text) mod 4 <> 0) then + Exit(False); + + var Padding := 0; + for var I := 1 to Length(Text) do + begin + var C := Text[I]; + if C = '=' then + begin + Inc(Padding); + if (Padding > 2) or (I < Length(Text) - 1) then + Exit(False); + end + else if Padding > 0 then + Exit(False) + else if not (CharInSet(C, ['A'..'Z', 'a'..'z', '0'..'9', '+', '/'])) then + Exit(False); + end; + + Bytes := TNetEncoding.Base64.DecodeStringToBytes(Text); + Result := True; +end; + +class function TMCPHeaderValue.TryDecode(const Value: string; out Decoded: string): Boolean; +var + Bytes: TBytes; +begin + Decoded := ''; + if not IsHeaderSafe(Value) then + Exit(False); + + if not IsSentinel(Value) then + begin + Decoded := Value; + Exit(True); + end; + + var Payload := Value.Substring(Length(SENTINEL_PREFIX), Length(Value) - Length(SENTINEL_PREFIX) - Length(SENTINEL_SUFFIX)); + if not TryDecodeBase64(Payload, Bytes) then + Exit(False); + + Decoded := TEncoding.UTF8.GetString(Bytes); + Result := True; +end; + +{ TMCPAcceptHeader } + +class function TMCPAcceptHeader.Accepts(const AcceptHeader, MediaType: string): Boolean; +begin + for var Entry in AcceptHeader.Split([',']) do + begin + var Media := Entry; + var ParameterStart := Media.IndexOf(';'); + if ParameterStart >= 0 then + Media := Media.Substring(0, ParameterStart); + if SameText(Media.Trim, MediaType) then + Exit(True); + end; + Result := False; +end; + +{ TMCPOriginPolicy } + +function DefaultPortOf(const Scheme: string): string; +begin + if Scheme = 'https' then + Result := '443' + else if Scheme = 'http' then + Result := '80' + else + Result := ''; +end; + +procedure SplitOrigin(const Origin: string; out Scheme, Host, Port: string); +begin + Scheme := ''; + Host := ''; + Port := ''; + + var Rest := Origin.Trim; + var SchemeEnd := Rest.IndexOf('://'); + if SchemeEnd < 0 then + Exit; + Scheme := Rest.Substring(0, SchemeEnd).ToLower; + Rest := Rest.Substring(SchemeEnd + 3); + + var PortStart: Integer; + if Rest.StartsWith('[') then + begin + var BracketEnd := Rest.IndexOf(']'); + if BracketEnd < 0 then + Exit; + Host := Rest.Substring(0, BracketEnd + 1).ToLower; + PortStart := Rest.IndexOf(':', BracketEnd); + end + else + begin + PortStart := Rest.IndexOf(':'); + if PortStart >= 0 then + Host := Rest.Substring(0, PortStart).ToLower + else + Host := Rest.ToLower; + end; + + if PortStart >= 0 then + Port := Rest.Substring(PortStart + 1); +end; + +class function TMCPOriginPolicy.IsLoopback(const Origin: string): Boolean; +var + Scheme, Host, Port: string; +begin + SplitOrigin(Origin, Scheme, Host, Port); + Result := ((Scheme = 'http') or (Scheme = 'https')) + and ((Host = 'localhost') or (Host = '127.0.0.1') or (Host = '[::1]')); +end; + +class function TMCPOriginPolicy.Matches(const Origin, Pattern: string): Boolean; +var + OriginScheme, OriginHost, OriginPort: string; + PatternScheme, PatternHost, PatternPort: string; +begin + if Pattern.Trim = ALLOW_ALL then + Exit(True); + + SplitOrigin(Origin, OriginScheme, OriginHost, OriginPort); + SplitOrigin(Pattern, PatternScheme, PatternHost, PatternPort); + if (OriginScheme = '') or (PatternScheme = '') then + Exit(False); + + if (OriginPort = '') then + OriginPort := DefaultPortOf(OriginScheme); + if (PatternPort = '') then + PatternPort := DefaultPortOf(PatternScheme); + + Result := (OriginScheme = PatternScheme) and (OriginHost = PatternHost) + and ((PatternPort = '*') or (OriginPort = PatternPort)); +end; + +class function TMCPOriginPolicy.IsAllowed(const Origin: string; const AllowList: TArray): Boolean; +begin + var Value := Origin.Trim; + if Value = '' then + Exit(True); + if SameText(Value, 'null') then + Exit(False); + if IsLoopback(Value) then + Exit(True); + + for var Pattern in AllowList do + if Matches(Value, Pattern) then + Exit(True); + Result := False; +end; + +{ TMCPHostPolicy } + +class function TMCPHostPolicy.Matches(const HostHeader, Pattern: string): Boolean; +var + Scheme, HostName, HostPort, PatternName, PatternPort: string; +begin + if Pattern.Trim = TMCPOriginPolicy.ALLOW_ALL then + Exit(True); + + SplitOrigin('http://' + HostHeader.Trim, Scheme, HostName, HostPort); + SplitOrigin('http://' + Pattern.Trim, Scheme, PatternName, PatternPort); + if (HostName = '') or (PatternName = '') or (HostName <> PatternName) then + Exit(False); + Result := (PatternPort = '') or (PatternPort = '*') or (PatternPort = HostPort); +end; + +class function TMCPHostPolicy.IsAllowed(const HostHeader: string; const AllowList: TArray): Boolean; +begin + if Length(AllowList) = 0 then + Exit(True); + for var Pattern in AllowList do + begin + if Matches(HostHeader, Pattern) then + Exit(True); + end; + Result := False; +end; + +{ TMCPJsonLimits } + +class function TMCPJsonLimits.NestingDepth(const Json: string): Integer; +begin + Result := 0; + var Depth := 0; + var InString := False; + var Escaped := False; + + for var C in Json do + begin + if InString then + begin + if Escaped then + Escaped := False + else if C = '\' then + Escaped := True + else if C = '"' then + InString := False; + Continue; + end; + + case C of + '"': + InString := True; + '{', '[': + begin + Inc(Depth); + if Depth > Result then + Result := Depth; + end; + '}', ']': + if Depth > 0 then + Dec(Depth); + end; + end; +end; + +end. diff --git a/src/Server/MCPServer.HttpStream.pas b/src/Server/MCPServer.HttpStream.pas new file mode 100644 index 0000000..0712d1a --- /dev/null +++ b/src/Server/MCPServer.HttpStream.pas @@ -0,0 +1,198 @@ +unit MCPServer.HttpStream; + +interface + +uses + System.SysUtils, + System.SyncObjs, + IdContext, + IdCustomHTTPServer, + MCPServer.Types; + +type + TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequestTracker, IMCPKeepAlive) + public + const MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; + strict private + FConnection: TIdContext; + FResponseInfo: TIdHTTPResponseInfo; + FLock: TCriticalSection; + FOpened: Boolean; + FBroken: Boolean; + FRequest: IMCPRequestContext; + procedure OpenStream; + procedure WriteChunk(const Text: string); + procedure WriteEvent(const Json: string); + procedure MarkBroken(const Reason: string); + public + constructor Create(const Connection: TIdContext; const ResponseInfo: TIdHTTPResponseInfo); + destructor Destroy; override; + + procedure Send(const Json: string); + procedure KeepAlive; + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + procedure Finish(const FinalJson: string); + + class function EventText(const Json: string): string; static; + + property Opened: Boolean read FOpened; + property Broken: Boolean read FBroken; + end; + +implementation + +uses + IdGlobal, + MCPServer.Errors, + MCPServer.Logger; + +const + SSE_EVENT_PREFIX = 'event: message'#10'data: '; + SSE_EVENT_SUFFIX = #10#10; + CHUNK_TERMINATOR = '0'#13#10#13#10; + SSE_KEEP_ALIVE_COMMENT = ': keep-alive'#10#10; + CHARSET_UTF8 = 'utf-8'; + HTTP_STATUS_OK = 200; + +{ TMCPHttpResponseStream } + +constructor TMCPHttpResponseStream.Create(const Connection: TIdContext; const ResponseInfo: TIdHTTPResponseInfo); +begin + inherited Create; + FConnection := Connection; + FResponseInfo := ResponseInfo; + FLock := TCriticalSection.Create; +end; + +destructor TMCPHttpResponseStream.Destroy; +begin + FLock.Free; + inherited; +end; + +class function TMCPHttpResponseStream.EventText(const Json: string): string; +begin + Result := SSE_EVENT_PREFIX + Json + SSE_EVENT_SUFFIX; +end; + +procedure TMCPHttpResponseStream.OpenStream; +begin + FResponseInfo.ResponseNo := HTTP_STATUS_OK; + FResponseInfo.ContentType := MEDIA_TYPE_EVENT_STREAM; + FResponseInfo.CharSet := CHARSET_UTF8; + FResponseInfo.ContentLength := -1; + FResponseInfo.TransferEncoding := 'chunked'; + FResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; + FResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + FResponseInfo.WriteHeader; + FOpened := True; +end; + +procedure TMCPHttpResponseStream.WriteChunk(const Text: string); +begin + var Bytes := TEncoding.UTF8.GetBytes(Text); + var IOHandler := FConnection.Connection.IOHandler; + IOHandler.WriteLn(IntToHex(Length(Bytes), 1)); + IOHandler.Write(TIdBytes(Bytes)); + IOHandler.WriteLn; +end; + +procedure TMCPHttpResponseStream.WriteEvent(const Json: string); +begin + WriteChunk(EventText(Json)); +end; + +procedure TMCPHttpResponseStream.MarkBroken(const Reason: string); +begin + FBroken := True; + TLogger.Info(Format('HTTP response stream closed by the client: %s', [Reason])); + var Request := FRequest; + if Assigned(Request) then + Request.Cancel; +end; + +procedure TMCPHttpResponseStream.Send(const Json: string); +begin + FLock.Enter; + try + if FBroken then + Exit; + try + if not FOpened then + OpenStream; + WriteEvent(Json); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + +procedure TMCPHttpResponseStream.KeepAlive; +begin + FLock.Enter; + try + if FBroken or not FOpened then + Exit; + try + if not FConnection.Connection.Connected then + raise EMCPTransportError.Create('connection closed'); + WriteChunk(SSE_KEEP_ALIVE_COMMENT); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + +procedure TMCPHttpResponseStream.Track(const Context: IMCPRequestContext); +begin + FLock.Enter; + try + FRequest := Context; + finally + FLock.Leave; + end; +end; + +procedure TMCPHttpResponseStream.Untrack(const Context: IMCPRequestContext); +begin + FLock.Enter; + try + FRequest := nil; + finally + FLock.Leave; + end; +end; + +function TMCPHttpResponseStream.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +begin + Result := False; +end; + +procedure TMCPHttpResponseStream.Finish(const FinalJson: string); +begin + FLock.Enter; + try + if not FOpened or FBroken then + Exit; + try + if FinalJson <> '' then + WriteEvent(FinalJson); + FConnection.Connection.IOHandler.Write(CHUNK_TERMINATOR); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + +end. diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 6516352..e419405 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -2,9 +2,7 @@ interface -// TaurusTLS provides OpenSSL 3.x/4.x support with modern ECDHE cipher suites -// Install via GetIt Package Manager: Search for "TaurusTLS" or get from https://github.com/TaurusTLS-Developers/TaurusTLS -{$DEFINE USE_TAURUS_TLS} // Comment this line to use standard Indy SSL (OpenSSL 1.0.2) +{$I MCPServer.inc} uses System.SysUtils, @@ -18,6 +16,8 @@ interface IdCustomHTTPServer, IdGlobal, IdGlobalProtocols, + IdSocketHandle, + IdStack, {$IFDEF USE_TAURUS_TLS} TaurusTLS, {$ELSE} @@ -26,6 +26,8 @@ interface IdServerIOHandler, MCPServer.Types, MCPServer.Settings, + MCPServer.Authorization, + MCPServer.RequestContext, MCPServer.JsonRpcProcessor; type @@ -43,66 +45,98 @@ TMCPIdHTTPServer = class(TComponent) FPort: Word; FActive: Boolean; FSettings: TMCPSettings; - FEventIDCounter: Int64; + FAuthorizer: IMCPAuthorizer; procedure ConfigureSSL; + procedure ConfigureBindings; + procedure AddBinding(const IP: string; IPVersion: TIdIPVersion); procedure HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean); + procedure HandleParseAuthentication(Context: TIdContext; const AuthType, AuthData: string; + var VUsername, VPassword: string; var VHandled: Boolean); procedure HandleHTTPRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); - function VerifyAndSetCORSHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; - procedure HandleOptionsRequest(ResponseInfo: TIdHTTPResponseInfo); - procedure HandleGetRequest(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); - procedure HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); - procedure HandlePostRequestSSE(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); - procedure HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); - function GetNextEventID: string; - function AcceptsSSE(const AcceptHeader: string): Boolean; - function IsRequestOnlyNotificationsOrResponses(JSONRequest: TJSONValue): Boolean; + function AllowedOrigins: TArray; + function ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; + function ValidateHost(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; + procedure ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); + procedure HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo); + function IsProtectedResourceMetadataPath(const Document: string): Boolean; + function ResourceUri: string; + function ResourceMetadataUrl: string; + procedure HandleProtectedResourceMetadata(ResponseInfo: TIdHTTPResponseInfo); + function Authenticate(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + out Principal: TMCPPrincipal): Boolean; + procedure SendChallenge(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; const Challenge: TMCPAuthChallenge; + const Message: string); + procedure HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Principal: TMCPPrincipal); + function BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; + procedure EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); + procedure SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); + procedure SendJson(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; const Body: string); + procedure SendSse(ResponseInfo: TIdHTTPResponseInfo; const Body: string); + procedure SendJsonRpcError(ResponseInfo: TIdHTTPResponseInfo; Status, Code: Integer; const Message: string); + procedure SendMethodNotAllowed(ResponseInfo: TIdHTTPResponseInfo); + function HeaderPresent(RequestInfo: TIdHTTPRequestInfo; const Name: string): Boolean; + procedure CloseSubscriptions; + function HeaderValue(RequestInfo: TIdHTTPRequestInfo; const Name: string): string; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Start; procedure Stop; + function BoundAddresses: TArray; property Port: Word read FPort write FPort; property Active: Boolean read FActive; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry write FManagerRegistry; property CoreManager: IMCPCapabilityManager read FCoreManager write FCoreManager; property Settings: TMCPSettings read FSettings write FSettings; + property Authorizer: IMCPAuthorizer read FAuthorizer write FAuthorizer; end; implementation uses MCPServer.Resource.Server, - MCPServer.CoreManager, + MCPServer.Errors, + MCPServer.HttpHeaders, + MCPServer.HttpStream, MCPServer.Logger; const - KEEP_ALIVE_TIMEOUT = 300; DEFAULT_MCP_PORT = 3000; - // HTTP Status Codes - HTTP_OK = 200; - HTTP_ACCEPTED = 202; HTTP_NO_CONTENT = 204; - HTTP_NOT_FOUND = 404; - HTTP_METHOD_NOT_ALLOWED = 405; - HTTP_NOT_ACCEPTABLE = 406; + HTTP_UNAUTHORIZED = 401; HTTP_FORBIDDEN = 403; + HTTP_METHOD_NOT_ALLOWED = 405; + HTTP_PAYLOAD_TOO_LARGE = 413; - // CORS Max Age (24 hours in seconds) - CORS_MAX_AGE = 86400; - - // JSON-RPC 2.0 Error Codes - JSONRPC_PARSE_ERROR = -32700; - JSONRPC_INVALID_REQUEST = -32600; - JSONRPC_METHOD_NOT_FOUND = -32601; - JSONRPC_INVALID_PARAMS = -32602; - JSONRPC_INTERNAL_ERROR = -32603; + SUBSCRIPTION_CLOSE_GRACE_MS = 1000; + SUBSCRIPTION_CLOSE_POLL_MS = 10; - // SSE Message Format - SSE_EVENT_PREFIX = 'event: '; - SSE_DATA_PREFIX = 'data: '; - SSE_ID_PREFIX = 'id: '; - SSE_MESSAGE_TERMINATOR = #10#10; + CORS_MAX_AGE = 86400; + CORS_ALLOW_METHODS = 'POST, OPTIONS'; + CORS_ALLOW_HEADERS = 'Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID'; + CORS_EXPOSE_HEADERS = 'Mcp-Session-Id, WWW-Authenticate'; + ALLOW_HEADER = 'POST, OPTIONS'; + + HEADER_ORIGIN = 'Origin'; + HEADER_AUTHORIZATION = 'Authorization'; + HEADER_WWW_AUTHENTICATE = 'WWW-Authenticate'; + BEARER_PREFIX = 'Bearer '; + METADATA_CACHE_CONTROL = 'max-age=3600'; + HEADER_ACCEPT = 'Accept'; + HEADER_SESSION_ID = 'Mcp-Session-Id'; + HEADER_PROTOCOL_VERSION = 'MCP-Protocol-Version'; + HEADER_METHOD = 'Mcp-Method'; + HEADER_NAME = 'Mcp-Name'; + + MEDIA_TYPE_JSON = 'application/json'; + MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; + + LOOPBACK_IPV4 = '127.0.0.1'; + LOOPBACK_IPV6 = '::1'; + ANY_IPV4 = '0.0.0.0'; + ANY_IPV6 = '::'; { TMCPIdHTTPServer } @@ -111,7 +145,6 @@ constructor TMCPIdHTTPServer.Create(Owner: TComponent); inherited Create(Owner); FPort := DEFAULT_MCP_PORT; FActive := False; - FEventIDCounter := 0; FJsonRpcProcessor := nil; FHTTPServer := TIdHTTPServer.Create(Self); @@ -119,6 +152,7 @@ constructor TMCPIdHTTPServer.Create(Owner: TComponent); FHTTPServer.OnCommandGet := HandleHTTPRequest; FHTTPServer.OnCommandOther := HandleHTTPRequest; FHTTPServer.OnQuerySSLPort := HandleQuerySSLPort; + FHTTPServer.OnParseAuthentication := HandleParseAuthentication; FSSLHandler := nil; end; @@ -141,265 +175,152 @@ procedure TMCPIdHTTPServer.Start; if not Assigned(FManagerRegistry) then raise Exception.Create('Manager registry not assigned'); - FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry); + FJsonRpcProcessor.Free; + FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry, FSettings); if Assigned(FSettings) then begin FPort := Word(FSettings.Port); + FHTTPServer.MaxConnections := FSettings.MaxConnections; - // Configure SSL if enabled if FSettings.SSLEnabled then ConfigureSSL; end; + if Assigned(FAuthorizer) and (not Assigned(FSettings) or (Length(FSettings.AuthorizationServerList) = 0)) then + TLogger.Warning('An authorizer is configured without [Auth] AuthorizationServers: clients cannot discover an authorization server, only pre-shared tokens work'); + FHTTPServer.DefaultPort := FPort; + ConfigureBindings; FHTTPServer.Active := True; FActive := True; - TLogger.Info('MCP Server started on ' + FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort)); -end; + if (FPort = 0) and (FHTTPServer.Bindings.Count > 0) then + FPort := FHTTPServer.Bindings[0].Port; -procedure TMCPIdHTTPServer.Stop; -begin - if not FActive then - Exit; - - FHTTPServer.Active := False; - FActive := False; - TLogger.Info('MCP Server stopped'); + TLogger.Info('MCP Server listening on ' + string.Join(', ', BoundAddresses)); end; -procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; - RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +procedure TMCPIdHTTPServer.CloseSubscriptions; var - RequestPath: string; + Hub: IMCPSubscriptionHub; begin - TServerStatusResource.ConnectionOpened; - try - TServerStatusResource.IncrementRequestCount; - - if not VerifyAndSetCORSHeaders(RequestInfo, ResponseInfo) then - Exit; // CORS blocked the request - - RequestPath := RequestInfo.Document; + if not Assigned(FManagerRegistry) + or not Supports(FManagerRegistry.GetManagerForMethod(MCP_METHOD_SUBSCRIPTIONS_LISTEN), IMCPSubscriptionHub, Hub) then + Exit; - // Only handle requests to the configured MCP endpoint - if (RequestPath <> FSettings.Endpoint) then - begin - ResponseInfo.ResponseNo := HTTP_NOT_FOUND; - ResponseInfo.ResponseText := 'Not Found'; - Exit; - end; - - if RequestInfo.Command = 'OPTIONS' then - HandleOptionsRequest(ResponseInfo) - else if RequestInfo.CommandType = hcGET then - HandleGetRequest(RequestInfo, ResponseInfo) - else if RequestInfo.CommandType = hcPOST then - HandlePostRequest(RequestInfo, ResponseInfo) - else - begin - ResponseInfo.ResponseNo := HTTP_METHOD_NOT_ALLOWED; - ResponseInfo.ResponseText := 'Method Not Allowed'; - end; - finally - TServerStatusResource.ConnectionClosed; - end; + var Deadline := TThread.GetTickCount64 + SUBSCRIPTION_CLOSE_GRACE_MS; + repeat + Hub.CloseAll('server stopping'); + if Hub.ActiveCount = 0 then + Break; + Sleep(SUBSCRIPTION_CLOSE_POLL_MS); + until TThread.GetTickCount64 >= Deadline; end; -function TMCPIdHTTPServer.VerifyAndSetCORSHeaders(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo): Boolean; -var - AllowedOrigin: string; - CurrentOrigin: string; - Found: Boolean; - Origin: string; - OriginsList: TStringList; +procedure TMCPIdHTTPServer.Stop; begin - Result := True; - - if not Assigned(FSettings) or not FSettings.CorsEnabled then + if not FActive then Exit; - Origin := RequestInfo.RawHeaders.Values['Origin']; - AllowedOrigin := '*'; + CloseSubscriptions; + FHTTPServer.Active := False; + FActive := False; + TLogger.Info('MCP Server stopped'); +end; - if (FSettings.CorsAllowedOrigins <> '*') and (Origin <> '') then +function TMCPIdHTTPServer.BoundAddresses: TArray; +begin + Result := nil; + for var I := 0 to FHTTPServer.Bindings.Count - 1 do begin - OriginsList := TStringList.Create; - try - OriginsList.CommaText := FSettings.CorsAllowedOrigins; - Found := False; - - for CurrentOrigin in OriginsList do - begin - if SameText(Trim(CurrentOrigin), Origin) then - begin - AllowedOrigin := Origin; - Found := True; - Break; - end; - end; - - if not Found then - begin - Result := False; - ResponseInfo.ResponseNo := HTTP_FORBIDDEN; - ResponseInfo.ResponseText := 'Forbidden - Origin not allowed'; - TLogger.Info('CORS blocked origin: ' + Origin); - Exit; - end; - finally - OriginsList.Free; - end; + var Binding := FHTTPServer.Bindings[I]; + if Binding.IPVersion = Id_IPv6 then + Result := Result + [Format('[%s]:%d', [Binding.IP, Binding.Port])] + else + Result := Result + [Format('%s:%d', [Binding.IP, Binding.Port])]; end; - - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := AllowedOrigin; - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Methods'] := 'POST, GET, OPTIONS'; - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Headers'] := - 'Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id'; - ResponseInfo.CustomHeaders.Values['Access-Control-Expose-Headers'] := 'Mcp-Session-Id'; - ResponseInfo.CustomHeaders.Values['Access-Control-Max-Age'] := CORS_MAX_AGE.ToString; end; -procedure TMCPIdHTTPServer.HandleOptionsRequest(ResponseInfo: TIdHTTPResponseInfo); +procedure TMCPIdHTTPServer.AddBinding(const IP: string; IPVersion: TIdIPVersion); begin - ResponseInfo.ResponseNo := HTTP_OK; - ResponseInfo.ResponseText := 'OK'; + var Binding := FHTTPServer.Bindings.Add; + Binding.IP := IP; + Binding.Port := FPort; + Binding.IPVersion := IPVersion; end; -procedure TMCPIdHTTPServer.HandleGetRequest(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); -var - AcceptHeader: string; - SessionID: string; +procedure TMCPIdHTTPServer.ConfigureBindings; begin - AcceptHeader := RequestInfo.RawHeaders.Values['Accept']; + FHTTPServer.Bindings.Clear; - if AcceptsSSE(AcceptHeader) then - begin - TLogger.Debug('Received GET request - opening SSE stream for server-initiated messages'); - - ResponseInfo.ContentType := 'text/event-stream'; - ResponseInfo.CharSet := 'utf-8'; - ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; - - SessionID := RequestInfo.RawHeaders.Values['Mcp-Session-Id']; - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; - - ResponseInfo.ResponseNo := HTTP_OK; - ResponseInfo.ContentText := ''; // Empty SSE stream, close immediately - - // Note: GET endpoint for SSE streams is optional per MCP spec 2025-03-26 - // Server MAY keep connection open to send server-initiated notifications/requests - // Current implementation: basic support, closes stream immediately (no persistent connection) - TLogger.Debug('SSE stream opened (no server-initiated messages to send)'); - end - else + var Address := ''; + var Host := 'localhost'; + if Assigned(FSettings) then begin - TLogger.Info('Received GET request - returning endpoint info'); - - ResponseInfo.ContentType := 'application/json'; - ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - - ResponseInfo.ContentText := '{"url": "' + FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort) + - FSettings.Endpoint + '", "transport": "' + FSettings.Protocol + '"}'; - - ResponseInfo.ResponseNo := HTTP_OK; + Address := FSettings.BindAddress.Trim; + Host := FSettings.Host.Trim; end; -end; -procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); -var - AcceptHeader: string; - JSONRequest: TJSONValue; - RequestBody: string; - SessionID: string; -begin - RequestBody := ''; - if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > 0) then + if Address <> '' then begin - RequestInfo.PostStream.Position := 0; - RequestBody := ReadStringFromStream(RequestInfo.PostStream, -1, IndyTextEncoding_UTF8); - end; - - TLogger.Info('Request: ' + RequestBody); - - SessionID := RequestInfo.RawHeaders.Values['Mcp-Session-Id']; - if SessionID <> '' then - TLogger.Info('Session ID from header: ' + SessionID); - - AcceptHeader := RequestInfo.RawHeaders.Values['Accept']; - - JSONRequest := nil; - try - JSONRequest := TJSONObject.ParseJSONValue(RequestBody); - - if Assigned(JSONRequest) and IsRequestOnlyNotificationsOrResponses(JSONRequest) then - begin - TLogger.Info('Request contains only notifications/responses, returning 202 Accepted'); - ResponseInfo.ResponseNo := HTTP_ACCEPTED; - - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; - - Exit; - end; - - if AcceptsSSE(AcceptHeader) then - HandlePostRequestSSE(RequestInfo, ResponseInfo, RequestBody, SessionID) + if (Address = ANY_IPV4) or (Address = ANY_IPV6) then + TLogger.Warning('BindAddress ' + Address + ': the server is reachable from every network interface'); + if Address.Contains(':') then + AddBinding(Address, Id_IPv6) else - HandlePostRequestJSON(RequestInfo, ResponseInfo, RequestBody, SessionID); + AddBinding(Address, Id_IPv4); + Exit; + end; - finally - JSONRequest.Free; + if SameText(Host, 'localhost') or (Host = LOOPBACK_IPV4) or (Host = LOOPBACK_IPV6) then + begin + AddBinding(LOOPBACK_IPV4, Id_IPv4); + if GStack.SupportsIPv6 then + AddBinding(LOOPBACK_IPV6, Id_IPv6); + end + else + begin + TLogger.Info('Host ' + Host + ' is not loopback; listening on every network interface (set BindAddress to narrow this)'); + AddBinding(ANY_IPV4, Id_IPv4); + if GStack.SupportsIPv6 then + AddBinding(ANY_IPV6, Id_IPv6); end; end; procedure TMCPIdHTTPServer.ConfigureSSL; begin - // Check if certificate files exist if not TFile.Exists(FSettings.SSLCertFile) then begin TLogger.Error('SSL Certificate file not found: ' + FSettings.SSLCertFile); raise Exception.Create('SSL Certificate file not found: ' + FSettings.SSLCertFile); end; - + if not TFile.Exists(FSettings.SSLKeyFile) then begin TLogger.Error('SSL Key file not found: ' + FSettings.SSLKeyFile); raise Exception.Create('SSL Key file not found: ' + FSettings.SSLKeyFile); end; - - // Create and configure SSL handler + {$IFDEF USE_TAURUS_TLS} - // TaurusTLS with OpenSSL 3.x/4.x support FSSLHandler := TTaurusTLSServerIOHandler.Create(Self); FSSLHandler.DefaultCert.PublicKey := FSettings.SSLCertFile; FSSLHandler.DefaultCert.PrivateKey := FSettings.SSLKeyFile; {$ELSE} - // Standard Indy SSL with OpenSSL 1.0.2 FSSLHandler := TIdServerIOHandlerSSLOpenSSL.Create(Self); FSSLHandler.SSLOptions.CertFile := FSettings.SSLCertFile; FSSLHandler.SSLOptions.KeyFile := FSettings.SSLKeyFile; - + if (FSettings.SSLRootCertFile <> '') and TFile.Exists(FSettings.SSLRootCertFile) then FSSLHandler.SSLOptions.RootCertFile := FSettings.SSLRootCertFile; - - // Configure SSL options + FSSLHandler.SSLOptions.Method := sslvTLSv1_2; - FSSLHandler.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2]; + FSSLHandler.SSLOptions.SSLVersions := [sslvTLSv1_2]; FSSLHandler.SSLOptions.Mode := sslmServer; {$ENDIF} - - // Assign handler to HTTP server + FHTTPServer.IOHandler := FSSLHandler; - + TLogger.Info('SSL configured successfully'); TLogger.Info('Certificate: ' + FSettings.SSLCertFile); TLogger.Info('Private Key: ' + FSettings.SSLKeyFile); @@ -407,152 +328,406 @@ procedure TMCPIdHTTPServer.ConfigureSSL; TLogger.Info('Root Certificate: ' + FSettings.SSLRootCertFile); end; +procedure TMCPIdHTTPServer.HandleParseAuthentication(Context: TIdContext; const AuthType, AuthData: string; + var VUsername, VPassword: string; var VHandled: Boolean); +begin + VUsername := ''; + VPassword := ''; + VHandled := True; +end; + procedure TMCPIdHTTPServer.HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean); begin - // Enable SSL for our configured port when SSL is enabled - VUseSSL := FSettings.SSLEnabled and (APort = FPort); + VUseSSL := Assigned(FSettings) and FSettings.SSLEnabled and (APort = FPort); end; -function TMCPIdHTTPServer.GetNextEventID: string; +function TMCPIdHTTPServer.HeaderPresent(RequestInfo: TIdHTTPRequestInfo; const Name: string): Boolean; begin - Inc(FEventIDCounter); - Result := IntToStr(FEventIDCounter); + Result := RequestInfo.RawHeaders.IndexOfName(Name) >= 0; end; -function TMCPIdHTTPServer.AcceptsSSE(const AcceptHeader: string): Boolean; +function TMCPIdHTTPServer.HeaderValue(RequestInfo: TIdHTTPRequestInfo; const Name: string): string; begin - Result := Pos('text/event-stream', AcceptHeader) > 0; + Result := Trim(RequestInfo.RawHeaders.Values[Name]); end; -function TMCPIdHTTPServer.IsRequestOnlyNotificationsOrResponses(JSONRequest: TJSONValue): Boolean; -var - Arr: TJSONArray; - ErrorValue: TJSONValue; - I: Integer; - IdValue: TJSONValue; - MethodValue: TJSONValue; - Obj: TJSONObject; - ResultValue: TJSONValue; -begin - if JSONRequest is TJSONObject then - begin - Obj := JSONRequest as TJSONObject; - MethodValue := Obj.GetValue('method'); - IdValue := Obj.GetValue('id'); - ResultValue := Obj.GetValue('result'); - ErrorValue := Obj.GetValue('error'); +procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; + RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + TServerStatusResource.ConnectionOpened; + try + TServerStatusResource.IncrementRequestCount; - if Assigned(MethodValue) and not Assigned(IdValue) then - Exit(True); + if not ValidateHost(RequestInfo, ResponseInfo) or not ValidateOrigin(RequestInfo, ResponseInfo) then + Exit; - if Assigned(ResultValue) or Assigned(ErrorValue) then - Exit(True); + ApplyCorsHeaders(RequestInfo, ResponseInfo); - Result := False; - end - else if JSONRequest is TJSONArray then - begin - Arr := JSONRequest as TJSONArray; - Result := True; - for I := 0 to Arr.Count - 1 do + var Endpoint := '/mcp'; + var EndpointInfoPath := ''; + if Assigned(FSettings) then begin - if not IsRequestOnlyNotificationsOrResponses(Arr.Items[I]) then - begin - Result := False; - Break; - end; + Endpoint := FSettings.Endpoint; + EndpointInfoPath := FSettings.EndpointInfoPath; end; - end - else - Result := False; + + if (EndpointInfoPath <> '') and (RequestInfo.Document = EndpointInfoPath) and (RequestInfo.CommandType = hcGET) then + begin + HandleEndpointInfo(ResponseInfo); + Exit; + end; + + if Assigned(FAuthorizer) and (RequestInfo.CommandType = hcGET) + and IsProtectedResourceMetadataPath(RequestInfo.Document) then + begin + HandleProtectedResourceMetadata(ResponseInfo); + Exit; + end; + + if RequestInfo.Document <> Endpoint then + begin + SendEmpty(ResponseInfo, HTTP_STATUS_NOT_FOUND); + Exit; + end; + + if RequestInfo.Command = 'OPTIONS' then + begin + SendEmpty(ResponseInfo, HTTP_NO_CONTENT); + Exit; + end; + + var Principal := TMCPPrincipal.None; + if Assigned(FAuthorizer) and not Authenticate(RequestInfo, ResponseInfo, Principal) then + Exit; + + if RequestInfo.CommandType = hcPOST then + HandlePostRequest(Context, RequestInfo, ResponseInfo, Principal) + else + SendMethodNotAllowed(ResponseInfo); + finally + TServerStatusResource.ConnectionClosed; + end; end; -procedure TMCPIdHTTPServer.HandlePostRequestSSE(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); -var - EventID: string; - JSONResponse: string; - SSEMessage: string; +function TMCPIdHTTPServer.AllowedOrigins: TArray; begin - TLogger.Info('Handling POST request with SSE stream'); + Result := nil; + if not Assigned(FSettings) then + Exit; - ResponseInfo.ContentType := 'text/event-stream'; - ResponseInfo.CharSet := 'utf-8'; - ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + var List := FSettings.AllowedOrigins; + if List.Trim = '' then + Exit; - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; + for var Entry in List.Split([',']) do + if Entry.Trim <> '' then + Result := Result + [Entry.Trim]; +end; - JSONResponse := FJsonRpcProcessor.ProcessRequest(RequestBody, SessionID); +function TMCPIdHTTPServer.ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; +begin + if not HeaderPresent(RequestInfo, HEADER_ORIGIN) then + Exit(True); - if JSONResponse <> '' then - begin - EventID := GetNextEventID; - SSEMessage := ''; + var Origin := HeaderValue(RequestInfo, HEADER_ORIGIN); + ResponseInfo.CustomHeaders.Values['Vary'] := HEADER_ORIGIN; - if EventID <> '' then - SSEMessage := SSEMessage + SSE_ID_PREFIX + EventID + #10; + if TMCPOriginPolicy.IsAllowed(Origin, AllowedOrigins) then + Exit(True); - SSEMessage := SSEMessage + SSE_EVENT_PREFIX + 'message' + #10; - SSEMessage := SSEMessage + SSE_DATA_PREFIX + JSONResponse + SSE_MESSAGE_TERMINATOR; + TLogger.Warning('Origin not allowed: ' + Origin); + SendJsonRpcError(ResponseInfo, HTTP_FORBIDDEN, JSONRPC_INVALID_REQUEST, 'Origin not allowed'); + Result := False; +end; - ResponseInfo.ContentText := SSEMessage; - TLogger.Info('SSE response prepared with event ID: ' + EventID); - end +function TMCPIdHTTPServer.ValidateHost(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; +begin + if not Assigned(FSettings) or TMCPHostPolicy.IsAllowed(RequestInfo.Host, FSettings.AllowedHostList) then + Exit(True); + + TLogger.Warning('Host not allowed: ' + RequestInfo.Host); + SendJsonRpcError(ResponseInfo, HTTP_FORBIDDEN, JSONRPC_INVALID_REQUEST, 'Host not allowed'); + Result := False; +end; + +procedure TMCPIdHTTPServer.ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + if not Assigned(FSettings) or not FSettings.CorsEnabled then + Exit; + + var Origin := HeaderValue(RequestInfo, HEADER_ORIGIN); + var AllowAll := False; + for var Entry in AllowedOrigins do + if Entry = TMCPOriginPolicy.ALLOW_ALL then + AllowAll := True; + + if (Origin = '') or AllowAll then + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := TMCPOriginPolicy.ALLOW_ALL else + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := Origin; + + var AllowHeaders := CORS_ALLOW_HEADERS; + for var Requested in HeaderValue(RequestInfo, 'Access-Control-Request-Headers').Split([',']) do begin - ResponseInfo.ContentText := ''; + var Name := Requested.Trim; + if (Name <> '') and (Pos(LowerCase(Name), LowerCase(AllowHeaders)) = 0) then + AllowHeaders := AllowHeaders + ', ' + Name; end; - ResponseInfo.ResponseNo := HTTP_OK; + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Methods'] := CORS_ALLOW_METHODS; + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Headers'] := AllowHeaders; + ResponseInfo.CustomHeaders.Values['Access-Control-Expose-Headers'] := CORS_EXPOSE_HEADERS; + ResponseInfo.CustomHeaders.Values['Access-Control-Max-Age'] := CORS_MAX_AGE.ToString; +end; + +procedure TMCPIdHTTPServer.HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo); +begin + var Info := TJSONObject.Create; + try + Info.AddPair('url', FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort) + FSettings.Endpoint); + Info.AddPair('transport', 'streamable-http'); + var Versions := TJSONArray.Create; + Info.AddPair('protocolVersions', Versions); + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Versions.Add(Version); + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Versions.Add(Version); + SendJson(ResponseInfo, HTTP_STATUS_OK, Info.ToJSON); + finally + Info.Free; + end; end; -procedure TMCPIdHTTPServer.HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); +function TMCPIdHTTPServer.IsProtectedResourceMetadataPath(const Document: string): Boolean; +begin + var Endpoint := '/mcp'; + if Assigned(FSettings) then + Endpoint := FSettings.Endpoint; + Result := (Document = TMCPProtectedResourceMetadata.WELL_KNOWN_PATH) + or (Document = TMCPProtectedResourceMetadata.WELL_KNOWN_PATH + Endpoint); +end; + +function TMCPIdHTTPServer.ResourceUri: string; +begin + Result := ''; + if Assigned(FSettings) then + Result := FSettings.ResourceUri.Trim; + if Result <> '' then + Exit; + + Result := Format('%s://%s:%d%s', [FSettings.Protocol.ToLower, FSettings.Host.ToLower, FPort, FSettings.Endpoint]); +end; + +function TMCPIdHTTPServer.ResourceMetadataUrl: string; +begin + Result := ''; + if not Assigned(FSettings) or (Length(FSettings.AuthorizationServerList) = 0) then + Exit; + Result := Format('%s://%s:%d%s%s', [FSettings.Protocol.ToLower, FSettings.Host.ToLower, FPort, + TMCPProtectedResourceMetadata.WELL_KNOWN_PATH, FSettings.Endpoint]); +end; + +procedure TMCPIdHTTPServer.HandleProtectedResourceMetadata(ResponseInfo: TIdHTTPResponseInfo); +begin + var Metadata := TMCPProtectedResourceMetadata.Build(ResourceUri, FSettings.ServerName, + FSettings.AuthorizationServerList, FSettings.ScopesSupportedList); + try + ResponseInfo.CustomHeaders.Values['Cache-Control'] := METADATA_CACHE_CONTROL; + SendJson(ResponseInfo, HTTP_STATUS_OK, Metadata.ToJSON); + finally + Metadata.Free; + end; +end; + +procedure TMCPIdHTTPServer.SendChallenge(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; + const Challenge: TMCPAuthChallenge; const Message: string); +begin + ResponseInfo.CustomHeaders.Values[HEADER_WWW_AUTHENTICATE] := TMCPBearerChallenge.Build(ResourceMetadataUrl, Challenge); + SendJsonRpcError(ResponseInfo, Status, JSONRPC_INVALID_REQUEST, Message); +end; + +function TMCPIdHTTPServer.Authenticate(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + out Principal: TMCPPrincipal): Boolean; var - ResponseBody: string; - ResponseJSON: TJSONObject; - ResultObj: TJSONObject; - SessionValue: TJSONValue; + Challenge: TMCPAuthChallenge; begin - TLogger.Info('Handling POST request with JSON response'); + Principal := TMCPPrincipal.None; + Result := False; - ResponseBody := FJsonRpcProcessor.ProcessRequest(RequestBody, SessionID); + var Header := HeaderValue(RequestInfo, HEADER_AUTHORIZATION); + if Header = '' then + begin + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, TMCPAuthChallenge.None, 'Authorization required'); + Exit; + end; + if not Header.StartsWith(BEARER_PREFIX, True) or (Header.Length <= BEARER_PREFIX.Length) then + begin + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, + TMCPAuthChallenge.InvalidRequest('Only the Bearer scheme is supported'), 'Malformed Authorization header'); + Exit; + end; - if ResponseBody = '' then + var Token := Header.Substring(BEARER_PREFIX.Length).Trim; + case FAuthorizer.Authorize(Token, RequestInfo.Command, RequestInfo.Document, Principal, Challenge) of + TMCPAuthDecision.Allow: + Result := True; + TMCPAuthDecision.Unauthorized: + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Challenge, 'Unauthorized'); + TMCPAuthDecision.Forbidden: + SendChallenge(ResponseInfo, HTTP_FORBIDDEN, Challenge, 'Forbidden'); + TMCPAuthDecision.BadRequest: + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, Challenge, 'Malformed authorization request'); + else + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Challenge, 'Unauthorized'); + end; +end; + +function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; +begin + Result := TMCPTransportHints.ForHttp( + HeaderPresent(RequestInfo, HEADER_PROTOCOL_VERSION), HeaderValue(RequestInfo, HEADER_PROTOCOL_VERSION)); + Result.HasMethodHeader := HeaderPresent(RequestInfo, HEADER_METHOD); + Result.MethodHeader := HeaderValue(RequestInfo, HEADER_METHOD); + Result.HasNameHeader := HeaderPresent(RequestInfo, HEADER_NAME); + Result.NameHeader := HeaderValue(RequestInfo, HEADER_NAME); + Result.RemoteAddress := RequestInfo.RemoteIP; +end; + +procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + var SessionId := HeaderValue(RequestInfo, HEADER_SESSION_ID); + if (SessionId <> '') and TMCPHeaderValue.IsHeaderSafe(SessionId) and not SessionId.Contains(' ') then + ResponseInfo.CustomHeaders.Values[HEADER_SESSION_ID] := SessionId; +end; + +procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; + ResponseInfo: TIdHTTPResponseInfo; const Principal: TMCPPrincipal); +begin + var MaxBodyBytes: Integer := TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES; + var MaxDepth: Integer := TMCPSettings.DEFAULT_MAX_JSON_DEPTH; + if Assigned(FSettings) then + begin + MaxBodyBytes := FSettings.MaxRequestBodyBytes; + MaxDepth := FSettings.MaxJsonDepth; + end; + + if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > MaxBodyBytes) then begin - ResponseInfo.ResponseNo := HTTP_NO_CONTENT; + SendJsonRpcError(ResponseInfo, HTTP_PAYLOAD_TOO_LARGE, JSONRPC_INVALID_REQUEST, + Format('Request body exceeds %d bytes', [MaxBodyBytes])); Exit; end; - ResponseInfo.ContentType := 'application/json'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; + var RequestBody := ''; + if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > 0) then + begin + RequestInfo.PostStream.Position := 0; + RequestBody := ReadStringFromStream(RequestInfo.PostStream, -1, IndyTextEncoding_UTF8); + end; + + TLogger.Debug('Request: ' + TLogger.RedactJson(RequestBody)); - if (SessionID = '') and (Pos('"sessionId"', ResponseBody) > 0) then + if TMCPJsonLimits.NestingDepth(RequestBody) > MaxDepth then begin - ResponseJSON := TJSONObject.ParseJSONValue(ResponseBody) as TJSONObject; - try - ResultObj := ResponseJSON.GetValue('result') as TJSONObject; - if Assigned(ResultObj) then - begin - SessionValue := ResultObj.GetValue('sessionId'); - if Assigned(SessionValue) then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionValue.Value; - end; - finally - ResponseJSON.Free; - end; - end - else if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; + SendJsonRpcError(ResponseInfo, HTTP_STATUS_BAD_REQUEST, JSONRPC_PARSE_ERROR, + Format('JSON nesting exceeds %d levels', [MaxDepth])); + Exit; + end; + + var AcceptsEventStream := TMCPAcceptHeader.Accepts(HeaderValue(RequestInfo, HEADER_ACCEPT), MEDIA_TYPE_EVENT_STREAM); + var Hints := BuildTransportHints(RequestInfo); + Hints.Principal := Principal.Subject; + Hints.Scopes := Principal.Scopes; + var Stream: TMCPHttpResponseStream := nil; + var StreamRef: IMCPMessageSink := nil; + if AcceptsEventStream then + begin + Stream := TMCPHttpResponseStream.Create(Context, ResponseInfo); + StreamRef := Stream; + Hints.Sink := Stream; + Hints.Tracker := Stream; + end; + + var Outcome: TMCPProcessResult; + var Message := TJSONObject.ParseJSONValue(RequestBody); + try + Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, Hints); + finally + Message.Free; + end; + + if Assigned(Stream) and Stream.Opened then + begin + TLogger.Debug('Response (streamed): ' + TLogger.RedactJson(Outcome.Body)); + Stream.Finish(Outcome.Body); + Exit; + end; + + if Outcome.Era = TMCPProtocolEra.Legacy then + EchoLegacySessionId(RequestInfo, ResponseInfo); + if Outcome.RequiredScope <> '' then + ResponseInfo.CustomHeaders.Values[HEADER_WWW_AUTHENTICATE] := + TMCPBearerChallenge.Build(ResourceMetadataUrl, TMCPAuthChallenge.InsufficientScope(Outcome.RequiredScope)); + + if Outcome.Body = '' then + begin + SendEmpty(ResponseInfo, Outcome.HttpStatus); + Exit; + end; + + TLogger.Debug('Response: ' + TLogger.RedactJson(Outcome.Body)); - ResponseInfo.ContentStream := TStringStream.Create(ResponseBody, TEncoding.UTF8); + if (Outcome.HttpStatus = HTTP_STATUS_OK) and AcceptsEventStream then + SendSse(ResponseInfo, Outcome.Body) + else + SendJson(ResponseInfo, Outcome.HttpStatus, Outcome.Body); +end; + +procedure TMCPIdHTTPServer.SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); +begin + ResponseInfo.ResponseNo := Status; + ResponseInfo.ContentStream := TMemoryStream.Create; ResponseInfo.FreeContentStream := True; - ResponseInfo.ResponseNo := HTTP_OK; +end; - TLogger.Info('Response: ' + ResponseBody); +procedure TMCPIdHTTPServer.SendJson(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; const Body: string); +begin + ResponseInfo.ResponseNo := Status; + ResponseInfo.ContentType := MEDIA_TYPE_JSON; + ResponseInfo.ContentStream := TStringStream.Create(Body, TEncoding.UTF8); + ResponseInfo.FreeContentStream := True; +end; + +procedure TMCPIdHTTPServer.SendSse(ResponseInfo: TIdHTTPResponseInfo; const Body: string); +begin + ResponseInfo.ResponseNo := HTTP_STATUS_OK; + ResponseInfo.ContentType := MEDIA_TYPE_EVENT_STREAM; + ResponseInfo.CharSet := 'utf-8'; + ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; + ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + ResponseInfo.ContentStream := TStringStream.Create(TMCPHttpResponseStream.EventText(Body), TEncoding.UTF8); + ResponseInfo.FreeContentStream := True; +end; + +procedure TMCPIdHTTPServer.SendJsonRpcError(ResponseInfo: TIdHTTPResponseInfo; Status, Code: Integer; const Message: string); +begin + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', '2.0'); + var Error := TJSONObject.Create; + Response.AddPair('error', Error); + Error.AddPair('code', TJSONNumber.Create(Code)); + Error.AddPair('message', Message); + SendJson(ResponseInfo, Status, Response.ToJSON); + finally + Response.Free; + end; +end; + +procedure TMCPIdHTTPServer.SendMethodNotAllowed(ResponseInfo: TIdHTTPResponseInfo); +begin + ResponseInfo.CustomHeaders.Values['Allow'] := ALLOW_HEADER; + SendEmpty(ResponseInfo, HTTP_METHOD_NOT_ALLOWED); end; -end. \ No newline at end of file +end. diff --git a/src/Server/MCPServer.StdioChannel.pas b/src/Server/MCPServer.StdioChannel.pas new file mode 100644 index 0000000..ecd496e --- /dev/null +++ b/src/Server/MCPServer.StdioChannel.pas @@ -0,0 +1,223 @@ +unit MCPServer.StdioChannel; + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + MCPServer.Types; + +type + TMCPLineStatus = ( + Ok, + TooLong, + InvalidUtf8 + ); + + TMCPLineReader = class + strict private + const READ_CHUNK_BYTES = 64 * 1024; + strict private + FStream: TStream; + FMaxLineBytes: Integer; + FPending: TBytes; + FPendingLength: Integer; + FAtStart: Boolean; + FEndOfStream: Boolean; + function Fill: Boolean; + function DecodeLine(Start, Count: Integer; out Line: string): TMCPLineStatus; + public + constructor Create(Stream: TStream; MaxLineBytes: Integer); + function ReadLine(out Line: string; out Status: TMCPLineStatus): Boolean; + end; + + TMCPLineWriter = class(TInterfacedObject, IMCPMessageSink) + strict private + FStream: TStream; + FLock: TCriticalSection; + public + constructor Create(Stream: TStream); + destructor Destroy; override; + procedure Send(const Json: string); + end; + +function StandardInputStream: TStream; +function StandardOutputStream: TStream; + +implementation + +uses +{$IFDEF MSWINDOWS} + Winapi.Windows, +{$ENDIF} +{$IFDEF POSIX} + Posix.Unistd, +{$ENDIF} + System.Math; + +function StandardInputStream: TStream; +begin +{$IFDEF MSWINDOWS} + Result := THandleStream.Create(GetStdHandle(STD_INPUT_HANDLE)); +{$ELSE} + Result := THandleStream.Create(STDIN_FILENO); +{$ENDIF} +end; + +function StandardOutputStream: TStream; +begin +{$IFDEF MSWINDOWS} + Result := THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE)); +{$ELSE} + Result := THandleStream.Create(STDOUT_FILENO); +{$ENDIF} +end; + +{ TMCPLineReader } + +constructor TMCPLineReader.Create(Stream: TStream; MaxLineBytes: Integer); +begin + inherited Create; + FStream := Stream; + FMaxLineBytes := MaxLineBytes; + FAtStart := True; + SetLength(FPending, READ_CHUNK_BYTES); +end; + +function TMCPLineReader.Fill: Boolean; +begin + if Length(FPending) - FPendingLength < READ_CHUNK_BYTES then + SetLength(FPending, Length(FPending) + READ_CHUNK_BYTES); + + var BytesRead := FStream.Read(FPending[FPendingLength], READ_CHUNK_BYTES); + if BytesRead <= 0 then + begin + FEndOfStream := True; + Exit(False); + end; + + if FAtStart then + begin + FAtStart := False; + if (BytesRead >= 3) and (FPending[0] = $EF) and (FPending[1] = $BB) and (FPending[2] = $BF) then + begin + Move(FPending[3], FPending[0], BytesRead - 3); + Dec(BytesRead, 3); + end; + end; + + Inc(FPendingLength, BytesRead); + Result := True; +end; + +function TMCPLineReader.DecodeLine(Start, Count: Integer; out Line: string): TMCPLineStatus; +begin + if (Count > 0) and (FPending[Start + Count - 1] = 13) then + Dec(Count); + + if Count > FMaxLineBytes then + begin + Line := ''; + Exit(TMCPLineStatus.TooLong); + end; + + try + Line := TEncoding.UTF8.GetString(FPending, Start, Count); + except + Line := ''; + Exit(TMCPLineStatus.InvalidUtf8); + end; + if (Line = '') and (Count > 0) then + Exit(TMCPLineStatus.InvalidUtf8); + Result := TMCPLineStatus.Ok; +end; + +function TMCPLineReader.ReadLine(out Line: string; out Status: TMCPLineStatus): Boolean; +begin + Line := ''; + Status := TMCPLineStatus.Ok; + var ScanFrom := 0; + + while True do + begin + for var I := ScanFrom to FPendingLength - 1 do + if FPending[I] = 10 then + begin + Status := DecodeLine(0, I, Line); + var Remaining := FPendingLength - (I + 1); + if Remaining > 0 then + Move(FPending[I + 1], FPending[0], Remaining); + FPendingLength := Remaining; + Exit(True); + end; + ScanFrom := FPendingLength; + + if FPendingLength > FMaxLineBytes then + begin + FPendingLength := 0; + var Skipped: TArray; + SetLength(Skipped, READ_CHUNK_BYTES); + while True do + begin + var Count := Integer(FStream.Read(Skipped[0], Length(Skipped))); + if Count <= 0 then + begin + FEndOfStream := True; + Line := ''; + Status := TMCPLineStatus.TooLong; + Exit(True); + end; + for var I := 0 to Count - 1 do + if Skipped[I] = 10 then + begin + var Rest: Integer := Count - (I + 1); + if Rest > 0 then + Move(Skipped[I + 1], FPending[0], Rest); + FPendingLength := Rest; + Line := ''; + Status := TMCPLineStatus.TooLong; + Exit(True); + end; + end; + end; + + if FEndOfStream or not Fill then + begin + if FPendingLength = 0 then + Exit(False); + Status := DecodeLine(0, FPendingLength, Line); + FPendingLength := 0; + Exit(True); + end; + end; +end; + +{ TMCPLineWriter } + +constructor TMCPLineWriter.Create(Stream: TStream); +begin + inherited Create; + FStream := Stream; + FLock := TCriticalSection.Create; +end; + +destructor TMCPLineWriter.Destroy; +begin + FLock.Free; + inherited; +end; + +procedure TMCPLineWriter.Send(const Json: string); +begin + var Line := Json.Replace(#13, ' ').Replace(#10, ' ') + #10; + var Bytes := TEncoding.UTF8.GetBytes(Line); + FLock.Enter; + try + FStream.WriteBuffer(Bytes, Length(Bytes)); + finally + FLock.Leave; + end; +end; + +end. diff --git a/src/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index da333b7..fbd1c66 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -5,25 +5,238 @@ interface uses System.SysUtils, System.Classes, + System.SyncObjs, System.JSON, + System.Generics.Collections, MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, MCPServer.JsonRpcProcessor, + MCPServer.StdioChannel, MCPServer.Logger; type + TMCPStdioRequestTracker = class(TInterfacedObject, IMCPRequestTracker) + strict private + type + TEntry = record + Context: IMCPRequestContext; + Cancelled: Boolean; + end; + var + FLock: TCriticalSection; + FEntries: TDictionary; + class function KeyOf(const RequestId: TMCPRequestId): string; static; + public + constructor Create; + destructor Destroy; override; + function Reserve(const RequestId: TMCPRequestId): Boolean; + procedure Release(const RequestId: TMCPRequestId); + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + function CancelAll(const Reason: string): Integer; + end; + TMCPStdioTransport = class - private + public + const DEFAULT_SHUTDOWN_DRAIN_MS = 2000; + const SHUTDOWN_CANCEL_GRACE_MS = 500; + const QUEUE_DEPTH = 1024; + const LISTENER_POLL_MS = 10; + strict private FManagerRegistry: IMCPManagerRegistry; FCoreManager: IMCPCapabilityManager; FJsonRpcProcessor: TMCPJsonRpcProcessor; + FLegacySession: TMCPLegacySession; + FTracker: TMCPStdioRequestTracker; + FTrackerIntf: IMCPRequestTracker; + FWriter: IMCPMessageSink; + FQueue: TThreadedQueue; + FWorkersDone: TCountdownEvent; + FShutdownDrainMs: Integer; + FWorkerStuck: Boolean; + FListeners: Integer; + function GetSettings: TMCPSettings; + procedure SetSettings(const Value: TMCPSettings); + function Hints: TMCPTransportHints; + function WorkerCount: Integer; + procedure SendResponse(const Body: string); + procedure SendError(const RequestId: TMCPRequestId; Code: Integer; const Message: string); + procedure ProcessInline(const Message: TJSONValue); + procedure DispatchLine(const Message: TJSONValue); + procedure ProcessQueued(const Message: TJSONValue); + procedure StartListener(const Message: TJSONValue); + procedure CloseSubscriptions; + procedure StartWorkers; + procedure DrainAndStop; + procedure ReadLoop(InputStream: TStream); + private + procedure WorkerLoop; public constructor Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); destructor Destroy; override; procedure Run; + procedure RunWith(InputStream, OutputStream: TStream); + property Settings: TMCPSettings read GetSettings write SetSettings; + property ShutdownDrainMs: Integer read FShutdownDrainMs write FShutdownDrainMs; end; implementation +uses + MCPServer.Errors; + +type + TMCPStdioWorker = class(TThread) + strict private + FTransport: TMCPStdioTransport; + protected + procedure Execute; override; + public + constructor Create(Transport: TMCPStdioTransport); + end; + +{ TMCPStdioWorker } + +constructor TMCPStdioWorker.Create(Transport: TMCPStdioTransport); +begin + inherited Create(False); + FTransport := Transport; + FreeOnTerminate := True; +end; + +procedure TMCPStdioWorker.Execute; +begin + FTransport.WorkerLoop; +end; + +{ TMCPStdioRequestTracker } + +constructor TMCPStdioRequestTracker.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FEntries := TDictionary.Create; +end; + +destructor TMCPStdioRequestTracker.Destroy; +begin + FEntries.Free; + FLock.Free; + inherited; +end; + +class function TMCPStdioRequestTracker.KeyOf(const RequestId: TMCPRequestId): string; +begin + if RequestId.Kind = TMCPRequestIdKind.Number then + Result := 'n:' + RequestId.AsText + else + Result := 's:' + RequestId.AsText; +end; + +function TMCPStdioRequestTracker.Reserve(const RequestId: TMCPRequestId): Boolean; +begin + FLock.Enter; + try + Result := not FEntries.ContainsKey(KeyOf(RequestId)); + if Result then + FEntries.Add(KeyOf(RequestId), Default(TEntry)); + finally + FLock.Leave; + end; +end; + +procedure TMCPStdioRequestTracker.Release(const RequestId: TMCPRequestId); +begin + FLock.Enter; + try + FEntries.Remove(KeyOf(RequestId)); + finally + FLock.Leave; + end; +end; + +procedure TMCPStdioRequestTracker.Track(const Context: IMCPRequestContext); +var + Entry: TEntry; +begin + var Key := KeyOf(Context.RequestId); + var CancelNow: Boolean; + FLock.Enter; + try + if not FEntries.TryGetValue(Key, Entry) then + Entry := Default(TEntry); + Entry.Context := Context; + FEntries.AddOrSetValue(Key, Entry); + CancelNow := Entry.Cancelled; + finally + FLock.Leave; + end; + if CancelNow then + Context.Cancel; +end; + +procedure TMCPStdioRequestTracker.Untrack(const Context: IMCPRequestContext); +begin + Release(Context.RequestId); +end; + +function TMCPStdioRequestTracker.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +var + Entry: TEntry; +begin + var Context: IMCPRequestContext := nil; + FLock.Enter; + try + Result := FEntries.TryGetValue(KeyOf(RequestId), Entry); + if Result then + begin + Entry.Cancelled := True; + FEntries[KeyOf(RequestId)] := Entry; + Context := Entry.Context; + end; + finally + FLock.Leave; + end; + + if not Result then + Exit; + if Assigned(Context) then + Context.Cancel; + if Reason <> '' then + TLogger.Info(Format('Request %s cancelled by the client: %s', [RequestId.AsText, Reason])) + else + TLogger.Info(Format('Request %s cancelled by the client', [RequestId.AsText])); +end; + +function TMCPStdioRequestTracker.CancelAll(const Reason: string): Integer; +begin + var Contexts := TList.Create; + try + FLock.Enter; + try + Result := Integer(FEntries.Count); + for var Key in FEntries.Keys.ToArray do + begin + var Entry := FEntries[Key]; + Entry.Cancelled := True; + FEntries[Key] := Entry; + if Assigned(Entry.Context) then + Contexts.Add(Entry.Context); + end; + finally + FLock.Leave; + end; + for var Context in Contexts do + Context.Cancel; + finally + Contexts.Free; + end; + if Result > 0 then + TLogger.Warning(Format('%d request(s) cancelled: %s', [Result, Reason])); +end; + { TMCPStdioTransport } constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); @@ -32,70 +245,282 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core FManagerRegistry := ManagerRegistry; FCoreManager := CoreManager; FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(ManagerRegistry); + FLegacySession := TMCPLegacySession.Create; + FTracker := TMCPStdioRequestTracker.Create; + FTrackerIntf := FTracker; + FShutdownDrainMs := DEFAULT_SHUTDOWN_DRAIN_MS; + + TLogger.UseStdErr := True; + TLogger.StdoutReserved := True; end; destructor TMCPStdioTransport.Destroy; begin - FJsonRpcProcessor.Free; + if not FWorkerStuck then + begin + FJsonRpcProcessor.Free; + FLegacySession.Free; + FTrackerIntf := nil; + end; inherited; end; -procedure TMCPStdioTransport.Run; -var - ErrorJson: TJSONObject; - ErrorObj: TJSONObject; - InputLine: string; - Response: string; +function TMCPStdioTransport.GetSettings: TMCPSettings; begin - TLogger.Info('STDIO transport started - reading from stdin, writing to stdout'); - TLogger.Info('Logging to stderr'); + Result := FJsonRpcProcessor.Settings; +end; - InputLine := ''; - while not Eof(Input) do - begin - try - Readln(Input, InputLine); +procedure TMCPStdioTransport.SetSettings(const Value: TMCPSettings); +begin + FJsonRpcProcessor.Settings := Value; +end; + +function TMCPStdioTransport.Hints: TMCPTransportHints; +begin + Result := TMCPTransportHints.ForStdio(FLegacySession, FWriter, FTrackerIntf); +end; + +function TMCPStdioTransport.WorkerCount: Integer; +begin + Result := Settings.MaxConcurrentRequests; + if Result < 1 then + Result := 1; +end; - if InputLine.Trim = '' then - Continue; +procedure TMCPStdioTransport.SendResponse(const Body: string); +begin + if Body = '' then + Exit; + FWriter.Send(Body); + TLogger.Debug('Sent: ' + TLogger.RedactJson(Body)); +end; - TLogger.Info('Received: ' + InputLine); +procedure TMCPStdioTransport.SendError(const RequestId: TMCPRequestId; Code: Integer; const Message: string); +begin + var Error := EMCPError.Create(Code, Message); + try + SendResponse(FJsonRpcProcessor.BuildErrorResponse(RequestId, Error)); + finally + Error.Free; + end; +end; - Response := FJsonRpcProcessor.ProcessRequest(InputLine, ''); +procedure TMCPStdioTransport.ProcessInline(const Message: TJSONValue); +begin + SendResponse(FJsonRpcProcessor.ProcessRequestEx(Message, Hints).Body); +end; + +procedure TMCPStdioTransport.DispatchLine(const Message: TJSONValue); +begin + var Queued := False; + try + if Message is TJSONObject then + begin + var Request := TJSONObject(Message); + var RequestId := TMCPRequestId.FromJson(Request.GetValue('id')); + var MethodValue := Request.GetValue('method'); + var Method := ''; + if MethodValue is TJSONString then + Method := TJSONString(MethodValue).Value; - if Response <> '' then + if RequestId.IsPresent and (Method <> '') and (Method <> 'ping') then begin - Writeln(Output, Response); - Flush(Output); - TLogger.Info('Sent: ' + Response); + if not FTracker.Reserve(RequestId) then + begin + SendError(RequestId, JSONRPC_INVALID_REQUEST, Format('Request id %s is still in flight', [RequestId.AsText])); + Exit; + end; + if Method = MCP_METHOD_SUBSCRIPTIONS_LISTEN then + begin + StartListener(Message); + Queued := True; + Exit; + end; + if FQueue.PushItem(Message) <> TWaitResult.wrSignaled then + begin + FTracker.Release(RequestId); + SendError(RequestId, JSONRPC_INTERNAL_ERROR, 'Server is shutting down'); + Exit; + end; + Queued := True; + Exit; end; + end; - except - on E: Exception do - begin - TLogger.Error('Error processing STDIO request: ' + E.Message); + ProcessInline(Message); + finally + if not Queued then + Message.Free; + end; +end; - // Build the error response with the JSON writer: hand-concatenated - // JSON with only '"' replaced emits invalid JSON whenever the message - // contains a backslash (e.g. a Windows path) or a control character. - ErrorJson := TJSONObject.Create; +procedure TMCPStdioTransport.ProcessQueued(const Message: TJSONValue); +begin + var RequestId := TMCPRequestId.FromJson(TJSONObject(Message).GetValue('id')); + try + var Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, Hints); + if Outcome.Cancelled then + TLogger.Info('No response for cancelled request ' + RequestId.AsText) + else + SendResponse(Outcome.Body); + finally + FTracker.Release(RequestId); + Message.Free; + end; +end; + +procedure TMCPStdioTransport.StartListener(const Message: TJSONValue); +begin + AtomicIncrement(FListeners); + TThread.CreateAnonymousThread( + procedure + begin + try try - ErrorJson.AddPair('jsonrpc', '2.0'); - ErrorJson.AddPair('id', TJSONNull.Create); - ErrorObj := TJSONObject.Create; - ErrorJson.AddPair('error', ErrorObj); - ErrorObj.AddPair('code', TJSONNumber.Create(JSONRPC_INTERNAL_ERROR)); - ErrorObj.AddPair('message', E.Message); - Writeln(Output, ErrorJson.ToJSON); - finally - ErrorJson.Free; + ProcessQueued(Message); + except + on E: Exception do + TLogger.Error(Format('Error processing stdio subscription: %s', [E.Message])); + end; + finally + AtomicDecrement(FListeners); + end; + end).Start; +end; + +procedure TMCPStdioTransport.CloseSubscriptions; +var + Hub: IMCPSubscriptionHub; +begin + Supports(FManagerRegistry.GetManagerForMethod(MCP_METHOD_SUBSCRIPTIONS_LISTEN), IMCPSubscriptionHub, Hub); + var Deadline := TThread.GetTickCount64 + UInt64(FShutdownDrainMs); + repeat + if Assigned(Hub) then + Hub.CloseAll('stdin closed'); + if AtomicCmpExchange(FListeners, 0, 0) = 0 then + Break; + Sleep(LISTENER_POLL_MS); + until TThread.GetTickCount64 >= Deadline; +end; + +procedure TMCPStdioTransport.WorkerLoop; +var + Message: TJSONValue; +begin + var Queue := FQueue; + var Done := FWorkersDone; + try + while Queue.PopItem(Message) = TWaitResult.wrSignaled do + begin + if not Assigned(Message) then + Break; + try + ProcessQueued(Message); + except + on E: Exception do + TLogger.Error('Error processing stdio request: ' + E.Message); + end; + end; + finally + Done.Signal; + end; +end; + +procedure TMCPStdioTransport.StartWorkers; +begin + var Count := WorkerCount; + FQueue := TThreadedQueue.Create(QUEUE_DEPTH, INFINITE, INFINITE); + FWorkersDone := TCountdownEvent.Create(Count); + for var I := 1 to Count do + TMCPStdioWorker.Create(Self); + TLogger.Info(Format('STDIO transport started: %d worker thread(s), logging to stderr', [Count])); +end; + +procedure TMCPStdioTransport.DrainAndStop; +begin + for var I := 1 to WorkerCount do + FQueue.PushItem(nil); + + if FWorkersDone.WaitFor(Cardinal(FShutdownDrainMs)) <> TWaitResult.wrSignaled then + begin + FTracker.CancelAll('stdin closed'); + FWorkersDone.WaitFor(SHUTDOWN_CANCEL_GRACE_MS); + end; + CloseSubscriptions; + + if FWorkersDone.IsSet then + begin + FWorkersDone.Free; + FQueue.Free; + FWorkersDone := nil; + FQueue := nil; + end + else + begin + FWorkerStuck := True; + TLogger.Warning('A request handler did not stop; leaving it to the process exit'); + end; +end; + +procedure TMCPStdioTransport.ReadLoop(InputStream: TStream); +var + Line: string; + Status: TMCPLineStatus; +begin + var Reader := TMCPLineReader.Create(InputStream, Settings.MaxRequestBodyBytes); + try + while Reader.ReadLine(Line, Status) do + begin + try + case Status of + TMCPLineStatus.TooLong: + SendError(TMCPRequestId.FromJson(nil), JSONRPC_INVALID_REQUEST, + Format('Message exceeds %d bytes', [Settings.MaxRequestBodyBytes])); + TMCPLineStatus.InvalidUtf8: + SendError(TMCPRequestId.FromJson(nil), JSONRPC_PARSE_ERROR, 'Message is not valid UTF-8'); + else + if Line.Trim = '' then + Continue; + TLogger.Debug('Received: ' + TLogger.RedactJson(Line)); + DispatchLine(TJSONObject.ParseJSONValue(Line)); end; - Flush(Output); + except + on E: Exception do + TLogger.Error('Error reading stdio request: ' + E.Message); end; end; + finally + Reader.Free; end; +end; - TLogger.Info('STDIO transport stopped - EOF reached'); +procedure TMCPStdioTransport.RunWith(InputStream, OutputStream: TStream); +begin + FWriter := TMCPLineWriter.Create(OutputStream); + try + StartWorkers; + try + ReadLoop(InputStream); + TLogger.Info('STDIO transport: stdin closed'); + finally + DrainAndStop; + end; + finally + FWriter := nil; + end; + TLogger.Info('STDIO transport stopped'); +end; + +procedure TMCPStdioTransport.Run; +begin + var InputStream := StandardInputStream; + var OutputStream := StandardOutputStream; + try + RunWith(InputStream, OutputStream); + finally + OutputStream.Free; + InputStream.Free; + end; end; end. diff --git a/src/Tools/MCPServer.Tool.Base.pas b/src/Tools/MCPServer.Tool.Base.pas index cda7484..6730a92 100644 --- a/src/Tools/MCPServer.Tool.Base.pas +++ b/src/Tools/MCPServer.Tool.Base.pas @@ -5,7 +5,8 @@ interface uses System.SysUtils, System.Rtti, - System.JSON; + System.JSON, + MCPServer.Types; type IMCPTool = interface @@ -24,66 +25,84 @@ interface property OutputSchema: TJSONObject read GetOutputSchema; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; + FAnnotations: TJSONObject; + FIcons: TJSONArray; function BuildSchema: TJSONObject; virtual; abstract; + function DoExecute(const Arguments: TJSONObject): TValue; virtual; abstract; public constructor Create; virtual; + destructor Destroy; override; function GetName: string; function GetTitle: string; function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; - function Execute(const Arguments: TJSONObject): TValue; virtual; abstract; + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; + function Execute(const Arguments: TJSONObject): TValue; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; - function ExecuteWithParams(const Params: T): string;virtual; abstract; + FAnnotations: TJSONObject; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T): string; virtual; + function ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; virtual; function GetParamsClass: TClass; virtual; public constructor Create; virtual; + destructor Destroy; override; function GetName: string; function GetTitle: string; function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; function Execute(const Arguments: TJSONObject): TValue; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; - function ExecuteWithParams(const Params: T): R;virtual; abstract; + FAnnotations: TJSONObject; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T): R; virtual; + function ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; virtual; public constructor Create; virtual; + destructor Destroy; override; function GetName: string; function GetTitle: string; function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; function Execute(const Arguments: TJSONObject): TValue; end; - - - implementation uses MCPServer.Schema.Generator, - MCPServer.Serializer; + MCPServer.Schema.Validator, + MCPServer.Serializer, + MCPServer.RequestContext, + MCPServer.Tool.Result; { TMCPToolBase } @@ -92,6 +111,13 @@ constructor TMCPToolBase.Create; inherited Create; end; +destructor TMCPToolBase.Destroy; +begin + FAnnotations.Free; + FIcons.Free; + inherited; +end; + function TMCPToolBase.GetName: string; begin Result := FName; @@ -107,7 +133,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -120,6 +146,29 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := BuildSchema; end; +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; +begin + var Schema := BuildSchema; + try + var Errors: TArray; + if not TMCPSchemaValidator.Validate(Schema, Arguments, Errors) then + raise EArgumentException.Create(string.Join('; ', Errors)); + finally + Schema.Free; + end; + Result := DoExecute(Arguments); +end; + { TMCPToolBase } constructor TMCPToolBase.Create; @@ -127,6 +176,13 @@ constructor TMCPToolBase.Create; inherited Create; end; +destructor TMCPToolBase.Destroy; +begin + FAnnotations.Free; + FIcons.Free; + inherited; +end; + function TMCPToolBase.GetName: string; begin Result := FName; @@ -142,7 +198,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -155,13 +211,33 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(T); end; +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +function TMCPToolBase.ExecuteWithParams(const Params: T): string; +begin + raise ENotImplemented.CreateFmt('%s overrides neither ExecuteWithParams nor ExecuteWithContext', [ClassName]); +end; + +function TMCPToolBase.ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; +begin + Result := ExecuteWithParams(Params); +end; + function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; var ParamsInstance: T; begin ParamsInstance := TMCPSerializer.Deserialize(Arguments); try - Result := ExecuteWithParams(ParamsInstance); + Result := ExecuteWithContext(ParamsInstance, TMCPRequestContext.Current); finally ParamsInstance.Free; end; @@ -172,7 +248,6 @@ function TMCPToolBase.GetParamsClass: TClass; Result := T; end; - { TMCPToolBase } constructor TMCPToolBase.Create; @@ -180,22 +255,44 @@ constructor TMCPToolBase.Create; inherited Create; end; -function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; +destructor TMCPToolBase.Destroy; +begin + FAnnotations.Free; + FIcons.Free; + inherited; +end; + +function TMCPToolBase.ExecuteWithParams(const Params: T): R; +begin + raise ENotImplemented.CreateFmt('%s overrides neither ExecuteWithParams nor ExecuteWithContext', [ClassName]); +end; + +function TMCPToolBase.ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; var - ParamsInstance: T; - Response : R; - JsonObj : TJSONObject; + Response: R; begin - ParamsInstance := TMCPSerializer.Deserialize(Arguments); + Response := ExecuteWithParams(Params); try - Response := ExecuteWithParams(ParamsInstance); + var JsonObj := TJSONObject.Create; try - JsonObj := TJSONObject.Create; TMCPSerializer.Serialize(Response, JsonObj); - result := TValue.From(JsonObj); - finally - Response.Free; + except + JsonObj.Free; + raise; end; + Result := TValue.From(JsonObj); + finally + Response.Free; + end; +end; + +function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; +var + ParamsInstance: T; +begin + ParamsInstance := TMCPSerializer.Deserialize(Arguments); + try + Result := ExecuteWithContext(ParamsInstance, TMCPRequestContext.Current); finally ParamsInstance.Free; end; @@ -203,7 +300,7 @@ function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; function TMCPToolBase.GetDescription: string; begin - result := FDescription; + Result := FDescription; end; function TMCPToolBase.GetInputSchema: TJSONObject; @@ -229,4 +326,14 @@ function TMCPToolBase.GetOutputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(R); end; -end. \ No newline at end of file +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +end. diff --git a/src/Tools/MCPServer.Tool.Calculate.pas b/src/Tools/MCPServer.Tool.Calculate.pas index c6344ab..b7988cd 100644 --- a/src/Tools/MCPServer.Tool.Calculate.pas +++ b/src/Tools/MCPServer.Tool.Calculate.pas @@ -10,7 +10,7 @@ interface type TOperationType = (otAdd, otSubtract, otMultiply, otDivide); - + TCalculateParams = class private FOperation: string; @@ -20,10 +20,10 @@ TCalculateParams = class [SchemaDescription('Operation: add, subtract, multiply, divide')] [SchemaEnum('add', 'subtract', 'multiply', 'divide')] property Operation: string read FOperation write FOperation; - + [SchemaDescription('First number')] property A: Double read FA write FA; - + [SchemaDescription('Second number')] property B: Double read FB write FB; end; @@ -74,7 +74,7 @@ function TCalculateTool.ExecuteWithParams(const Params: TCalculateParams): strin Result := 'Error: Unknown operation: ' + Params.Operation; Exit; end; - + Result := Format('%s %s %s = %g', [ FloatToStr(Params.A), Params.Operation, FloatToStr(Params.B), ResultValue ]); diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas new file mode 100644 index 0000000..44b88c4 --- /dev/null +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -0,0 +1,337 @@ +unit MCPServer.Tool.ContentSamples; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base; + +type + TNoParams = class + end; + + TSimpleTextTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TNoParams): string; override; + public + constructor Create; override; + end; + + TImageContentTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TAudioContentTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TEmbeddedResourceTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TMultipleContentTypesTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TProgressToolParams = class + private + FSteps: Integer; + FStepMs: Integer; + public + [Optional] + [SchemaDescription('Number of steps to report (default 5)')] + property Steps: Integer read FSteps write FSteps; + [Optional] + [SchemaDescription('Pause per step in milliseconds (default 100)')] + property StepMs: Integer read FStepMs write FStepMs; + end; + + TProgressTool = class(TMCPToolBase) + public + const DEFAULT_STEPS = 5; + const DEFAULT_STEP_MS = 100; + const MAX_STEPS = 1000; + const MAX_STEP_MS = 10000; + protected + function ExecuteWithContext(const Params: TProgressToolParams; + const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TErrorHandlingTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TNoParams): string; override; + public + constructor Create; override; + end; + + TLoggingTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TJsonSchema202012Tool = class(TMCPToolBase) + protected + function BuildSchema: TJSONObject; override; + function DoExecute(const Arguments: TJSONObject): TValue; override; + public + constructor Create; override; + end; + +const + SAMPLE_TEXT_RESOURCE_URI = 'test://static-text'; + SAMPLE_TEXT_RESOURCE_CONTENT = 'This is the content of the static text resource.'; + SAMPLE_PNG_BASE64 = 'iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mNkYPhfDwAChwGA60e6kgAAAABJRU5ErkJggg=='; + SAMPLE_WAV_BASE64 = 'UklGRiQAAABXQVZFZm10IBAAAAABAAEAQB8AAEAfAAABAAgAZGF0YQAAAAA='; + +implementation + +uses + MCPServer.Errors, + MCPServer.Registration, + MCPServer.Tool.Result; + +{ TSimpleTextTool } + +constructor TSimpleTextTool.Create; +begin + inherited; + FName := 'test_simple_text'; + FDescription := 'Returns a plain text result'; + FAnnotations := TJSONObject.Create; + FAnnotations.AddPair('readOnlyHint', TJSONBool.Create(True)); +end; + +function TSimpleTextTool.ExecuteWithParams(const Params: TNoParams): string; +begin + Result := 'This is a simple text response'; +end; + +{ TImageContentTool } + +constructor TImageContentTool.Create; +begin + inherited; + FName := 'test_image_content'; + FDescription := 'Returns an image content block'; +end; + +function TImageContentTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddImage(SAMPLE_PNG_BASE64, 'image/png'); +end; + +{ TAudioContentTool } + +constructor TAudioContentTool.Create; +begin + inherited; + FName := 'test_audio_content'; + FDescription := 'Returns an audio content block'; +end; + +function TAudioContentTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddAudio(SAMPLE_WAV_BASE64, 'audio/wav'); +end; + +{ TEmbeddedResourceTool } + +constructor TEmbeddedResourceTool.Create; +begin + inherited; + FName := 'test_embedded_resource'; + FDescription := 'Returns an embedded resource content block'; +end; + +function TEmbeddedResourceTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddEmbeddedText(SAMPLE_TEXT_RESOURCE_URI, 'text/plain', SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TMultipleContentTypesTool } + +constructor TMultipleContentTypesTool.Create; +begin + inherited; + FName := 'test_multiple_content_types'; + FDescription := 'Returns text, image and embedded resource content in one result'; +end; + +function TMultipleContentTypesTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create + .AddText('Multiple content types example') + .AddImage(SAMPLE_PNG_BASE64, 'image/png') + .AddEmbeddedText(SAMPLE_TEXT_RESOURCE_URI, 'text/plain', SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TErrorHandlingTool } + +constructor TErrorHandlingTool.Create; +begin + inherited; + FName := 'test_error_handling'; + FDescription := 'Always fails with a tool execution error'; +end; + +function TErrorHandlingTool.ExecuteWithParams(const Params: TNoParams): string; +begin + raise EMCPToolError.Create('This tool always fails, as an example of a tool execution error'); +end; + +{ TProgressTool } + +constructor TProgressTool.Create; +begin + inherited; + FName := 'test_tool_with_progress'; + FDescription := 'Runs a few steps and reports progress for each; honours cancellation'; +end; + +function TProgressTool.ExecuteWithContext(const Params: TProgressToolParams; + const Context: IMCPRequestContext): TValue; +begin + var Steps := Params.Steps; + if (Steps <= 0) or (Steps > MAX_STEPS) then + Steps := DEFAULT_STEPS; + var StepMs := Params.StepMs; + if (StepMs <= 0) or (StepMs > MAX_STEP_MS) then + StepMs := DEFAULT_STEP_MS; + + for var Step := 1 to Steps do + begin + if Assigned(Context) then + begin + Context.CheckCancelled; + Context.ReportProgress(Step - 1, Steps, Format('Step %d of %d', [Step, Steps])); + end; + Sleep(Cardinal(StepMs)); + end; + if Assigned(Context) then + Context.ReportProgress(Steps, Steps, 'Done'); + + Result := Format('Completed %d steps', [Steps]); +end; + +{ TJsonSchema202012Tool } + +constructor TJsonSchema202012Tool.Create; +begin + inherited; + FName := 'json_schema_2020_12_tool'; + FDescription := 'Tool with JSON Schema 2020-12 features'; +end; + +function TJsonSchema202012Tool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{'+ + '"$schema":"https://json-schema.org/draft/2020-12/schema",'+ + '"type":"object",'+ + '"$defs":{"address":{"$anchor":"addressDef","type":"object",'+ + '"properties":{"street":{"type":"string"},"city":{"type":"string"}}}},'+ + '"properties":{'+ + '"name":{"type":"string"},'+ + '"address":{"$ref":"#/$defs/address"},'+ + '"contactMethod":{"type":"string","enum":["phone","email"]},'+ + '"phone":{"type":"string"},'+ + '"email":{"type":"string"}'+ + '},'+ + '"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],'+ + '"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},'+ + '"then":{"required":["phone"]},'+ + '"else":{"required":["email"]},'+ + '"additionalProperties":false'+ + '}') as TJSONObject; +end; + +function TJsonSchema202012Tool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From('ok'); +end; + +{ TLoggingTool } + +constructor TLoggingTool.Create; +begin + inherited; + FName := 'test_logging_tool'; + FDescription := 'Emits log notifications at every level; the client sees those at or above its requested level'; +end; + +function TLoggingTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + for var Level in MCP_LOG_LEVELS do + begin + Context.Log(Level, Format('%s message from test_logging_tool', [Level]), 'test_logging_tool'); + end; + Result := TMCPToolResult.Text('Logged a message at every level'); +end; + +initialization + TMCPRegistry.RegisterTool('test_simple_text', + function: IMCPTool + begin + Result := TSimpleTextTool.Create; + end); + TMCPRegistry.RegisterTool('test_image_content', + function: IMCPTool + begin + Result := TImageContentTool.Create; + end); + TMCPRegistry.RegisterTool('test_audio_content', + function: IMCPTool + begin + Result := TAudioContentTool.Create; + end); + TMCPRegistry.RegisterTool('test_embedded_resource', + function: IMCPTool + begin + Result := TEmbeddedResourceTool.Create; + end); + TMCPRegistry.RegisterTool('test_multiple_content_types', + function: IMCPTool + begin + Result := TMultipleContentTypesTool.Create; + end); + TMCPRegistry.RegisterTool('test_tool_with_progress', + function: IMCPTool + begin + Result := TProgressTool.Create; + end); + TMCPRegistry.RegisterTool('test_error_handling', + function: IMCPTool + begin + Result := TErrorHandlingTool.Create; + end); + TMCPRegistry.RegisterTool('test_logging_tool', + function: IMCPTool + begin + Result := TLoggingTool.Create; + end); + TMCPRegistry.RegisterTool('json_schema_2020_12_tool', + function: IMCPTool + begin + Result := TJsonSchema202012Tool.Create; + end); + +end. diff --git a/src/Tools/MCPServer.Tool.InputRequiredSamples.pas b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas new file mode 100644 index 0000000..6f2ee47 --- /dev/null +++ b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas @@ -0,0 +1,479 @@ +unit MCPServer.Tool.InputRequiredSamples; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base, + MCPServer.Tool.ContentSamples; + +type + TElicitationInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TSamplingInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TListRootsInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TRequestStateInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TMultipleInputsTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TMultiRoundInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TTamperedStateInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TCapabilityAwareInputTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TMissingCapabilityTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TStreamingElicitationTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TInputSample = record + class function DescribeRoots(const Roots: TJSONArray): string; static; + class function NewState(const Round: Integer): TJSONObject; static; + end; + +implementation + +uses + MCPServer.Mrtr, + MCPServer.Registration, + MCPServer.Tool.Result; + +const + KEY_USER_NAME = 'user_name'; + KEY_CAPITAL_QUESTION = 'capital_question'; + KEY_CLIENT_ROOTS = 'client_roots'; + KEY_CONFIRM = 'confirm'; + KEY_GREETING = 'greeting'; + KEY_STEP1 = 'step1'; + KEY_STEP2 = 'step2'; + FIELD_NAME = 'name'; + FIELD_OK = 'ok'; + FIELD_COLOR = 'color'; + STATE_ROUND = 'round'; + STATE_NAME = 'name'; + STATE_NONCE = 'nonce'; + CAPABILITY_ELICITATION = 'elicitation'; + CAPABILITY_SAMPLING = 'sampling'; + CAPABILITY_ROOTS = 'roots'; + ASK_NAME = 'What is your name?'; + CAPITAL_QUESTION = 'What is the capital of France?'; + SAMPLING_MAX_TOKENS = 100; + GREETING_MAX_TOKENS = 50; + +{ TInputSample } + +class function TInputSample.DescribeRoots(const Roots: TJSONArray): string; +begin + var Uris: TArray := nil; + if Assigned(Roots) then + begin + for var Root in Roots do + begin + if Root is TJSONObject then + Uris := Uris + [TJSONObject(Root).GetValue('uri', '')]; + end; + end; + Result := Format('Roots: %s', [string.Join(', ', Uris)]); +end; + +class function TInputSample.NewState(const Round: Integer): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(STATE_ROUND, TJSONNumber.Create(Round)); +end; + +{ TElicitationInputTool } + +constructor TElicitationInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_elicitation'; + FDescription := 'Asks the client for a name through an elicitation input request, then greets it'; +end; + +function TElicitationInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Name := ''; + if Context.TryGetInputResponse(KEY_USER_NAME, Response) then + Name := TMCPInputResponse.ElicitationField(Response, FIELD_NAME); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME))); + + Result := TMCPToolResult.Text(Format('Hello, %s!', [Name])); +end; + +{ TSamplingInputTool } + +constructor TSamplingInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_sampling'; + FDescription := 'Asks the client to sample an answer, then returns that answer'; +end; + +function TSamplingInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Answer := ''; + if Context.TryGetInputResponse(KEY_CAPITAL_QUESTION, Response) then + Answer := TMCPInputResponse.SamplingText(Response); + if Answer = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddSampling(KEY_CAPITAL_QUESTION, CAPITAL_QUESTION, SAMPLING_MAX_TOKENS)); + + Result := TMCPToolResult.Text(Format('LLM response: %s', [Answer])); +end; + +{ TListRootsInputTool } + +constructor TListRootsInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_list_roots'; + FDescription := 'Asks the client for its roots, then lists them'; +end; + +function TListRootsInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + if not Context.TryGetInputResponse(KEY_CLIENT_ROOTS, Response) + or not Assigned(TMCPInputResponse.Roots(Response)) then + raise EMCPInputRequired.Create(TMCPInputRequests.Create.AddListRoots(KEY_CLIENT_ROOTS)); + + Result := TMCPToolResult.Text(TInputSample.DescribeRoots(TMCPInputResponse.Roots(Response))); +end; + +{ TRequestStateInputTool } + +constructor TRequestStateInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_request_state'; + FDescription := 'Asks for a confirmation and carries a signed requestState across the round trip'; +end; + +function TRequestStateInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + var HasState := Assigned(Context.RequestState) and Assigned(Context.RequestState.GetValue(STATE_NONCE)); + if not Confirmed or not HasState then + begin + var State := TJSONObject.Create; + State.AddPair(STATE_NONCE, TGUID.NewGuid.ToString); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean')), State); + end; + + Result := TMCPToolResult.Text(Format('state-ok: confirmed with nonce %s', + [Context.RequestState.GetValue(STATE_NONCE)])); +end; + +{ TMultipleInputsTool } + +constructor TMultipleInputsTool.Create; +begin + inherited; + FName := 'test_input_required_result_multiple_inputs'; + FDescription := 'Asks for a name, a sampled greeting and the client roots in one round trip'; +end; + +function TMultipleInputsTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + NameResponse, GreetingResponse, RootsResponse: TJSONObject; +begin + var Complete := Context.TryGetInputResponse(KEY_USER_NAME, NameResponse) + and Context.TryGetInputResponse(KEY_GREETING, GreetingResponse) + and Context.TryGetInputResponse(KEY_CLIENT_ROOTS, RootsResponse) + and Assigned(Context.RequestState); + if not Complete then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME)) + .AddSampling(KEY_GREETING, 'Generate a greeting', GREETING_MAX_TOKENS) + .AddListRoots(KEY_CLIENT_ROOTS), TInputSample.NewState(1)); + + Result := TMCPToolResult.Text(Format('%s, %s! %s', [ + TMCPInputResponse.SamplingText(GreetingResponse), + TMCPInputResponse.ElicitationField(NameResponse, FIELD_NAME), + TInputSample.DescribeRoots(TMCPInputResponse.Roots(RootsResponse))])); +end; + +{ TMultiRoundInputTool } + +constructor TMultiRoundInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_multi_round'; + FDescription := 'Asks for a name and then a colour in two consecutive round trips'; +end; + +function TMultiRoundInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Round := 0; + if Assigned(Context.RequestState) then + Round := Context.RequestState.GetValue(STATE_ROUND, 0); + + if Round < 1 then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP1, 'Step 1: What is your name?', TMCPInputRequests.FieldSchema(FIELD_NAME)), TInputSample.NewState(1)); + + if Round = 1 then + begin + var Name := ''; + if Context.TryGetInputResponse(KEY_STEP1, Response) then + Name := TMCPInputResponse.ElicitationField(Response, FIELD_NAME); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP1, 'Step 1: What is your name?', TMCPInputRequests.FieldSchema(FIELD_NAME)), TInputSample.NewState(1)); + + var State := TInputSample.NewState(2); + State.AddPair(STATE_NAME, Name); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP2, 'Step 2: What is your favorite color?', TMCPInputRequests.FieldSchema(FIELD_COLOR)), State); + end; + + var Color := ''; + if Context.TryGetInputResponse(KEY_STEP2, Response) then + Color := TMCPInputResponse.ElicitationField(Response, FIELD_COLOR); + if Color = '' then + begin + var State := TInputSample.NewState(2); + State.AddPair(STATE_NAME, Context.RequestState.GetValue(STATE_NAME, '')); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP2, 'Step 2: What is your favorite color?', TMCPInputRequests.FieldSchema(FIELD_COLOR)), State); + end; + + Result := TMCPToolResult.Text(Format('Hello, %s! Your favorite color is %s.', + [Context.RequestState.GetValue(STATE_NAME, ''), Color])); +end; + +{ TTamperedStateInputTool } + +constructor TTamperedStateInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_tampered_state'; + FDescription := 'Asks for a confirmation with a signed requestState that must come back unchanged'; +end; + +function TTamperedStateInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + if not Confirmed or not Assigned(Context.RequestState) then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean')), TInputSample.NewState(1)); + + Result := TMCPToolResult.Text('state-ok: the requestState verified'); +end; + +{ TCapabilityAwareInputTool } + +constructor TCapabilityAwareInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_capabilities'; + FDescription := 'Asks only for the kinds of input the client declared it can provide'; +end; + +function TCapabilityAwareInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Answers: TArray := nil; + var Requests := TMCPInputRequests.Create; + try + var Response: TJSONObject; + if Context.HasClientCapability(CAPABILITY_ELICITATION) then + begin + if Context.TryGetInputResponse(KEY_USER_NAME, Response) then + Answers := Answers + [Format('name=%s', [TMCPInputResponse.ElicitationField(Response, FIELD_NAME)])] + else + Requests.AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME)); + end; + if Context.HasClientCapability(CAPABILITY_SAMPLING) then + begin + if Context.TryGetInputResponse(KEY_CAPITAL_QUESTION, Response) then + Answers := Answers + [Format('capital=%s', [TMCPInputResponse.SamplingText(Response)])] + else + Requests.AddSampling(KEY_CAPITAL_QUESTION, CAPITAL_QUESTION, SAMPLING_MAX_TOKENS); + end; + if Context.HasClientCapability(CAPABILITY_ROOTS) then + begin + if Context.TryGetInputResponse(KEY_CLIENT_ROOTS, Response) then + Answers := Answers + [TInputSample.DescribeRoots(TMCPInputResponse.Roots(Response))] + else + Requests.AddListRoots(KEY_CLIENT_ROOTS); + end; + + if Requests.Count > 0 then + begin + var Pending := Requests; + Requests := nil; + raise EMCPInputRequired.Create(Pending); + end; + finally + Requests.Free; + end; + + if Length(Answers) = 0 then + Result := TMCPToolResult.Text('The client declared no capability this tool can ask input through') + else + Result := TMCPToolResult.Text(string.Join('; ', Answers)); +end; + +{ TMissingCapabilityTool } + +constructor TMissingCapabilityTool.Create; +begin + inherited; + FName := 'test_missing_capability'; + FDescription := 'Requires the sampling client capability and fails with -32021 when it is absent'; +end; + +function TMissingCapabilityTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Context.RequireClientCapability(CAPABILITY_SAMPLING); + Result := TMCPToolResult.Text('The client declared the sampling capability'); +end; + +{ TStreamingElicitationTool } + +constructor TStreamingElicitationTool.Create; +begin + inherited; + FName := 'test_streaming_elicitation'; + FDescription := 'Logs to the response stream, then asks the client for a confirmation'; +end; + +function TStreamingElicitationTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + Context.Log('info', 'Asking the client to confirm', 'test_streaming_elicitation'); + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + if not Confirmed then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean'))); + + Result := TMCPToolResult.Text('Confirmed'); +end; + +initialization + TMCPRegistry.RegisterTool('test_input_required_result_elicitation', + function: IMCPTool + begin + Result := TElicitationInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_sampling', + function: IMCPTool + begin + Result := TSamplingInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_list_roots', + function: IMCPTool + begin + Result := TListRootsInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_request_state', + function: IMCPTool + begin + Result := TRequestStateInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_multiple_inputs', + function: IMCPTool + begin + Result := TMultipleInputsTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_multi_round', + function: IMCPTool + begin + Result := TMultiRoundInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_tampered_state', + function: IMCPTool + begin + Result := TTamperedStateInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_capabilities', + function: IMCPTool + begin + Result := TCapabilityAwareInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_missing_capability', + function: IMCPTool + begin + Result := TMissingCapabilityTool.Create; + end); + TMCPRegistry.RegisterTool('test_streaming_elicitation', + function: IMCPTool + begin + Result := TStreamingElicitationTool.Create; + end); + +end. diff --git a/src/Tools/MCPServer.Tool.ListFiles.pas b/src/Tools/MCPServer.Tool.ListFiles.pas index 8e6e8f3..777d8b8 100644 --- a/src/Tools/MCPServer.Tool.ListFiles.pas +++ b/src/Tools/MCPServer.Tool.ListFiles.pas @@ -19,7 +19,7 @@ TListFilesParams = class public [SchemaDescription('Directory path to list files from')] property Path: string read FPath write FPath; - + [Optional] [SchemaDescription('Include hidden files in the listing')] property IncludeHidden: Boolean read FIncludeHidden write FIncludeHidden; @@ -67,7 +67,7 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin Result := 'Error: Access denied - path outside allowed directory'; Exit; end; - + if TDirectory.Exists(NormalizedPath) then begin FileArray := TDirectory.GetFiles(NormalizedPath); @@ -83,7 +83,7 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin {$WARN SYMBOL_PLATFORM ON} end; {$ENDIF} - + Files.Add(ExtractFileName(FileName)); end; Result := 'Files in ' + NormalizedPath + ':' + sLineBreak + Files.Text; diff --git a/src/Tools/MCPServer.Tool.Result.pas b/src/Tools/MCPServer.Tool.Result.pas new file mode 100644 index 0000000..9d7348c --- /dev/null +++ b/src/Tools/MCPServer.Tool.Result.pas @@ -0,0 +1,188 @@ +unit MCPServer.Tool.Result; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON, + System.Generics.Collections, + MCPServer.Types, + MCPServer.ContentBlocks; + +type + TMCPToolResult = class + private + FContent: TJSONArray; + FStructuredContent: TJSONValue; + FMeta: TJSONObject; + FIsError: Boolean; + function BuildContent(Era: TMCPProtocolEra): TJSONArray; + public + constructor Create; + destructor Destroy; override; + + function AddText(const Text: string): TMCPToolResult; + function AddImage(const Data: TBytes; const MimeType: string): TMCPToolResult; overload; + function AddImage(const Base64Data, MimeType: string): TMCPToolResult; overload; + function AddAudio(const Data: TBytes; const MimeType: string): TMCPToolResult; overload; + function AddAudio(const Base64Data, MimeType: string): TMCPToolResult; overload; + function AddResourceLink(const Uri, Name: string; const Description: string = ''; + const MimeType: string = ''): TMCPToolResult; + function AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; + function AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; + function WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; + function SetStructuredContent(const Value: TJSONValue): TMCPToolResult; + function SetMeta(const Meta: TJSONObject): TMCPToolResult; + function SetError(const Message: string): TMCPToolResult; + + class function Text(const Text: string): TMCPToolResult; + class function Error(const Message: string): TMCPToolResult; + + function ToJson(Era: TMCPProtocolEra): TJSONObject; + + property IsError: Boolean read FIsError write FIsError; + property Content: TJSONArray read FContent; + property StructuredContent: TJSONValue read FStructuredContent; + end; + +implementation + +{ TMCPToolResult } + +constructor TMCPToolResult.Create; +begin + inherited Create; + FContent := TJSONArray.Create; +end; + +destructor TMCPToolResult.Destroy; +begin + FContent.Free; + FStructuredContent.Free; + FMeta.Free; + inherited; +end; + +function TMCPToolResult.AddText(const Text: string): TMCPToolResult; +begin + FContent.AddElement(CreateTextBlock(Text)); + Result := Self; +end; + +function TMCPToolResult.AddImage(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddImage(EncodeBase64Blob(Data), MimeType); +end; + +function TMCPToolResult.AddImage(const Base64Data, MimeType: string): TMCPToolResult; +begin + FContent.AddElement(CreateImageBlock(Base64Data, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddAudio(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddAudio(EncodeBase64Blob(Data), MimeType); +end; + +function TMCPToolResult.AddAudio(const Base64Data, MimeType: string): TMCPToolResult; +begin + FContent.AddElement(CreateAudioBlock(Base64Data, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddResourceLink(const Uri, Name, Description, MimeType: string): TMCPToolResult; +begin + FContent.AddElement(CreateResourceLinkBlock(Uri, Name, Description, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; +begin + FContent.AddElement(CreateEmbeddedTextBlock(Uri, MimeType, Text)); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; +begin + FContent.AddElement(CreateEmbeddedBlobBlock(Uri, MimeType, EncodeBase64Blob(Data))); + Result := Self; +end; + +function TMCPToolResult.WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; +begin + if FContent.Count = 0 then + begin + Annotations.Free; + raise EInvalidOperation.Create('WithAnnotations needs a content block to attach to'); + end; + TJSONObject(FContent.Items[FContent.Count - 1]).AddPair('annotations', Annotations); + Result := Self; +end; + +function TMCPToolResult.SetStructuredContent(const Value: TJSONValue): TMCPToolResult; +begin + FStructuredContent.Free; + FStructuredContent := Value; + Result := Self; +end; + +function TMCPToolResult.SetMeta(const Meta: TJSONObject): TMCPToolResult; +begin + FMeta.Free; + FMeta := Meta; + Result := Self; +end; + +function TMCPToolResult.SetError(const Message: string): TMCPToolResult; +begin + AddText(Message); + FIsError := True; + Result := Self; +end; + +class function TMCPToolResult.Text(const Text: string): TMCPToolResult; +begin + Result := TMCPToolResult.Create.AddText(Text); +end; + +class function TMCPToolResult.Error(const Message: string): TMCPToolResult; +begin + Result := TMCPToolResult.Create.SetError(Message); +end; + +function TMCPToolResult.BuildContent(Era: TMCPProtocolEra): TJSONArray; +begin + Result := TJSONArray(FContent.Clone); + if (Result.Count = 0) and Assigned(FStructuredContent) then + begin + var Block := TJSONObject.Create; + Block.AddPair('type', 'text'); + Block.AddPair('text', FStructuredContent.ToJSON); + Result.AddElement(Block); + end; +end; + +function TMCPToolResult.ToJson(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TJSONObject.Create; + try + Result.AddPair('content', BuildContent(Era)); + + if Assigned(FStructuredContent) + and ((Era = TMCPProtocolEra.Modern) or (FStructuredContent is TJSONObject)) then + Result.AddPair('structuredContent', FStructuredContent.Clone as TJSONValue); + + if FIsError then + Result.AddPair('isError', TJSONBool.Create(True)); + + if Assigned(FMeta) then + Result.AddPair('_meta', TJSONObject(FMeta.Clone)); + except + Result.Free; + raise; + end; +end; + +end. diff --git a/src/Tools/MCPServer.Tool.SubscriptionSamples.pas b/src/Tools/MCPServer.Tool.SubscriptionSamples.pas new file mode 100644 index 0000000..c9ed240 --- /dev/null +++ b/src/Tools/MCPServer.Tool.SubscriptionSamples.pas @@ -0,0 +1,179 @@ +unit MCPServer.Tool.SubscriptionSamples; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base, + MCPServer.Tool.ContentSamples, + MCPServer.Prompt.Base; + +type + TDynamicTool = class(TSimpleTextTool) + public + constructor Create; override; + end; + + TDynamicPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TTriggerToolChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TTriggerPromptChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TTriggerResourceChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.Registration, + MCPServer.ToolsManager, + MCPServer.PromptsManager, + MCPServer.ResourcesManager, + MCPServer.Tool.Result; + +const + DYNAMIC_TOOL_NAME = 'test_dynamic_tool'; + DYNAMIC_PROMPT_NAME = 'test_dynamic_prompt'; + UPDATED_RESOURCE_URI = 'test://static-text'; + +{ TDynamicTool } + +constructor TDynamicTool.Create; +begin + inherited; + FName := DYNAMIC_TOOL_NAME; + FDescription := 'Appears and disappears when test_trigger_tool_change runs'; +end; + +{ TDynamicPrompt } + +constructor TDynamicPrompt.Create; +begin + inherited; + FName := DYNAMIC_PROMPT_NAME; + FDescription := 'Appears and disappears when test_trigger_prompt_change runs'; +end; + +function TDynamicPrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', 'This prompt was added at run time.'); + Result := 'Dynamic prompt'; +end; + +{ TTriggerToolChangeTool } + +constructor TTriggerToolChangeTool.Create; +begin + inherited; + FName := 'test_trigger_tool_change'; + FDescription := 'Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed'; +end; + +function TTriggerToolChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('tools/list') as TObject; + if not (Manager is TMCPToolsManager) then + raise EMCPError.InternalError('No tools manager to change'); + + var Tools := TMCPToolsManager(Manager); + if Tools.HasTool(DYNAMIC_TOOL_NAME) then + begin + Tools.RemoveTool(DYNAMIC_TOOL_NAME); + Result := TMCPToolResult.Text(Format('Removed %s', [DYNAMIC_TOOL_NAME])); + end + else + begin + Tools.AddTool(TDynamicTool.Create); + Result := TMCPToolResult.Text(Format('Added %s', [DYNAMIC_TOOL_NAME])); + end; +end; + +{ TTriggerPromptChangeTool } + +constructor TTriggerPromptChangeTool.Create; +begin + inherited; + FName := 'test_trigger_prompt_change'; + FDescription := 'Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed'; +end; + +function TTriggerPromptChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('prompts/list') as TObject; + if not (Manager is TMCPPromptsManager) then + raise EMCPError.InternalError('No prompts manager to change'); + + var Prompts := TMCPPromptsManager(Manager); + if Prompts.HasPrompt(DYNAMIC_PROMPT_NAME) then + begin + Prompts.RemovePrompt(DYNAMIC_PROMPT_NAME); + Result := TMCPToolResult.Text(Format('Removed %s', [DYNAMIC_PROMPT_NAME])); + end + else + begin + Prompts.AddPrompt(TDynamicPrompt.Create); + Result := TMCPToolResult.Text(Format('Added %s', [DYNAMIC_PROMPT_NAME])); + end; +end; + +{ TTriggerResourceChangeTool } + +constructor TTriggerResourceChangeTool.Create; +begin + inherited; + FName := 'test_trigger_resource_change'; + FDescription := 'Reports test://static-text as updated to the clients subscribed to it'; +end; + +function TTriggerResourceChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('resources/list') as TObject; + if not (Manager is TMCPResourcesManager) then + raise EMCPError.InternalError('No resources manager to change'); + + TMCPResourcesManager(Manager).ResourceUpdated(UPDATED_RESOURCE_URI); + Result := TMCPToolResult.Text(Format('Reported %s as updated', [UPDATED_RESOURCE_URI])); +end; + +initialization + TMCPRegistry.RegisterTool('test_trigger_tool_change', + function: IMCPTool + begin + Result := TTriggerToolChangeTool.Create; + end); + TMCPRegistry.RegisterTool('test_trigger_prompt_change', + function: IMCPTool + begin + Result := TTriggerPromptChangeTool.Create; + end); + TMCPRegistry.RegisterTool('test_trigger_resource_change', + function: IMCPTool + begin + Result := TTriggerResourceChangeTool.Create; + end); + +end. diff --git a/tests/MCPServer.Tests.Authorization.pas b/tests/MCPServer.Tests.Authorization.pas new file mode 100644 index 0000000..883fb3c --- /dev/null +++ b/tests/MCPServer.Tests.Authorization.pas @@ -0,0 +1,273 @@ +unit MCPServer.Tests.Authorization; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + IdHTTPServer, + IdContext, + IdCustomHTTPServer, + MCPServer.Types, + MCPServer.Authorization; + +type + TClaimsAuthorizer = class(TMCPOAuthResourceServerAuthorizer) + strict private + FClaimsJson: string; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; override; + public + constructor Create(const ExpectedAudience, ClaimsJson: string); + end; + + [TestFixture] + TAuthorizationTests = class + private + FIntrospection: TIdHTTPServer; + FSeenAuthorization: string; + FSeenBody: string; + procedure HandleIntrospection(Context: TIdContext; Request: TIdHTTPRequestInfo; Response: TIdHTTPResponseInfo); + function Decide(const Authorizer: IMCPAuthorizer; const Token: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + public + [TearDown] + procedure TearDown; + + [Test] procedure StaticBearer_AcceptsListedTokens_RejectsOthers; + [Test] procedure StaticBearer_NeedsAToken; + [Test] procedure ConstantTime_ComparesWholeToken; + [Test] procedure Principal_HasScope_HonoursWildcard; + [Test] procedure OAuth_RejectsWrongAudience_Expiry_AndScope; + [Test] procedure OAuth_AcceptsAudienceArray_AndScopeArray; + [Test] procedure OAuth_NeedsAnAudience; + [Test] procedure Challenge_Build_QuotesParameters; + [Test] procedure Metadata_Build_DropsOfflineAccess; + [Test] procedure Introspection_PostsTokenWithClientCredentials; + end; + +implementation + +uses + System.DateUtils; + +const + AUDIENCE = 'https://mcp.example/mcp'; + +{ TClaimsAuthorizer } + +constructor TClaimsAuthorizer.Create(const ExpectedAudience, ClaimsJson: string); +begin + inherited Create(ExpectedAudience); + FClaimsJson := ClaimsJson; +end; + +function TClaimsAuthorizer.ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; +begin + Claims := nil; + if Token <> 'valid' then + Exit(False); + Claims := TJSONObject.ParseJSONValue(FClaimsJson) as TJSONObject; + Result := True; +end; + +{ TAuthorizationTests } + +procedure TAuthorizationTests.TearDown; +begin + FIntrospection.Free; + FIntrospection := nil; +end; + +function TAuthorizationTests.Decide(const Authorizer: IMCPAuthorizer; const Token: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +begin + Result := Authorizer.Authorize(Token, 'POST', '/mcp', Principal, Challenge); +end; + +procedure TAuthorizationTests.StaticBearer_AcceptsListedTokens_RejectsOthers; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Authorizer: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha', ' beta ']); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'alpha', Principal, Challenge)); + Assert.AreEqual('token-1', Principal.Subject); + Assert.IsTrue(Principal.HasScope('anything'), 'pre-shared tokens grant every scope'); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'beta', Principal, Challenge)); + Assert.AreEqual('token-2', Principal.Subject); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, 'alph', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); + Assert.AreEqual('', Principal.Subject); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, '', Principal, Challenge)); + + var Scoped: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha'], ['read']); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Scoped, 'alpha', Principal, Challenge)); + Assert.IsTrue(Principal.HasScope('read')); + Assert.IsFalse(Principal.HasScope('write')); +end; + +procedure TAuthorizationTests.StaticBearer_NeedsAToken; +begin + Assert.WillRaise( + procedure + begin + TMCPStaticBearerAuthorizer.Create(['', ' ']).Free; + end, EMCPAuthorizationConfiguration); +end; + +procedure TAuthorizationTests.ConstantTime_ComparesWholeToken; +begin + Assert.IsTrue(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secret'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secret2'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secreT'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(nil, TEncoding.UTF8.GetBytes('x'))); + Assert.IsTrue(TMCPConstantTime.SameBytes(nil, nil)); +end; + +procedure TAuthorizationTests.Principal_HasScope_HonoursWildcard; +begin + var Principal := TMCPPrincipal.None; + Assert.IsFalse(Principal.HasScope('read')); + Principal.Scopes := ['read', 'files:write']; + Assert.IsTrue(Principal.HasScope('files:write')); + Assert.IsFalse(Principal.HasScope('admin')); + Principal.Scopes := ['*']; + Assert.IsTrue(Principal.HasScope('admin')); +end; + +procedure TAuthorizationTests.OAuth_RejectsWrongAudience_Expiry_AndScope; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Future := System.DateUtils.DateTimeToUnix(Now, False) + 600; + var Past := System.DateUtils.DateTimeToUnix(Now, False) - 600; + + var Invalid: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d}', [AUDIENCE, Future])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Invalid, 'nope', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); + + var WrongAudience: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"https://other","exp":%d}', [Future])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(WrongAudience, 'valid', Principal, Challenge)); + Assert.IsTrue(Challenge.ErrorDescription.Contains('not issued for this server'), Challenge.ErrorDescription); + + var Expired: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d}', [AUDIENCE, Past])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Expired, 'valid', Principal, Challenge)); + Assert.IsTrue(Challenge.ErrorDescription.Contains('expired'), Challenge.ErrorDescription); + + var NoExpiry: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s"}', [AUDIENCE])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(NoExpiry, 'valid', Principal, Challenge), 'exp is mandatory'); + + var Scoped := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d,"scope":"read"}', [AUDIENCE, Future])); + var ScopedRef: IMCPAuthorizer := Scoped; + Scoped.RequiredScopes := ['read', 'write']; + Assert.AreEqual(TMCPAuthDecision.Forbidden, Decide(ScopedRef, 'valid', Principal, Challenge)); + Assert.AreEqual('insufficient_scope', Challenge.Error); + Assert.AreEqual('read write', Challenge.Scope); + + Scoped.RequiredScopes := ['read']; + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(ScopedRef, 'valid', Principal, Challenge)); + Assert.AreEqual('u', Principal.Subject); + Assert.IsTrue(Principal.HasScope('read')); + Assert.IsFalse(Principal.HasScope('write')); +end; + +procedure TAuthorizationTests.OAuth_AcceptsAudienceArray_AndScopeArray; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Future := System.DateUtils.DateTimeToUnix(Now, False) + 600; + var Authorizer: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, + Format('{"sub":"u","aud":["https://other","%s"],"exp":%d,"scp":["a","b"]}', [AUDIENCE.ToUpper, Future])); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'valid', Principal, Challenge)); + Assert.IsTrue(Principal.HasScope('a')); + Assert.IsTrue(Principal.HasScope('b')); + Assert.IsFalse(Principal.HasScope('c')); +end; + +procedure TAuthorizationTests.OAuth_NeedsAnAudience; +begin + Assert.WillRaise( + procedure + begin + TClaimsAuthorizer.Create(' ', '{}').Free; + end, EMCPAuthorizationConfiguration); +end; + +procedure TAuthorizationTests.Challenge_Build_QuotesParameters; +begin + Assert.AreEqual('Bearer', TMCPBearerChallenge.Build('', TMCPAuthChallenge.None)); + Assert.AreEqual('Bearer resource_metadata="https://s/.well-known/oauth-protected-resource/mcp"', + TMCPBearerChallenge.Build('https://s/.well-known/oauth-protected-resource/mcp', TMCPAuthChallenge.None)); + Assert.AreEqual('Bearer error="invalid_token", error_description="say \"hi\""', + TMCPBearerChallenge.Build('', TMCPAuthChallenge.InvalidToken('say "hi"'))); + Assert.AreEqual('Bearer resource_metadata="https://s/m", error="insufficient_scope", scope="read write"', + TMCPBearerChallenge.Build('https://s/m', TMCPAuthChallenge.InsufficientScope('read write'))); + Assert.IsFalse(TMCPBearerChallenge.Build('', TMCPAuthChallenge.InvalidRequest('a'#13#10'b')).Contains(#10)); +end; + +procedure TAuthorizationTests.Metadata_Build_DropsOfflineAccess; +begin + var Metadata := TMCPProtectedResourceMetadata.Build('https://mcp.example/mcp', 'demo', + ['https://auth.example'], ['read', 'offline_access', 'write']); + try + Assert.AreEqual('https://mcp.example/mcp', Metadata.GetValue('resource')); + Assert.AreEqual('https://auth.example', Metadata.GetValue('authorization_servers[0]')); + Assert.AreEqual(2, (Metadata.GetValue('scopes_supported') as TJSONArray).Count); + Assert.AreEqual('header', Metadata.GetValue('bearer_methods_supported[0]')); + Assert.AreEqual('demo', Metadata.GetValue('resource_name')); + finally + Metadata.Free; + end; + + var Bare := TMCPProtectedResourceMetadata.Build('https://mcp.example/mcp', '', nil, nil); + try + Assert.AreEqual(0, (Bare.GetValue('authorization_servers') as TJSONArray).Count); + Assert.IsNull(Bare.GetValue('scopes_supported')); + Assert.IsNull(Bare.GetValue('resource_name')); + finally + Bare.Free; + end; +end; + +procedure TAuthorizationTests.HandleIntrospection(Context: TIdContext; Request: TIdHTTPRequestInfo; + Response: TIdHTTPResponseInfo); +begin + FSeenAuthorization := Request.RawHeaders.Values['Authorization']; + FSeenBody := Request.FormParams; + Response.ContentType := 'application/json'; + if FSeenBody.Contains('token=good') then + Response.ContentText := Format('{"active":true,"sub":"alice","aud":"%s","exp":%d,"scope":"read"}', + [AUDIENCE, System.DateUtils.DateTimeToUnix(Now, False) + 600]) + else + Response.ContentText := '{"active":false}'; +end; + +procedure TAuthorizationTests.Introspection_PostsTokenWithClientCredentials; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + FIntrospection := TIdHTTPServer.Create(nil); + FIntrospection.Bindings.Add.IP := '127.0.0.1'; + FIntrospection.Bindings[0].Port := 0; + FIntrospection.OnCommandGet := HandleIntrospection; + FIntrospection.Active := True; + var Url := Format('http://127.0.0.1:%d/introspect', [FIntrospection.Bindings[0].Port]); + + var Authorizer: IMCPAuthorizer := TMCPIntrospectionAuthorizer.Create(AUDIENCE, Url, 'mcp', 's3cret'); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'good', Principal, Challenge)); + Assert.AreEqual('alice', Principal.Subject); + Assert.IsTrue(Principal.HasScope('read')); + Assert.AreEqual('token=good', FSeenBody); + Assert.IsTrue(FSeenAuthorization.StartsWith('Basic '), FSeenAuthorization); + + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, 'stale', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); +end; + +end. diff --git a/tests/MCPServer.Tests.Cancellation.pas b/tests/MCPServer.Tests.Cancellation.pas new file mode 100644 index 0000000..525f6ce --- /dev/null +++ b/tests/MCPServer.Tests.Cancellation.pas @@ -0,0 +1,315 @@ +unit MCPServer.Tests.Cancellation; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.Tests.Harness; + +type + TRecordingSink = class(TInterfacedObject, IMCPMessageSink) + private + FMessages: TStrings; + public + constructor Create(Messages: TStrings); + procedure Send(const Json: string); + end; + + TCancellingTracker = class(TInterfacedObject, IMCPRequestTracker) + private + FCancelOnTrack: Boolean; + FCancelledIds: TStrings; + FReasons: TStrings; + public + constructor Create(CancelOnTrack: Boolean; CancelledIds, Reasons: TStrings); + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + end; + + [TestFixture] + TCancellationTests = class + private + FMessages: TStringList; + FSink: IMCPMessageSink; + function NewContext(const MetaJson: string): IMCPRequestContext; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Cancel_SetsIsCancelled_And_CheckRaises; + [Test] procedure Progress_WithoutToken_SendsNothing; + [Test] procedure Progress_NotificationShape; + [Test] procedure Progress_IntegerToken_IsKept; + [Test] procedure Progress_Monotonic_And_Throttled; + [Test] procedure Progress_AfterCancel_SendsNothing; + [Test] procedure Progress_WithoutSink_IsNoOp; + [Test] procedure Log_WithoutLogLevel_SendsNothing; + [Test] procedure Log_AtOrAboveLevel_HasNotificationShape; + [Test] procedure Log_AfterCancel_SendsNothing; + [Test] procedure Processor_CancelledRequest_HasNoResponse; + [Test] procedure Processor_CancelledNotification_ReachesTracker; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.JsonRpcProcessor; + +{ TRecordingSink } + +constructor TRecordingSink.Create(Messages: TStrings); +begin + inherited Create; + FMessages := Messages; +end; + +procedure TRecordingSink.Send(const Json: string); +begin + FMessages.Add(Json); +end; + +{ TCancellingTracker } + +constructor TCancellingTracker.Create(CancelOnTrack: Boolean; CancelledIds, Reasons: TStrings); +begin + inherited Create; + FCancelOnTrack := CancelOnTrack; + FCancelledIds := CancelledIds; + FReasons := Reasons; +end; + +procedure TCancellingTracker.Track(const Context: IMCPRequestContext); +begin + if FCancelOnTrack then + Context.Cancel; +end; + +procedure TCancellingTracker.Untrack(const Context: IMCPRequestContext); +begin +end; + +function TCancellingTracker.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +begin + FCancelledIds.Add(RequestId.AsText); + FReasons.Add(Reason); + Result := True; +end; + +{ TCancellationTests } + +procedure TCancellationTests.Setup; +begin + FMessages := TStringList.Create; + FSink := TRecordingSink.Create(FMessages); +end; + +procedure TCancellationTests.TearDown; +begin + FSink := nil; + FMessages.Free; +end; + +function TCancellationTests.NewContext(const MetaJson: string): IMCPRequestContext; +begin + var Meta: TJSONObject := nil; + if MetaJson <> '' then + Meta := TJSONObject.ParseJSONValue(MetaJson) as TJSONObject; + try + Result := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, 'tools/call', + TMCPRequestId.FromNumber(7), Meta, nil, nil, FSink); + finally + Meta.Free; + end; +end; + +procedure TCancellationTests.Cancel_SetsIsCancelled_And_CheckRaises; +begin + var Context := NewContext(''); + Assert.IsFalse(Context.IsCancelled); + Context.CheckCancelled; + Context.Cancel; + Assert.IsTrue(Context.IsCancelled); + var Check: TProc := procedure begin Context.CheckCancelled end; + Assert.WillRaise(Check, EMCPRequestCancelled); +end; + +procedure TCancellationTests.Progress_WithoutToken_SendsNothing; +begin + var Context := NewContext('{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}'); + Assert.IsFalse(Context.HasProgressToken); + Context.ReportProgress(1, 2, 'half'); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Progress_NotificationShape; +begin + var Context := NewContext('{"progressToken":"abc"}'); + Assert.IsTrue(Context.HasProgressToken); + Context.ReportProgress(1, 4, 'quarter'); + Assert.AreEqual(1, FMessages.Count); + var Json := TJSONObject.ParseJSONValue(FMessages[0]) as TJSONObject; + try + Assert.AreEqual('2.0', Json.GetValue('jsonrpc')); + Assert.AreEqual('notifications/progress', Json.GetValue('method')); + Assert.AreEqual('abc', Json.GetValue('params.progressToken')); + Assert.AreEqual(1.0, Json.GetValue('params.progress'), 0.0001); + Assert.AreEqual(4.0, Json.GetValue('params.total'), 0.0001); + Assert.AreEqual('quarter', Json.GetValue('params.message')); + Assert.IsNull(Json.GetValue('id')); + finally + Json.Free; + end; +end; + +procedure TCancellationTests.Progress_IntegerToken_IsKept; +begin + var Context := NewContext('{"progressToken":42}'); + Context.ReportProgress(0.5); + var Json := TJSONObject.ParseJSONValue(FMessages[0]) as TJSONObject; + try + Assert.AreEqual(42, Json.GetValue('params.progressToken')); + Assert.AreEqual(0.5, Json.GetValue('params.progress'), 0.0001); + Assert.IsNull(Json.FindValue('params.total'), 'unknown total is omitted'); + finally + Json.Free; + end; +end; + +procedure TCancellationTests.Progress_Monotonic_And_Throttled; +begin + var Context := NewContext('{"progressToken":"t"}'); + Context.ReportProgress(1, 10); + Context.ReportProgress(0.5, 10); + Assert.AreEqual(1, FMessages.Count, 'a smaller value is dropped'); + Context.ReportProgress(2, 10); + Assert.AreEqual(1, FMessages.Count, 'a burst within the interval is dropped'); + Context.ReportProgress(10, 10); + Assert.AreEqual(2, FMessages.Count, 'reaching the total is always sent'); + Sleep(PROGRESS_MIN_INTERVAL_MS + 20); + Context.ReportProgress(11); + Assert.AreEqual(3, FMessages.Count, 'after the interval the next value goes out'); +end; + +procedure TCancellationTests.Progress_AfterCancel_SendsNothing; +begin + var Context := NewContext('{"progressToken":"t"}'); + Context.Cancel; + Context.ReportProgress(1, 2); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Progress_WithoutSink_IsNoOp; +begin + var Meta := TJSONObject.ParseJSONValue('{"progressToken":"t"}') as TJSONObject; + try + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Legacy, + MCP_LATEST_LEGACY_PROTOCOL_VERSION, 'tools/call', TMCPRequestId.FromNumber(1), Meta, nil, nil); + Context.ReportProgress(1, 2); + Assert.IsTrue(Context.HasProgressToken); + finally + Meta.Free; + end; +end; + +procedure TCancellationTests.Log_WithoutLogLevel_SendsNothing; +begin + var Context := NewContext('{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}'); + Context.Log('error', 'nobody asked'); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Log_AtOrAboveLevel_HasNotificationShape; +begin + var Context := NewContext('{"io.modelcontextprotocol/logLevel":"warning"}'); + Context.Log('info', 'below the threshold'); + Context.Log('warning', 'at the threshold', 'db'); + Context.LogJson('error', TJSONObject.ParseJSONValue('{"code":7}')); + Context.Log('bogus', 'unknown level'); + Assert.AreEqual(2, FMessages.Count); + + var Json := TJSONObject.ParseJSONValue(FMessages[0]) as TJSONObject; + try + Assert.AreEqual('notifications/message', Json.GetValue('method')); + Assert.AreEqual('warning', Json.GetValue('params.level')); + Assert.AreEqual('db', Json.GetValue('params.logger')); + Assert.AreEqual('at the threshold', Json.GetValue('params.data')); + Assert.IsNull(Json.GetValue('id')); + finally + Json.Free; + end; + + var Structured := TJSONObject.ParseJSONValue(FMessages[1]) as TJSONObject; + try + Assert.AreEqual(7, Structured.GetValue('params.data.code')); + Assert.IsNull(Structured.FindValue('params.logger')); + finally + Structured.Free; + end; +end; + +procedure TCancellationTests.Log_AfterCancel_SendsNothing; +begin + var Context := NewContext('{"io.modelcontextprotocol/logLevel":"debug"}'); + Context.Cancel; + Context.Log('error', 'too late'); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Processor_CancelledRequest_HasNoResponse; +begin + var Harness := TMCPTestHarness.Create; + var Ids := TStringList.Create; + var Reasons := TStringList.Create; + var Processor := TMCPJsonRpcProcessor.Create(Harness.ManagerRegistry); + try + var Hints := TMCPTransportHints.ForStdio(nil, FSink, TCancellingTracker.Create(True, Ids, Reasons)); + var Outcome := Processor.ProcessRequestEx( + '{"jsonrpc":"2.0","id":9,"method":"tools/call","params":{"name":"echo","arguments":{"message":"x"}}}', Hints); + Assert.IsTrue(Outcome.Cancelled); + Assert.AreEqual('', Outcome.Body); + finally + Processor.Free; + Reasons.Free; + Ids.Free; + Harness.Free; + end; +end; + +procedure TCancellationTests.Processor_CancelledNotification_ReachesTracker; +begin + var Harness := TMCPTestHarness.Create; + var Ids := TStringList.Create; + var Reasons := TStringList.Create; + var Processor := TMCPJsonRpcProcessor.Create(Harness.ManagerRegistry); + try + var Hints := TMCPTransportHints.ForStdio(nil, FSink, TCancellingTracker.Create(False, Ids, Reasons)); + var Outcome := Processor.ProcessRequestEx( + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":5,"reason":"user"}}', Hints); + Assert.AreEqual('', Outcome.Body); + Assert.IsTrue(Outcome.IsNotification); + Assert.AreEqual(1, Ids.Count); + Assert.AreEqual('5', Ids[0]); + Assert.AreEqual('user', Reasons[0]); + + Outcome := Processor.ProcessRequestEx( + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":"abc"}}', Hints); + Assert.AreEqual('abc', Ids[1]); + Assert.AreEqual('', Reasons[1]); + finally + Processor.Free; + Reasons.Free; + Ids.Free; + Harness.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Capabilities.pas b/tests/MCPServer.Tests.Capabilities.pas new file mode 100644 index 0000000..84b6a60 --- /dev/null +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -0,0 +1,100 @@ +unit MCPServer.Tests.Capabilities; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TCapabilityBuilderTests = class + public + [Test] procedure Registry_YieldsAllManagersInRegistrationOrder; + [Test] procedure Registry_NeverEmitsLogging; + [Test] procedure RegistryWithoutEnumeration_YieldsDefaults; + end; + +implementation + +uses + System.SysUtils, + System.Generics.Collections, + System.JSON, + MCPServer.Types, + MCPServer.Capabilities, + MCPServer.Tests.Harness; + +type + TOpaqueRegistry = class(TInterfacedObject, IMCPManagerRegistry) + public + procedure RegisterManager(const Manager: IMCPCapabilityManager); + function GetManagerForMethod(const Method: string): IMCPCapabilityManager; + end; + +procedure TOpaqueRegistry.RegisterManager(const Manager: IMCPCapabilityManager); +begin +end; + +function TOpaqueRegistry.GetManagerForMethod(const Method: string): IMCPCapabilityManager; +begin + Result := nil; +end; + +{ TCapabilityBuilderTests } + +procedure TCapabilityBuilderTests.Registry_YieldsAllManagersInRegistrationOrder; +begin + var Harness := TMCPTestHarness.Create; + try + var Capabilities := TMCPCapabilityBuilder.Build(Harness.ManagerRegistry, TMCPProtocolEra.Modern); + try + Assert.AreEqual(4, Capabilities.Count); + Assert.AreEqual('tools', Capabilities.Pairs[0].JsonString.Value); + Assert.AreEqual('resources', Capabilities.Pairs[1].JsonString.Value); + Assert.AreEqual('prompts', Capabilities.Pairs[2].JsonString.Value); + Assert.AreEqual('completions', Capabilities.Pairs[3].JsonString.Value); + Assert.IsTrue(Capabilities.GetValue('tools.listChanged')); + Assert.IsTrue(Capabilities.GetValue('resources.subscribe')); + Assert.IsTrue(Capabilities.GetValue('resources.listChanged')); + Assert.IsTrue(Capabilities.GetValue('prompts.listChanged')); + Assert.IsTrue(Capabilities.GetValue('completions') is TJSONObject); + finally + Capabilities.Free; + end; + finally + Harness.Free; + end; +end; + +procedure TCapabilityBuilderTests.Registry_NeverEmitsLogging; +begin + var Harness := TMCPTestHarness.Create; + try + for var Era in [TMCPProtocolEra.Legacy, TMCPProtocolEra.Modern] do + begin + var Capabilities := TMCPCapabilityBuilder.Build(Harness.ManagerRegistry, Era); + try + Assert.IsNull(Capabilities.GetValue('logging')); + Assert.IsNull(Capabilities.GetValue('extensions')); + finally + Capabilities.Free; + end; + end; + finally + Harness.Free; + end; +end; + +procedure TCapabilityBuilderTests.RegistryWithoutEnumeration_YieldsDefaults; +begin + var Registry: IMCPManagerRegistry := TOpaqueRegistry.Create; + var Capabilities := TMCPCapabilityBuilder.Build(Registry, TMCPProtocolEra.Legacy); + try + Assert.IsNotNull(Capabilities.GetValue('tools')); + Assert.IsNotNull(Capabilities.GetValue('resources')); + finally + Capabilities.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.CompletionManager.pas b/tests/MCPServer.Tests.CompletionManager.pas new file mode 100644 index 0000000..bc8d16c --- /dev/null +++ b/tests/MCPServer.Tests.CompletionManager.pas @@ -0,0 +1,217 @@ +unit MCPServer.Tests.CompletionManager; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.Tests.Harness; + +type + [TestFixture] + TCompletionManagerTests = class + private + FHarness: TMCPTestHarness; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure RefPrompt_KnownArgument_ReturnsFilteredValues; + [Test] procedure RefPrompt_UnknownPrompt_IsInvalidParams; + [Test] procedure RefPrompt_MissingRefName_IsInvalidParams; + [Test] procedure RefResource_Template_Completes; + [Test] procedure RefResource_UnknownUri_IsNotFound; + [Test] procedure RefResource_UnknownUri_Legacy_IsLegacyNotFound; + [Test] procedure MissingArgument_IsInvalidParams; + [Test] procedure UnknownRefType_IsInvalidParams; + [Test] procedure CapabilitiesInclude_Completions; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors, + MCPServer.CompletionManager; + +{ TCompletionManagerTests } + +procedure TCompletionManagerTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TCompletionManagerTests.TearDown; +begin + FHarness.Free; +end; + +procedure TCompletionManagerTests.RefPrompt_KnownArgument_ReturnsFilteredValues; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt","name":"summarize_logs"},"argument":{"name":"level","value":"IN"}}') as TJSONObject; + try + var Json := Manager.Complete(Params, TMCPProtocolEra.Modern).AsType; + try + var Values := Json.FindValue('completion.values') as TJSONArray; + for var Value in Values do + Assert.IsTrue(Value.Value.ToUpper.StartsWith('IN'), 'every suggestion starts with the typed prefix'); + Assert.IsFalse(Json.GetValue('completion.hasMore')); + finally + Json.Free; + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefPrompt_UnknownPrompt_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt","name":"nope"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefPrompt_MissingRefName_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefResource_Template_Completes; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/resource","uri":"logs://{level}"},"argument":{"name":"level","value":""}}') as TJSONObject; + try + var Json := Manager.Complete(Params, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNotNull(Json.FindValue('completion.values')); + finally + Json.Free; + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefResource_UnknownUri_IsNotFound; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/resource","uri":"nope://missing"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefResource_UnknownUri_Legacy_IsLegacyNotFound; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/resource","uri":"nope://missing"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Legacy).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.MissingArgument_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue('{"ref":{"type":"ref/prompt","name":"summarize_logs"}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.UnknownRefType_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/bogus"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.CapabilitiesInclude_Completions; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Capabilities := TJSONObject.Create; + try + Manager.DescribeCapabilities(Capabilities, TMCPProtocolEra.Modern); + Assert.IsTrue(Capabilities.GetValue('completions') is TJSONObject); + finally + Capabilities.Free; + Manager.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Constants.pas b/tests/MCPServer.Tests.Constants.pas new file mode 100644 index 0000000..1c11c42 --- /dev/null +++ b/tests/MCPServer.Tests.Constants.pas @@ -0,0 +1,111 @@ +unit MCPServer.Tests.Constants; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TProtocolConstantsTests = class + public + [Test] procedure JsonRpcErrorCodes_HaveSpecValues; + [Test] procedure ProcessorAliases_MatchTypes; + [Test] procedure McpErrorCodes_HaveSpecValues; + [Test] procedure ProtocolVersions_AreConsistent; + [Test] procedure MetaKeys_UseReservedPrefix; + [Test] procedure CacheableMethods_MatchSpec; + [Test] procedure IsJsonString_AcceptsStringsOnly; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Types, + MCPServer.JsonRpcProcessor; + +{ TProtocolConstantsTests } + +procedure TProtocolConstantsTests.JsonRpcErrorCodes_HaveSpecValues; +begin + Assert.AreEqual(-32700, MCPServer.Types.JSONRPC_PARSE_ERROR); + Assert.AreEqual(-32600, MCPServer.Types.JSONRPC_INVALID_REQUEST); + Assert.AreEqual(-32601, MCPServer.Types.JSONRPC_METHOD_NOT_FOUND); + Assert.AreEqual(-32602, MCPServer.Types.JSONRPC_INVALID_PARAMS); + Assert.AreEqual(-32603, MCPServer.Types.JSONRPC_INTERNAL_ERROR); +end; + +procedure TProtocolConstantsTests.ProcessorAliases_MatchTypes; +begin + Assert.AreEqual(MCPServer.Types.JSONRPC_PARSE_ERROR, MCPServer.JsonRpcProcessor.JSONRPC_PARSE_ERROR); + Assert.AreEqual(MCPServer.Types.JSONRPC_INVALID_REQUEST, MCPServer.JsonRpcProcessor.JSONRPC_INVALID_REQUEST); + Assert.AreEqual(MCPServer.Types.JSONRPC_METHOD_NOT_FOUND, MCPServer.JsonRpcProcessor.JSONRPC_METHOD_NOT_FOUND); + Assert.AreEqual(MCPServer.Types.JSONRPC_INVALID_PARAMS, MCPServer.JsonRpcProcessor.JSONRPC_INVALID_PARAMS); + Assert.AreEqual(MCPServer.Types.JSONRPC_INTERNAL_ERROR, MCPServer.JsonRpcProcessor.JSONRPC_INTERNAL_ERROR); +end; + +procedure TProtocolConstantsTests.McpErrorCodes_HaveSpecValues; +begin + Assert.AreEqual(-32020, MCP_ERROR_HEADER_MISMATCH); + Assert.AreEqual(-32021, MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY); + Assert.AreEqual(-32022, MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION); + Assert.AreEqual(-32002, MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY); +end; + +procedure TProtocolConstantsTests.ProtocolVersions_AreConsistent; +begin + Assert.AreEqual('2025-06-18', MCP_PROTOCOL_VERSION, 'the initialize handshake answers this revision'); + Assert.AreEqual('2026-07-28', MCP_LATEST_PROTOCOL_VERSION); + Assert.AreEqual('2025-11-25', MCP_LATEST_LEGACY_PROTOCOL_VERSION); + + Assert.AreEqual(2, Length(MCP_LEGACY_PROTOCOL_VERSIONS)); + Assert.AreEqual(MCP_PROTOCOL_VERSION_2025_11_25, MCP_LEGACY_PROTOCOL_VERSIONS[0]); + Assert.AreEqual(MCP_PROTOCOL_VERSION_2025_06_18, MCP_LEGACY_PROTOCOL_VERSIONS[1]); + + Assert.AreEqual(1, Length(MCP_MODERN_PROTOCOL_VERSIONS)); + Assert.AreEqual(MCP_LATEST_PROTOCOL_VERSION, MCP_MODERN_PROTOCOL_VERSIONS[0]); +end; + +procedure TProtocolConstantsTests.MetaKeys_UseReservedPrefix; +const + RESERVED_PREFIX = 'io.modelcontextprotocol/'; +begin + Assert.IsTrue(MCP_META_PROTOCOL_VERSION.StartsWith(RESERVED_PREFIX)); + Assert.IsTrue(MCP_META_CLIENT_CAPABILITIES.StartsWith(RESERVED_PREFIX)); + Assert.IsTrue(MCP_META_CLIENT_INFO.StartsWith(RESERVED_PREFIX)); + Assert.IsTrue(MCP_META_LOG_LEVEL.StartsWith(RESERVED_PREFIX)); + Assert.IsTrue(MCP_META_SERVER_INFO.StartsWith(RESERVED_PREFIX)); + Assert.IsTrue(MCP_META_SUBSCRIPTION_ID.StartsWith(RESERVED_PREFIX)); + Assert.AreEqual('progressToken', MCP_META_PROGRESS_TOKEN); +end; + +procedure TProtocolConstantsTests.CacheableMethods_MatchSpec; +begin + Assert.AreEqual(6, Length(MCP_CACHEABLE_METHODS)); + Assert.AreEqual('server/discover', MCP_CACHEABLE_METHODS[0]); + Assert.AreEqual('tools/list', MCP_CACHEABLE_METHODS[1]); + Assert.AreEqual('prompts/list', MCP_CACHEABLE_METHODS[2]); + Assert.AreEqual('resources/list', MCP_CACHEABLE_METHODS[3]); + Assert.AreEqual('resources/templates/list', MCP_CACHEABLE_METHODS[4]); + Assert.AreEqual('resources/read', MCP_CACHEABLE_METHODS[5]); +end; + +procedure TProtocolConstantsTests.IsJsonString_AcceptsStringsOnly; +begin + var Json := TJSONObject.ParseJSONValue('{"s":"text","n":12345,"f":1.5,"b":true,"o":{},"z":null}') as TJSONObject; + try + Assert.IsTrue(IsJsonString(Json.GetValue('s'))); + Assert.IsFalse(IsJsonString(Json.GetValue('n')), 'a number is not a string'); + Assert.IsFalse(IsJsonString(Json.GetValue('f'))); + Assert.IsFalse(IsJsonString(Json.GetValue('b'))); + Assert.IsFalse(IsJsonString(Json.GetValue('o'))); + Assert.IsFalse(IsJsonString(Json.GetValue('z'))); + Assert.IsFalse(IsJsonString(nil)); + finally + Json.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Golden.Legacy.pas b/tests/MCPServer.Tests.Golden.Legacy.pas new file mode 100644 index 0000000..7f80022 --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -0,0 +1,281 @@ +unit MCPServer.Tests.Golden.Legacy; + +interface + +uses + DUnitX.TestFramework, + MCPServer.Tests.Harness, + MCPServer.Tests.Golden; + +type + [TestFixture] + TLegacyGoldenTests = class + private + FHarness: TMCPTestHarness; + procedure CheckGolden(const CaseName: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Initialize_2025_06_18; + [Test] procedure Initialize_2025_11_25; + [Test] procedure Initialize_2025_03_26; + [Test] procedure Initialize_UnknownVersion; + [Test] procedure Initialize_WithoutParams; + [Test] procedure Notifications_Initialized; + [Test] procedure Ping; + + [Test] procedure Tools_List; + [Test] procedure Tools_Call_Echo; + [Test] procedure Tools_Call_Echo_Unicode; + [Test] procedure Tools_Call_Calculate; + [Test] procedure Tools_Call_Calculate_DivideByZero; + [Test] procedure Tools_Call_GetTime; + [Test] procedure Tools_Call_ListFiles; + [Test] procedure Tools_Call_ListFiles_OutsideAllowedDirectory; + [Test] procedure Tools_Call_MissingArguments; + [Test] procedure Tools_Call_UnknownTool; + [Test] procedure Tools_Call_InvalidArgumentType; + [Test] procedure Tools_Call_WithoutParams; + [Test] procedure Tools_Call_EmptyName; + + [Test] procedure Resources_List; + [Test] procedure Resources_Read_ProjectInfo; + [Test] procedure Resources_Read_ProjectReadme; + [Test] procedure Resources_Read_LogsRecent; + [Test] procedure Resources_Read_ServerStatus; + [Test] procedure Resources_Read_UnknownUri; + [Test] procedure Resources_Read_WithoutParams; + [Test] procedure Resources_Templates_List; + + [Test] procedure UnknownMethod; + [Test] procedure ServerDiscover_WithoutMeta; + [Test] procedure ParseError; + [Test] procedure EmptyBody; + [Test] procedure RequestNotAnObject; + [Test] procedure Id_Null; + [Test] procedure Id_String; + [Test] procedure MissingJsonRpcField; + [Test] procedure MissingMethod; + [Test] procedure ParamsNotAnObject; + end; + +implementation + +uses + System.SysUtils; + +{ TLegacyGoldenTests } + +procedure TLegacyGoldenTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TLegacyGoldenTests.TearDown; +begin + FreeAndNil(FHarness); +end; + +procedure TLegacyGoldenTests.CheckGolden(const CaseName: string); +begin + TGoldenRunner.Check(TGoldenFiles.LEGACY_SUITE, CaseName, + function(const RequestBody: string): string + begin + Result := FHarness.Process(RequestBody); + end); +end; + +procedure TLegacyGoldenTests.Initialize_2025_06_18; +begin + CheckGolden('initialize-2025-06-18'); +end; + +procedure TLegacyGoldenTests.Initialize_2025_11_25; +begin + CheckGolden('initialize-2025-11-25'); +end; + +procedure TLegacyGoldenTests.Initialize_2025_03_26; +begin + CheckGolden('initialize-2025-03-26'); +end; + +procedure TLegacyGoldenTests.Initialize_UnknownVersion; +begin + CheckGolden('initialize-unknown-version'); +end; + +procedure TLegacyGoldenTests.Initialize_WithoutParams; +begin + CheckGolden('initialize-without-params'); +end; + +procedure TLegacyGoldenTests.Notifications_Initialized; +begin + CheckGolden('notifications-initialized'); +end; + +procedure TLegacyGoldenTests.Ping; +begin + CheckGolden('ping'); +end; + +procedure TLegacyGoldenTests.Tools_List; +begin + CheckGolden('tools-list'); +end; + +procedure TLegacyGoldenTests.Tools_Call_Echo; +begin + CheckGolden('tools-call-echo'); +end; + +procedure TLegacyGoldenTests.Tools_Call_Echo_Unicode; +begin + CheckGolden('tools-call-echo-unicode'); +end; + +procedure TLegacyGoldenTests.Tools_Call_Calculate; +begin + CheckGolden('tools-call-calculate'); +end; + +procedure TLegacyGoldenTests.Tools_Call_Calculate_DivideByZero; +begin + CheckGolden('tools-call-calculate-divide-by-zero'); +end; + +procedure TLegacyGoldenTests.Tools_Call_GetTime; +begin + CheckGolden('tools-call-get-time'); +end; + +procedure TLegacyGoldenTests.Tools_Call_ListFiles; +begin + CheckGolden('tools-call-list-files'); +end; + +procedure TLegacyGoldenTests.Tools_Call_ListFiles_OutsideAllowedDirectory; +begin + CheckGolden('tools-call-list-files-outside-allowed-directory'); +end; + +procedure TLegacyGoldenTests.Tools_Call_MissingArguments; +begin + CheckGolden('tools-call-missing-arguments'); +end; + +procedure TLegacyGoldenTests.Tools_Call_UnknownTool; +begin + CheckGolden('tools-call-unknown-tool'); +end; + +procedure TLegacyGoldenTests.Tools_Call_InvalidArgumentType; +begin + CheckGolden('tools-call-invalid-argument-type'); +end; + +procedure TLegacyGoldenTests.Tools_Call_WithoutParams; +begin + CheckGolden('tools-call-without-params'); +end; + +procedure TLegacyGoldenTests.Tools_Call_EmptyName; +begin + CheckGolden('tools-call-empty-name'); +end; + +procedure TLegacyGoldenTests.Resources_List; +begin + CheckGolden('resources-list'); +end; + +procedure TLegacyGoldenTests.Resources_Read_ProjectInfo; +begin + CheckGolden('resources-read-project-info'); +end; + +procedure TLegacyGoldenTests.Resources_Read_ProjectReadme; +begin + CheckGolden('resources-read-project-readme'); +end; + +procedure TLegacyGoldenTests.Resources_Read_LogsRecent; +begin + CheckGolden('resources-read-logs-recent'); +end; + +procedure TLegacyGoldenTests.Resources_Read_ServerStatus; +begin + CheckGolden('resources-read-server-status'); +end; + +procedure TLegacyGoldenTests.Resources_Read_UnknownUri; +begin + CheckGolden('resources-read-unknown-uri'); +end; + +procedure TLegacyGoldenTests.Resources_Read_WithoutParams; +begin + CheckGolden('resources-read-without-params'); +end; + +procedure TLegacyGoldenTests.Resources_Templates_List; +begin + CheckGolden('resources-templates-list'); +end; + +procedure TLegacyGoldenTests.UnknownMethod; +begin + CheckGolden('unknown-method'); +end; + +procedure TLegacyGoldenTests.ServerDiscover_WithoutMeta; +begin + CheckGolden('server-discover-without-meta'); +end; + +procedure TLegacyGoldenTests.ParseError; +begin + CheckGolden('parse-error'); +end; + +procedure TLegacyGoldenTests.EmptyBody; +begin + CheckGolden('empty-body'); +end; + +procedure TLegacyGoldenTests.RequestNotAnObject; +begin + CheckGolden('request-not-an-object'); +end; + +procedure TLegacyGoldenTests.Id_Null; +begin + CheckGolden('id-null'); +end; + +procedure TLegacyGoldenTests.Id_String; +begin + CheckGolden('id-string'); +end; + +procedure TLegacyGoldenTests.MissingJsonRpcField; +begin + CheckGolden('missing-jsonrpc-field'); +end; + +procedure TLegacyGoldenTests.MissingMethod; +begin + CheckGolden('missing-method'); +end; + +procedure TLegacyGoldenTests.ParamsNotAnObject; +begin + CheckGolden('params-not-an-object'); +end; + +end. diff --git a/tests/MCPServer.Tests.Golden.Modern.pas b/tests/MCPServer.Tests.Golden.Modern.pas new file mode 100644 index 0000000..d0e6a99 --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Modern.pas @@ -0,0 +1,157 @@ +unit MCPServer.Tests.Golden.Modern; + +interface + +uses + DUnitX.TestFramework, + MCPServer.Tests.Harness, + MCPServer.Tests.Golden; + +type + [TestFixture] + TModernGoldenTests = class + private + FHarness: TMCPTestHarness; + procedure CheckGolden(const CaseName: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Server_Discover; + [Test] procedure Server_Discover_AfterInitialize; + [Test] procedure Server_Discover_WithoutMeta; + [Test] procedure Tools_List; + [Test] procedure Tools_Call_Echo; + [Test] procedure Tools_Call_UnknownTool; + [Test] procedure Resources_List; + [Test] procedure Resources_Read_ProjectInfo; + [Test] procedure Resources_Templates_List; + [Test] procedure Ping_IsNotFound; + [Test] procedure UnknownMethod; + [Test] procedure UnknownProtocolVersion; + [Test] procedure MissingClientCapabilities; + [Test] procedure InvalidLogLevel; + [Test] procedure Initialize_WithModernMeta_IsNotFound; + [Test] procedure Id_Null; + [Test] procedure MissingJsonRpcField; + end; + +implementation + +uses + System.SysUtils; + +const + INITIALIZE_REQUEST = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18",' + + '"capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0.0"}}}'; + +{ TModernGoldenTests } + +procedure TModernGoldenTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TModernGoldenTests.TearDown; +begin + FreeAndNil(FHarness); +end; + +procedure TModernGoldenTests.CheckGolden(const CaseName: string); +begin + TGoldenRunner.Check(TGoldenFiles.MODERN_SUITE, CaseName, + function(const RequestBody: string): string + begin + Result := FHarness.Process(RequestBody); + end); +end; + +procedure TModernGoldenTests.Server_Discover; +begin + CheckGolden('server-discover'); +end; + +procedure TModernGoldenTests.Server_Discover_AfterInitialize; +begin + FHarness.Process(INITIALIZE_REQUEST); + CheckGolden('server-discover'); +end; + +procedure TModernGoldenTests.Server_Discover_WithoutMeta; +begin + CheckGolden('server-discover-without-meta'); +end; + +procedure TModernGoldenTests.Tools_List; +begin + CheckGolden('tools-list'); +end; + +procedure TModernGoldenTests.Tools_Call_Echo; +begin + CheckGolden('tools-call-echo'); +end; + +procedure TModernGoldenTests.Tools_Call_UnknownTool; +begin + CheckGolden('tools-call-unknown-tool'); +end; + +procedure TModernGoldenTests.Resources_List; +begin + CheckGolden('resources-list'); +end; + +procedure TModernGoldenTests.Resources_Read_ProjectInfo; +begin + CheckGolden('resources-read-project-info'); +end; + +procedure TModernGoldenTests.Resources_Templates_List; +begin + CheckGolden('resources-templates-list'); +end; + +procedure TModernGoldenTests.Ping_IsNotFound; +begin + CheckGolden('ping'); +end; + +procedure TModernGoldenTests.UnknownMethod; +begin + CheckGolden('unknown-method'); +end; + +procedure TModernGoldenTests.UnknownProtocolVersion; +begin + CheckGolden('unknown-protocol-version'); +end; + +procedure TModernGoldenTests.MissingClientCapabilities; +begin + CheckGolden('missing-client-capabilities'); +end; + +procedure TModernGoldenTests.InvalidLogLevel; +begin + CheckGolden('invalid-log-level'); +end; + +procedure TModernGoldenTests.Initialize_WithModernMeta_IsNotFound; +begin + CheckGolden('initialize-with-modern-meta'); +end; + +procedure TModernGoldenTests.Id_Null; +begin + CheckGolden('id-null'); +end; + +procedure TModernGoldenTests.MissingJsonRpcField; +begin + CheckGolden('missing-jsonrpc-field'); +end; + +end. diff --git a/tests/MCPServer.Tests.Golden.pas b/tests/MCPServer.Tests.Golden.pas new file mode 100644 index 0000000..a4b767e --- /dev/null +++ b/tests/MCPServer.Tests.Golden.pas @@ -0,0 +1,417 @@ +unit MCPServer.Tests.Golden; + +interface + +uses + System.SysUtils, + System.Classes, + System.Generics.Collections, + System.JSON; + +type + EGoldenError = class(Exception); + + TGoldenFiles = class + public + const RECORD_ENVIRONMENT_VARIABLE = 'MCP_GOLDEN_RECORD'; + const GOLDEN_DIR_ENVIRONMENT_VARIABLE = 'MCP_GOLDEN_DIR'; + const GOLDEN_DIRECTORY_NAME = 'golden'; + const LEGACY_SUITE = 'legacy'; + const MODERN_SUITE = 'modern'; + + class function GoldenRoot: string; + class function TestsRoot: string; + class function CaseFile(const Suite, CaseName: string): string; + class function RecordMode: Boolean; + end; + + TGoldenNormalizer = class + private + class function ReplaceIndexes(const Segment: string): string; + class function SegmentMatches(const Segment, Pattern: string): Boolean; + class function ShapeOfString(const Value: string): TJSONValue; + class procedure NormalizeObject(const Obj: TJSONObject; const Path: string; + const MaskPaths, ShapePaths: TArray); + class procedure NormalizeArray(const Arr: TJSONArray; const Path: string; + const MaskPaths, ShapePaths: TArray); + public + const MASK_PLACEHOLDER = ''; + + class function PathMatches(const Path, Pattern: string): Boolean; + class function MatchesAny(const Path: string; const Patterns: TArray): Boolean; + class function Shape(const Value: TJSONValue): TJSONValue; + class procedure Normalize(const Root: TJSONValue; const MaskPaths, ShapePaths: TArray); + end; + + TGoldenCase = class + private + FFileName: string; + FDocument: TJSONObject; + function ReadStringArray(const Name: string): TArray; + function GetRequestBody: string; + function GetWorkingDirectory: string; + function GetHasExpected: Boolean; + procedure RemoveExpected; + procedure Save; + public + const INDENTATION = 2; + + constructor Create(const AFileName: string); + destructor Destroy; override; + + function NormalizeResponse(const ResponseBody: string): string; + function ExpectedText: string; + procedure RecordExpected(const ResponseBody: string); + + property FileName: string read FFileName; + property RequestBody: string read GetRequestBody; + property WorkingDirectory: string read GetWorkingDirectory; + property HasExpected: Boolean read GetHasExpected; + end; + + TGoldenProcessFunc = reference to function(const RequestBody: string): string; + + TGoldenRunner = class + public + class procedure Check(const Suite, CaseName: string; const Process: TGoldenProcessFunc); + end; + +implementation + +uses + System.IOUtils; + +const + MAX_PARENT_LEVELS = 6; + +{ TGoldenFiles } + +class function TGoldenFiles.GoldenRoot: string; +begin + Result := GetEnvironmentVariable(GOLDEN_DIR_ENVIRONMENT_VARIABLE); + if Result <> '' then + Exit(TPath.GetFullPath(Result)); + + var Dir := ExtractFilePath(ParamStr(0)); + for var Level := 0 to MAX_PARENT_LEVELS do + begin + var Candidate := TPath.Combine(Dir, GOLDEN_DIRECTORY_NAME); + if TDirectory.Exists(TPath.Combine(Candidate, LEGACY_SUITE)) then + Exit(Candidate); + Dir := TPath.GetFullPath(TPath.Combine(Dir, '..')); + end; + + raise EGoldenError.CreateFmt('Golden directory not found above %s (set %s)', + [ExtractFilePath(ParamStr(0)), GOLDEN_DIR_ENVIRONMENT_VARIABLE]); +end; + +class function TGoldenFiles.TestsRoot: string; +begin + Result := TPath.GetFullPath(TPath.Combine(GoldenRoot, '..')); +end; + +class function TGoldenFiles.CaseFile(const Suite, CaseName: string): string; +begin + Result := TPath.Combine(TPath.Combine(GoldenRoot, Suite), CaseName + '.json'); +end; + +class function TGoldenFiles.RecordMode: Boolean; +begin + Result := GetEnvironmentVariable(RECORD_ENVIRONMENT_VARIABLE) = '1'; +end; + +{ TGoldenNormalizer } + +class function TGoldenNormalizer.ReplaceIndexes(const Segment: string): string; +begin + Result := ''; + var I := 1; + while I <= Length(Segment) do + begin + if Segment[I] = '[' then + begin + Result := Result + '[*'; + Inc(I); + while (I <= Length(Segment)) and CharInSet(Segment[I], ['0'..'9']) do + Inc(I); + end + else + begin + Result := Result + Segment[I]; + Inc(I); + end; + end; +end; + +class function TGoldenNormalizer.SegmentMatches(const Segment, Pattern: string): Boolean; +begin + Result := Segment = Pattern; + if (not Result) and Pattern.Contains('[*]') then + Result := ReplaceIndexes(Segment) = Pattern; +end; + +class function TGoldenNormalizer.PathMatches(const Path, Pattern: string): Boolean; +begin + var PathParts := Path.Split(['.']); + var PatternParts := Pattern.Split(['.']); + if Length(PathParts) <> Length(PatternParts) then + Exit(False); + + for var I := 0 to High(PathParts) do + if not SegmentMatches(PathParts[I], PatternParts[I]) then + Exit(False); + + Result := True; +end; + +class function TGoldenNormalizer.MatchesAny(const Path: string; const Patterns: TArray): Boolean; +begin + for var Pattern in Patterns do + if PathMatches(Path, Pattern) then + Exit(True); + Result := False; +end; + +class function TGoldenNormalizer.ShapeOfString(const Value: string): TJSONValue; +begin + var Parsed := TJSONObject.ParseJSONValue(Value); + try + if (Parsed is TJSONObject) or (Parsed is TJSONArray) then + Result := Shape(Parsed) + else + Result := TJSONString.Create('string'); + finally + Parsed.Free; + end; +end; + +class function TGoldenNormalizer.Shape(const Value: TJSONValue): TJSONValue; +begin + if Value is TJSONObject then + begin + var Obj := TJSONObject.Create; + for var Pair in TJSONObject(Value) do + Obj.AddPair(Pair.JsonString.Value, Shape(Pair.JsonValue)); + Result := Obj; + end + else if Value is TJSONArray then + begin + var Arr := TJSONArray.Create; + for var Item in TJSONArray(Value) do + Arr.AddElement(Shape(Item)); + Result := Arr; + end + else if Value is TJSONNull then + Result := TJSONString.Create('null') + else if Value is TJSONBool then + Result := TJSONString.Create('boolean') + else if Value is TJSONNumber then + Result := TJSONString.Create('number') + else if Value is TJSONString then + Result := ShapeOfString(TJSONString(Value).Value) + else + Result := TJSONString.Create(Value.ClassName); +end; + +class procedure TGoldenNormalizer.NormalizeObject(const Obj: TJSONObject; const Path: string; + const MaskPaths, ShapePaths: TArray); +begin + for var Pair in Obj do + begin + var ChildPath := Pair.JsonString.Value; + if Path <> '' then + ChildPath := Path + '.' + ChildPath; + + if MatchesAny(ChildPath, MaskPaths) then + Pair.JsonValue := TJSONString.Create(MASK_PLACEHOLDER) + else if MatchesAny(ChildPath, ShapePaths) then + Pair.JsonValue := Shape(Pair.JsonValue) + else if Pair.JsonValue is TJSONObject then + NormalizeObject(TJSONObject(Pair.JsonValue), ChildPath, MaskPaths, ShapePaths) + else if Pair.JsonValue is TJSONArray then + NormalizeArray(TJSONArray(Pair.JsonValue), ChildPath, MaskPaths, ShapePaths); + end; +end; + +class procedure TGoldenNormalizer.NormalizeArray(const Arr: TJSONArray; const Path: string; + const MaskPaths, ShapePaths: TArray); +begin + for var I := 0 to Arr.Count - 1 do + begin + var ChildPath := Path + '[' + I.ToString + ']'; + var Item := Arr.Items[I]; + if Item is TJSONObject then + NormalizeObject(TJSONObject(Item), ChildPath, MaskPaths, ShapePaths) + else if Item is TJSONArray then + NormalizeArray(TJSONArray(Item), ChildPath, MaskPaths, ShapePaths); + end; +end; + +class procedure TGoldenNormalizer.Normalize(const Root: TJSONValue; const MaskPaths, ShapePaths: TArray); +begin + if Root is TJSONObject then + NormalizeObject(TJSONObject(Root), '', MaskPaths, ShapePaths) + else if Root is TJSONArray then + NormalizeArray(TJSONArray(Root), '', MaskPaths, ShapePaths); +end; + +{ TGoldenCase } + +constructor TGoldenCase.Create(const AFileName: string); +begin + inherited Create; + FFileName := AFileName; + + if not TFile.Exists(FFileName) then + raise EGoldenError.CreateFmt('Golden file not found: %s', [FFileName]); + + var Parsed := TJSONObject.ParseJSONValue(TFile.ReadAllText(FFileName, TEncoding.UTF8)); + if not (Parsed is TJSONObject) then + begin + Parsed.Free; + raise EGoldenError.CreateFmt('Golden file is not a JSON object: %s', [FFileName]); + end; + FDocument := TJSONObject(Parsed); +end; + +destructor TGoldenCase.Destroy; +begin + FDocument.Free; + inherited; +end; + +function TGoldenCase.ReadStringArray(const Name: string): TArray; +begin + Result := nil; + var Value := FDocument.GetValue(Name); + if not (Value is TJSONArray) then + Exit; + + var Arr := TJSONArray(Value); + SetLength(Result, Arr.Count); + for var I := 0 to Arr.Count - 1 do + Result[I] := Arr.Items[I].Value; +end; + +function TGoldenCase.GetRequestBody: string; +begin + var Request := FDocument.GetValue('request'); + if Assigned(Request) then + Exit(Request.ToJSON); + + var RequestText := FDocument.GetValue('requestText'); + if Assigned(RequestText) then + Exit(RequestText.Value); + + raise EGoldenError.CreateFmt('Golden file has neither "request" nor "requestText": %s', [FFileName]); +end; + +function TGoldenCase.GetWorkingDirectory: string; +begin + var Value := FDocument.GetValue('workingDirectory'); + if Assigned(Value) and (Value.Value <> '') then + Result := TPath.GetFullPath(TPath.Combine(TGoldenFiles.TestsRoot, Value.Value)) + else + Result := ''; +end; + +function TGoldenCase.GetHasExpected: Boolean; +begin + Result := Assigned(FDocument.GetValue('expected')) or Assigned(FDocument.GetValue('expectedText')); +end; + +function TGoldenCase.NormalizeResponse(const ResponseBody: string): string; +begin + if ResponseBody.Trim = '' then + Exit(ResponseBody); + + var Parsed := TJSONObject.ParseJSONValue(ResponseBody); + if not Assigned(Parsed) then + Exit(ResponseBody); + + try + TGoldenNormalizer.Normalize(Parsed, ReadStringArray('mask'), ReadStringArray('shape')); + Result := Parsed.Format(INDENTATION); + finally + Parsed.Free; + end; +end; + +function TGoldenCase.ExpectedText: string; +begin + var Expected := FDocument.GetValue('expected'); + if Assigned(Expected) then + Exit(Expected.Format(INDENTATION)); + + var ExpectedText := FDocument.GetValue('expectedText'); + if Assigned(ExpectedText) then + Exit(ExpectedText.Value); + + raise EGoldenError.CreateFmt('No expectation recorded in %s (run once with %s=1)', + [FFileName, TGoldenFiles.RECORD_ENVIRONMENT_VARIABLE]); +end; + +procedure TGoldenCase.RemoveExpected; +begin + FDocument.RemovePair('expected').Free; + FDocument.RemovePair('expectedText').Free; +end; + +procedure TGoldenCase.RecordExpected(const ResponseBody: string); +begin + RemoveExpected; + + var Parsed: TJSONValue := nil; + if ResponseBody.Trim <> '' then + Parsed := TJSONObject.ParseJSONValue(ResponseBody); + + if Assigned(Parsed) then + begin + TGoldenNormalizer.Normalize(Parsed, ReadStringArray('mask'), ReadStringArray('shape')); + FDocument.AddPair('expected', Parsed); + end + else + FDocument.AddPair('expectedText', ResponseBody); + + Save; +end; + +procedure TGoldenCase.Save; +begin + var Text := FDocument.Format(INDENTATION) + sLineBreak; + TFile.WriteAllBytes(FFileName, TEncoding.UTF8.GetBytes(Text)); +end; + +{ TGoldenRunner } + +class procedure TGoldenRunner.Check(const Suite, CaseName: string; const Process: TGoldenProcessFunc); +begin + var GoldenCase := TGoldenCase.Create(TGoldenFiles.CaseFile(Suite, CaseName)); + try + var Response: string; + var SavedDirectory := GetCurrentDir; + if GoldenCase.WorkingDirectory <> '' then + SetCurrentDir(GoldenCase.WorkingDirectory); + try + Response := Process(GoldenCase.RequestBody); + finally + SetCurrentDir(SavedDirectory); + end; + + if TGoldenFiles.RecordMode then + begin + GoldenCase.RecordExpected(Response); + Exit; + end; + + var Expected := GoldenCase.ExpectedText; + var Actual := GoldenCase.NormalizeResponse(Response); + if Expected <> Actual then + raise EGoldenError.CreateFmt('Golden mismatch for %s/%s'#13#10'--- expected ---'#13#10'%s'#13#10'--- actual ---'#13#10'%s', + [Suite, CaseName, Expected, Actual]); + finally + GoldenCase.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Harness.pas b/tests/MCPServer.Tests.Harness.pas new file mode 100644 index 0000000..e9d9bee --- /dev/null +++ b/tests/MCPServer.Tests.Harness.pas @@ -0,0 +1,90 @@ +unit MCPServer.Tests.Harness; + +interface + +uses + System.SysUtils, + MCPServer.Types, + MCPServer.Settings, + MCPServer.ToolsManager, + MCPServer.ResourcesManager, + MCPServer.PromptsManager, + MCPServer.SubscriptionsManager, + MCPServer.JsonRpcProcessor; + +type + TMCPTestHarness = class + private + FSettings: TMCPSettings; + FManagerRegistry: IMCPManagerRegistry; + FCoreManager: IMCPCapabilityManager; + FToolsManager: TMCPToolsManager; + FResourcesManager: TMCPResourcesManager; + FPromptsManager: TMCPPromptsManager; + FSubscriptionsManager: TMCPSubscriptionsManager; + FProcessor: TMCPJsonRpcProcessor; + public + constructor Create; + destructor Destroy; override; + + function Process(const RequestBody: string): string; + + property Settings: TMCPSettings read FSettings; + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; + property CoreManager: IMCPCapabilityManager read FCoreManager; + property ToolsManager: TMCPToolsManager read FToolsManager; + property ResourcesManager: TMCPResourcesManager read FResourcesManager; + property PromptsManager: TMCPPromptsManager read FPromptsManager; + property SubscriptionsManager: TMCPSubscriptionsManager read FSubscriptionsManager; + end; + +implementation + +uses + MCPServer.ManagerRegistry, + MCPServer.CoreManager, + MCPServer.CompletionManager; + +{ TMCPTestHarness } + +constructor TMCPTestHarness.Create; +begin + inherited Create; + + FSettings := TMCPSettings.Create('', False); + + FManagerRegistry := TMCPManagerRegistry.Create; + FCoreManager := TMCPCoreManager.Create(FSettings); + FToolsManager := TMCPToolsManager.Create; + FResourcesManager := TMCPResourcesManager.Create; + FPromptsManager := TMCPPromptsManager.Create; + FSubscriptionsManager := TMCPSubscriptionsManager.Create; + FToolsManager.ChangeNotifier := FSubscriptionsManager; + FResourcesManager.ChangeNotifier := FSubscriptionsManager; + FPromptsManager.ChangeNotifier := FSubscriptionsManager; + + FManagerRegistry.RegisterManager(FCoreManager); + FManagerRegistry.RegisterManager(FToolsManager); + FManagerRegistry.RegisterManager(FResourcesManager); + FManagerRegistry.RegisterManager(FPromptsManager); + FManagerRegistry.RegisterManager(TMCPCompletionManager.Create(FPromptsManager, FResourcesManager)); + FManagerRegistry.RegisterManager(FSubscriptionsManager); + + FProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry); +end; + +destructor TMCPTestHarness.Destroy; +begin + FProcessor.Free; + FCoreManager := nil; + FManagerRegistry := nil; + FSettings.Free; + inherited; +end; + +function TMCPTestHarness.Process(const RequestBody: string): string; +begin + Result := FProcessor.ProcessRequest(RequestBody, ''); +end; + +end. diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas new file mode 100644 index 0000000..b3a2f87 --- /dev/null +++ b/tests/MCPServer.Tests.Http.pas @@ -0,0 +1,742 @@ +unit MCPServer.Tests.Http; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + IdHTTP, + MCPServer.Types, + MCPServer.Settings, + MCPServer.Authorization, + MCPServer.IdHTTPServer, + MCPServer.Tool.Base, + MCPServer.Tool.ContentSamples, + MCPServer.Tests.Harness; + +type + THttpReply = record + Status: Integer; + Body: string; + ContentLength: Int64; + RawHeaders: string; + function Header(const Name: string): string; + function Json: TJSONObject; + end; + + [RequiresScope('admin')] + TScopedTool = class(TSimpleTextTool) + public + constructor Create; override; + end; + + [TestFixture] + THttpTransportTests = class + private + FHarness: TMCPTestHarness; + FSettings: TMCPSettings; + FServer: TMCPIdHTTPServer; + procedure StartServer; + function Url(const Path: string): string; + function Send(const Method, Path, Body: string; const Headers: array of string): THttpReply; + function Post(const Body: string; const Headers: array of string): THttpReply; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Notification_Is202WithEmptyBody; + [Test] procedure Get_IsMethodNotAllowedWithAllow; + [Test] procedure Delete_IsMethodNotAllowed; + [Test] procedure Options_Is204; + [Test] procedure WrongPath_Is404; + [Test] procedure Origin_NotAllowed_Is403WithJsonRpcBody_EvenWithCorsDisabled; + [Test] procedure Origin_LoopbackOnAnyPort_IsAllowed; + [Test] procedure Origin_Null_IsDenied; + [Test] procedure Origin_AllowListWithPortWildcard; + [Test] procedure Cors_HeadersOnlyWhenEnabled; + [Test] procedure Cors_PreflightReflectsRequestedHeaders; + [Test] procedure Legacy_UnknownMethod_Is200; + [Test] procedure Modern_UnknownMethod_Is404; + [Test] procedure Modern_MissingVersionHeader_Is400HeaderMismatch; + [Test] procedure Modern_UnsupportedVersion_Is400; + [Test] procedure Modern_MissingClientCapabilities_Is400; + [Test] procedure ModernHeader_WithoutMeta_Is400InvalidParams; + [Test] procedure Legacy_UnknownVersionHeader_Is400; + [Test] procedure Modern_McpMethodHeader_IsRequiredAndMustMatch; + [Test] procedure Modern_McpNameHeader_Base64IsDecoded; + [Test] procedure Modern_Discover_Is200; + [Test] procedure BodyTooLarge_Is413; + [Test] procedure NestingTooDeep_Is400; + [Test] procedure SessionId_IsEchoedForLegacyOnly; + [Test] procedure Sse_HasNoIdLine; + [Test] procedure Bind_DefaultIsLoopback; + [Test] procedure Bind_ExplicitAddress; + [Test] procedure EndpointInfoPath_AnswersJson; + [Test] procedure Progress_IsStreamedBeforeTheResponse; + [Test] procedure Progress_WithoutEventStreamAccept_IsPlainJson; + [Test] procedure Log_OnlyWithLogLevel_InMeta; + [Test] procedure InputRequired_StreamsAsFinalEvent; + [Test] procedure StreamedError_IsFinalEvent; + [Test] procedure Listen_StreamsAckAndChanges_UntilStopped; + [Test] procedure Listen_WithoutEventStreamAccept_IsInvalidRequest; + [Test] procedure Auth_MissingToken_Is401WithChallenge; + [Test] procedure Auth_WrongToken_Is401_InvalidToken; + [Test] procedure Auth_MalformedHeader_Is400; + [Test] procedure Auth_ValidToken_IsServed; + [Test] procedure Auth_PreflightAndMetadata_NeedNoToken; + [Test] procedure Auth_ScopedTool_Is403_WithInsufficientScope; + [Test] procedure Auth_ScopedTool_OnOpenServer_Is403; + [Test] procedure Host_NotAllowed_Is403; + end; + +implementation + +uses + System.Threading; + +const + MODERN_VERSION_HEADER = 'MCP-Protocol-Version: 2026-07-28'; + MODERN_META = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + LEGACY_PING = '{"jsonrpc":"2.0","id":1,"method":"ping"}'; + +{ THttpReply } + +function THttpReply.Header(const Name: string): string; +begin + var Headers := TStringList.Create; + try + Headers.NameValueSeparator := ':'; + Headers.Text := RawHeaders; + Result := Trim(Headers.Values[Name]); + finally + Headers.Free; + end; +end; + +function THttpReply.Json: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Body) as TJSONObject; + Assert.IsNotNull(Result, 'body is not a JSON object: ' + Body); +end; + +{ TScopedTool } + +constructor TScopedTool.Create; +begin + inherited; + FName := 'test_scoped'; +end; + +{ THttpTransportTests } + +procedure THttpTransportTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FSettings := FHarness.Settings; + FSettings.Port := 0; + FSettings.CorsEnabled := False; + FServer := TMCPIdHTTPServer.Create(nil); + FServer.Settings := FSettings; + FServer.ManagerRegistry := FHarness.ManagerRegistry; + FServer.CoreManager := FHarness.CoreManager; +end; + +procedure THttpTransportTests.TearDown; +begin + FServer.Free; + FHarness.Free; +end; + +procedure THttpTransportTests.StartServer; +begin + FServer.Start; +end; + +function THttpTransportTests.Url(const Path: string): string; +begin + Result := Format('http://127.0.0.1:%d%s', [FServer.Port, Path]); +end; + +function THttpTransportTests.Send(const Method, Path, Body: string; const Headers: array of string): THttpReply; +begin + if not FServer.Active then + StartServer; + + var Http := TIdHTTP.Create(nil); + var Request := TStringStream.Create(Body, TEncoding.UTF8); + var Response := TMemoryStream.Create; + try + Http.HTTPOptions := Http.HTTPOptions + [hoNoProtocolErrorException, hoWantProtocolErrorContent] - [hoInProcessAuth]; + Http.MaxAuthRetries := 0; + Http.Request.ContentType := 'application/json'; + Http.Request.Accept := 'application/json'; + for var Header in Headers do + begin + var Separator := Header.IndexOf(':'); + var Name := Header.Substring(0, Separator).Trim; + var Value := Header.Substring(Separator + 1).Trim; + if SameText(Name, 'Accept') then + Http.Request.Accept := Value + else if SameText(Name, 'Content-Type') then + Http.Request.ContentType := Value + else + Http.Request.CustomHeaders.AddValue(Name, Value); + end; + + if Method = 'POST' then + Http.Post(Url(Path), Request, Response) + else if Method = 'GET' then + Http.Get(Url(Path), Response) + else if Method = 'DELETE' then + Http.Delete(Url(Path), Response) + else if Method = 'PUT' then + Http.Put(Url(Path), Request, Response) + else if Method = 'OPTIONS' then + Http.Options(Url(Path), Response) + else + raise Exception.Create('unsupported method ' + Method); + + Result.Status := Http.ResponseCode; + Result.ContentLength := Http.Response.ContentLength; + Result.RawHeaders := Http.Response.RawHeaders.Text; + var Bytes: TBytes; + SetLength(Bytes, Integer(Response.Size)); + if Response.Size > 0 then + Move(Response.Memory^, Bytes[0], Integer(Response.Size)); + Result.Body := TEncoding.UTF8.GetString(Bytes); + finally + Response.Free; + Request.Free; + Http.Free; + end; +end; + +function THttpTransportTests.Post(const Body: string; const Headers: array of string): THttpReply; +begin + Result := Send('POST', '/mcp', Body, Headers); +end; + +procedure THttpTransportTests.Notification_Is202WithEmptyBody; +begin + var Reply := Post('{"jsonrpc":"2.0","method":"notifications/initialized"}', []); + Assert.AreEqual(202, Reply.Status); + Assert.AreEqual('', Reply.Body); + Assert.AreEqual(Int64(0), Reply.ContentLength); +end; + +procedure THttpTransportTests.Get_IsMethodNotAllowedWithAllow; +begin + var Reply := Send('GET', '/mcp', '', ['Accept: text/event-stream']); + Assert.AreEqual(405, Reply.Status); + Assert.AreEqual('POST, OPTIONS', Reply.Header('Allow')); + Assert.AreEqual('', Reply.Body); +end; + +procedure THttpTransportTests.Delete_IsMethodNotAllowed; +begin + Assert.AreEqual(405, Send('DELETE', '/mcp', '', []).Status); + Assert.AreEqual(405, Send('PUT', '/mcp', '{}', []).Status); +end; + +procedure THttpTransportTests.Options_Is204; +begin + var Reply := Send('OPTIONS', '/mcp', '', ['Origin: http://localhost']); + Assert.AreEqual(204, Reply.Status); + Assert.AreEqual('', Reply.Body); +end; + +procedure THttpTransportTests.WrongPath_Is404; +begin + Assert.AreEqual(404, Send('POST', '/other', LEGACY_PING, []).Status); + Assert.AreEqual(404, Send('GET', '/mcp/extra', '', []).Status); +end; + +procedure THttpTransportTests.Origin_NotAllowed_Is403WithJsonRpcBody_EvenWithCorsDisabled; +begin + var Reply := Post(LEGACY_PING, ['Origin: http://evil.example']); + Assert.AreEqual(403, Reply.Status); + Assert.AreEqual('Origin', Reply.Header('Vary')); + var Json := Reply.Json; + try + Assert.AreEqual(JSONRPC_INVALID_REQUEST, Json.GetValue('error.code')); + Assert.IsNull(Json.GetValue('id')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.Origin_LoopbackOnAnyPort_IsAllowed; +begin + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: http://127.0.0.1:3000']).Status); + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: http://localhost:5173']).Status); + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: https://localhost']).Status); +end; + +procedure THttpTransportTests.Origin_Null_IsDenied; +begin + Assert.AreEqual(403, Post(LEGACY_PING, ['Origin: null']).Status); +end; + +procedure THttpTransportTests.Origin_AllowListWithPortWildcard; +begin + FSettings.SecurityAllowedOrigins := 'https://app.example:*'; + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: https://app.example:8443']).Status); + Assert.AreEqual(403, Post(LEGACY_PING, ['Origin: https://other.example']).Status); +end; + +procedure THttpTransportTests.Cors_HeadersOnlyWhenEnabled; +begin + var Disabled := Post(LEGACY_PING, ['Origin: http://localhost']); + Assert.AreEqual('', Disabled.Header('Access-Control-Allow-Origin')); + + FServer.Stop; + FSettings.CorsEnabled := True; + var Enabled := Post(LEGACY_PING, ['Origin: http://localhost']); + Assert.AreEqual(200, Enabled.Status); + Assert.AreEqual('http://localhost', Enabled.Header('Access-Control-Allow-Origin')); + Assert.AreEqual('POST, OPTIONS', Enabled.Header('Access-Control-Allow-Methods')); + Assert.IsTrue(Enabled.Header('Access-Control-Allow-Headers').Contains('Mcp-Method')); + Assert.IsTrue(Enabled.Header('Access-Control-Expose-Headers').Contains('WWW-Authenticate')); +end; + +procedure THttpTransportTests.Cors_PreflightReflectsRequestedHeaders; +begin + FSettings.CorsEnabled := True; + var Reply := Send('OPTIONS', '/mcp', '', ['Origin: http://localhost', + 'Access-Control-Request-Method: POST', 'Access-Control-Request-Headers: Mcp-Param-Region, X-Trace']); + Assert.AreEqual(204, Reply.Status); + var AllowHeaders := Reply.Header('Access-Control-Allow-Headers'); + Assert.IsTrue(AllowHeaders.Contains('Mcp-Param-Region'), AllowHeaders); + Assert.IsTrue(AllowHeaders.Contains('X-Trace'), AllowHeaders); +end; + +procedure THttpTransportTests.Legacy_UnknownMethod_Is200; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"totally/bogus/method"}', ['MCP-Protocol-Version: 2025-06-18']); + Assert.AreEqual(200, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32601')); +end; + +procedure THttpTransportTests.Modern_UnknownMethod_Is404; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"totally/bogus/method","params":{' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: totally/bogus/method']); + Assert.AreEqual(404, Reply.Status); + var Json := Reply.Json; + try + Assert.AreEqual(JSONRPC_METHOD_NOT_FOUND, Json.GetValue('error.code')); + Assert.AreEqual(1, Json.GetValue('id')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.Modern_MissingVersionHeader_Is400HeaderMismatch; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{' + MODERN_META + '}}', ['Mcp-Method: tools/list']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32020'), Reply.Body); +end; + +procedure THttpTransportTests.Modern_UnsupportedVersion_Is400; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}', + ['MCP-Protocol-Version: 1900-01-01', 'Mcp-Method: tools/list']); + Assert.AreEqual(400, Reply.Status); + var Json := Reply.Json; + try + Assert.AreEqual(MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION, Json.GetValue('error.code')); + Assert.AreEqual('2026-07-28', Json.GetValue('error.data.supported[0]')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.Modern_MissingClientCapabilities_Is400; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: tools/list']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32602'), Reply.Body); +end; + +procedure THttpTransportTests.ModernHeader_WithoutMeta_Is400InvalidParams; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list"}', [MODERN_VERSION_HEADER, 'Mcp-Method: tools/list']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32602'), Reply.Body); +end; + +procedure THttpTransportTests.Legacy_UnknownVersionHeader_Is400; +begin + var Reply := Post(LEGACY_PING, ['MCP-Protocol-Version: 1900-01-01']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32600'), Reply.Body); +end; + +procedure THttpTransportTests.Modern_McpMethodHeader_IsRequiredAndMustMatch; +begin + var Body := '{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{' + MODERN_META + '}}'; + + var Missing := Post(Body, [MODERN_VERSION_HEADER]); + Assert.AreEqual(400, Missing.Status); + Assert.IsTrue(Missing.Body.Contains('-32020'), Missing.Body); + + var Mismatch := Post(Body, [MODERN_VERSION_HEADER, 'Mcp-Method: TOOLS/LIST']); + Assert.AreEqual(400, Mismatch.Status); + Assert.IsTrue(Mismatch.Body.Contains('-32020'), Mismatch.Body); + + var Matching := Post(Body, [MODERN_VERSION_HEADER, 'mcp-method: tools/list']); + Assert.AreEqual(200, Matching.Status); +end; + +procedure THttpTransportTests.Modern_McpNameHeader_Base64IsDecoded; +begin + var Body := '{"jsonrpc":"2.0","id":1,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hi"},' + MODERN_META + '}}'; + + var Encoded := Post(Body, [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: =?base64?ZWNobw==?=']); + Assert.AreEqual(200, Encoded.Status); + Assert.IsTrue(Encoded.Body.Contains('Echo: hi'), Encoded.Body); + + var Wrong := Post(Body, [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: calculate']); + Assert.AreEqual(400, Wrong.Status); + Assert.IsTrue(Wrong.Body.Contains('-32020'), Wrong.Body); + + var Missing := Post(Body, [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call']); + Assert.AreEqual(400, Missing.Status); +end; + +procedure THttpTransportTests.Modern_Discover_Is200; +begin + var Reply := Post('{"jsonrpc":"2.0","id":"d","method":"server/discover","params":{' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: server/discover']); + Assert.AreEqual(200, Reply.Status); + var Json := Reply.Json; + try + Assert.AreEqual('complete', Json.GetValue('result.resultType')); + Assert.AreEqual('2026-07-28', Json.GetValue('result.supportedVersions[0]')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.BodyTooLarge_Is413; +begin + FSettings.MaxRequestBodyBytes := 64; + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"ping","params":{"padding":"' + StringOfChar('x', 100) + '"}}', []); + Assert.AreEqual(413, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32600'), Reply.Body); +end; + +procedure THttpTransportTests.NestingTooDeep_Is400; +begin + FSettings.MaxJsonDepth := 3; + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"ping","params":{"a":{"b":{"c":{}}}}}', []); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32700'), Reply.Body); +end; + +procedure THttpTransportTests.SessionId_IsEchoedForLegacyOnly; +begin + var Legacy := Post(LEGACY_PING, ['Mcp-Session-Id: session-42']); + Assert.AreEqual('session-42', Legacy.Header('Mcp-Session-Id')); + + var Modern := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: tools/list', 'Mcp-Session-Id: session-42']); + Assert.AreEqual(200, Modern.Status); + Assert.AreEqual('', Modern.Header('Mcp-Session-Id')); + + var Initialize := Post('{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"t","version":"1"}}}', []); + Assert.AreEqual('', Initialize.Header('Mcp-Session-Id'), 'sessions are never minted'); +end; + +procedure THttpTransportTests.Sse_HasNoIdLine; +begin + var Reply := Post(LEGACY_PING, ['Accept: application/json, text/event-stream']); + Assert.AreEqual(200, Reply.Status); + Assert.IsTrue(Reply.Header('Content-Type').StartsWith('text/event-stream'), Reply.Header('Content-Type')); + Assert.IsTrue(Reply.Body.StartsWith('event: message'#10'data: '), Reply.Body); + Assert.IsFalse(Reply.Body.Contains(#10'id:'), Reply.Body); +end; + +procedure THttpTransportTests.Bind_DefaultIsLoopback; +begin + StartServer; + var Addresses := FServer.BoundAddresses; + Assert.IsTrue(Length(Addresses) >= 1); + for var Address in Addresses do + Assert.IsTrue(Address.StartsWith('127.0.0.1:') or Address.StartsWith('[::1]:') + or Address.StartsWith('[0:0:0:0:0:0:0:1]:'), Address); +end; + +procedure THttpTransportTests.Bind_ExplicitAddress; +begin + FSettings.BindAddress := '127.0.0.1'; + StartServer; + var Addresses := FServer.BoundAddresses; + Assert.AreEqual(1, Integer(Length(Addresses))); + Assert.IsTrue(Addresses[0].StartsWith('127.0.0.1:'), Addresses[0]); + Assert.AreEqual(200, Post(LEGACY_PING, []).Status); +end; + +procedure THttpTransportTests.EndpointInfoPath_AnswersJson; +begin + FSettings.EndpointInfoPath := '/info'; + var Reply := Send('GET', '/info', '', []); + Assert.AreEqual(200, Reply.Status); + var Json := Reply.Json; + try + Assert.IsTrue(Json.GetValue('url').EndsWith('/mcp')); + Assert.AreEqual('2026-07-28', Json.GetValue('protocolVersions[0]')); + finally + Json.Free; + end; + Assert.AreEqual(404, Send('GET', '/nothing', '', []).Status); +end; + +procedure THttpTransportTests.Progress_IsStreamedBeforeTheResponse; +begin + var Reply := Post('{"jsonrpc":"2.0","id":9,"method":"tools/call","params":{"name":"test_tool_with_progress",' + + '"arguments":{"steps":3,"stepMs":10},"_meta":{"progressToken":"p1"}}}', + ['Accept: application/json, text/event-stream', 'MCP-Protocol-Version: 2025-11-25']); + Assert.AreEqual(200, Reply.Status); + Assert.IsTrue(Reply.Header('Content-Type').StartsWith('text/event-stream'), Reply.Header('Content-Type')); + Assert.AreEqual('no', Reply.Header('X-Accel-Buffering')); + + var Events := Reply.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.IsTrue(Length(Events) >= 3, Reply.Body); + for var I := 0 to High(Events) - 1 do + begin + Assert.IsTrue(Events[I].Contains('"method":"notifications/progress"'), Events[I]); + Assert.IsTrue(Events[I].Contains('"progressToken":"p1"'), Events[I]); + end; + Assert.IsTrue(Events[High(Events)].Contains('"id":9'), Events[High(Events)]); + Assert.IsTrue(Events[High(Events)].Contains('Completed 3 steps'), Events[High(Events)]); +end; + +procedure THttpTransportTests.Progress_WithoutEventStreamAccept_IsPlainJson; +begin + var Reply := Post('{"jsonrpc":"2.0","id":9,"method":"tools/call","params":{"name":"test_tool_with_progress",' + + '"arguments":{"steps":2,"stepMs":10},"_meta":{"progressToken":"p1"}}}', []); + Assert.AreEqual(200, Reply.Status); + Assert.IsTrue(Reply.Header('Content-Type').StartsWith('application/json'), Reply.Header('Content-Type')); + Assert.IsFalse(Reply.Body.Contains('notifications/progress'), Reply.Body); + var Json := Reply.Json; + try + Assert.AreEqual('Completed 2 steps', Json.GetValue('result.content[0].text')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.Log_OnlyWithLogLevel_InMeta; +const + CALL = '{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"test_logging_tool","arguments":{},' + + '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}%s}}}'; +begin + var Silent := Post(Format(CALL, ['']), + ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_logging_tool']); + Assert.AreEqual(200, Silent.Status); + Assert.IsFalse(Silent.Body.Contains('notifications/message'), Silent.Body); + Assert.IsTrue(Silent.Body.Contains('"resultType":"complete"'), Silent.Body); + + var Verbose := Post(Format(CALL, [',"io.modelcontextprotocol/logLevel":"error"']), + ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_logging_tool']); + Assert.AreEqual(200, Verbose.Status); + var Events := Verbose.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(5, Integer(Length(Events)), Verbose.Body); + Assert.IsTrue(Events[0].Contains('"level":"error"'), Events[0]); + Assert.IsFalse(Verbose.Body.Contains('"level":"warning"'), Verbose.Body); + Assert.IsTrue(Events[4].Contains('"id":3'), Events[4]); +end; + +procedure THttpTransportTests.InputRequired_StreamsAsFinalEvent; +begin + var Reply := Post('{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_streaming_elicitation","arguments":{},' + + '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{"elicitation":{}},' + + '"io.modelcontextprotocol/logLevel":"info"}}}', + ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_streaming_elicitation']); + Assert.AreEqual(200, Reply.Status); + var Events := Reply.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(2, Integer(Length(Events)), Reply.Body); + Assert.IsTrue(Events[0].Contains('notifications/message'), Events[0]); + Assert.IsTrue(Events[1].Contains('"resultType":"input_required"'), Events[1]); + Assert.IsTrue(Events[1].Contains('"confirm"'), Events[1]); +end; + +procedure THttpTransportTests.StreamedError_IsFinalEvent; +begin + var Reply := Post('{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"test_streaming_elicitation","arguments":{},' + + '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},' + + '"io.modelcontextprotocol/logLevel":"info"}}}', + ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_streaming_elicitation']); + Assert.AreEqual(200, Reply.Status, 'the stream was already open when the -32021 error arose'); + var Events := Reply.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(2, Integer(Length(Events)), Reply.Body); + Assert.IsTrue(Events[1].Contains('"code":-32021'), Events[1]); +end; + +procedure THttpTransportTests.Listen_StreamsAckAndChanges_UntilStopped; +const + LISTEN = '{"jsonrpc":"2.0","id":"sub-1","method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true,"resourceSubscriptions":["test://static-text"]},' + MODERN_META + '}}'; + TRIGGER = '{"jsonrpc":"2.0","id":2,"method":"tools/call","params":{"name":"%s","arguments":{},' + MODERN_META + '}}'; +begin + StartServer; + var Listener := TTask.Future( + function: THttpReply + begin + Result := Post(LISTEN, ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: subscriptions/listen']); + end); + + var Deadline := TThread.GetTickCount64 + 2000; + while (FHarness.SubscriptionsManager.ActiveCount = 0) and (TThread.GetTickCount64 < Deadline) do + Sleep(10); + Assert.AreEqual(1, FHarness.SubscriptionsManager.ActiveCount, 'the subscription is open'); + + Post(Format(TRIGGER, ['test_trigger_tool_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_tool_change']); + Post(Format(TRIGGER, ['test_trigger_prompt_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_prompt_change']); + Post(Format(TRIGGER, ['test_trigger_resource_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_resource_change']); + FServer.Stop; + + var Reply := Listener.Value; + Assert.AreEqual(200, Reply.Status); + var Events := Reply.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(4, Integer(Length(Events)), Reply.Body); + Assert.IsTrue(Events[0].Contains('"method":"notifications/subscriptions/acknowledged"'), Events[0]); + Assert.IsTrue(Events[0].Contains('"toolsListChanged":true'), Events[0]); + Assert.IsTrue(Events[0].Contains('"resourceSubscriptions":["test://static-text"]'), Events[0]); + Assert.IsTrue(Events[0].Contains('"io.modelcontextprotocol/subscriptionId":"sub-1"'), Events[0]); + Assert.IsTrue(Events[1].Contains('"method":"notifications/tools/list_changed"'), Events[1]); + Assert.IsTrue(Events[2].Contains('"method":"notifications/resources/updated"'), Events[2]); + Assert.IsTrue(Events[2].Contains('"uri":"test://static-text"'), Events[2]); + Assert.IsFalse(Reply.Body.Contains('prompts/list_changed'), 'not requested'); + Assert.IsTrue(Events[3].Contains('"id":"sub-1"'), Events[3]); + Assert.IsTrue(Events[3].Contains('"resultType":"complete"'), Events[3]); + Assert.IsTrue(Events[3].Contains('"io.modelcontextprotocol/subscriptionId":"sub-1"'), Events[3]); +end; + +procedure THttpTransportTests.Listen_WithoutEventStreamAccept_IsInvalidRequest; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true},' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: subscriptions/listen']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32600'), Reply.Body); +end; + +procedure THttpTransportTests.Auth_MissingToken_Is401WithChallenge; +begin + FSettings.AuthorizationServers := 'https://auth.example'; + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['s3cret']); + var Reply := Post(LEGACY_PING, []); + Assert.AreEqual(401, Reply.Status); + Assert.AreEqual(Format('Bearer resource_metadata="http://localhost:%d/.well-known/oauth-protected-resource/mcp"', [FServer.Port]), + Reply.Header('WWW-Authenticate')); + Assert.IsTrue(Reply.Body.Contains('-32600'), Reply.Body); + Assert.IsFalse(Reply.Body.Contains('"id"'), 'the challenge body carries no id'); +end; + +procedure THttpTransportTests.Auth_WrongToken_Is401_InvalidToken; +begin + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['s3cret']); + var Reply := Post(LEGACY_PING, ['Authorization: Bearer nope']); + Assert.AreEqual(401, Reply.Status); + Assert.AreEqual('Bearer error="invalid_token", error_description="The bearer token is not recognised"', + Reply.Header('WWW-Authenticate')); +end; + +procedure THttpTransportTests.Auth_MalformedHeader_Is400; +begin + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['s3cret']); + var Reply := Post(LEGACY_PING, ['Authorization: Basic abc']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Header('WWW-Authenticate').Contains('error="invalid_request"'), Reply.Header('WWW-Authenticate')); + var Empty := Post(LEGACY_PING, ['Authorization: Bearer']); + Assert.AreEqual(400, Empty.Status); +end; + +procedure THttpTransportTests.Auth_ValidToken_IsServed; +begin + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['s3cret']); + var Reply := Post(LEGACY_PING, ['Authorization: bearer s3cret']); + Assert.AreEqual(200, Reply.Status); + Assert.AreEqual('', Reply.Header('WWW-Authenticate')); + var Modern := Post('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: tools/list', 'Authorization: Bearer s3cret']); + Assert.AreEqual(200, Modern.Status); +end; + +procedure THttpTransportTests.Auth_PreflightAndMetadata_NeedNoToken; +begin + FSettings.CorsEnabled := True; + FSettings.AuthorizationServers := 'https://auth.example, https://auth2.example'; + FSettings.ScopesSupported := 'read,offline_access'; + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['s3cret']); + Assert.AreEqual(204, Send('OPTIONS', '/mcp', '', ['Origin: http://localhost:5173']).Status); + + for var Path in ['/.well-known/oauth-protected-resource', '/.well-known/oauth-protected-resource/mcp'] do + begin + var Reply := Send('GET', Path, '', []); + Assert.AreEqual(200, Reply.Status, Path); + Assert.AreEqual('max-age=3600', Reply.Header('Cache-Control')); + var Json := Reply.Json; + try + Assert.AreEqual(Format('http://localhost:%d/mcp', [FServer.Port]), Json.GetValue('resource')); + Assert.AreEqual('https://auth2.example', Json.GetValue('authorization_servers[1]')); + Assert.AreEqual(1, (Json.GetValue('scopes_supported') as TJSONArray).Count, 'offline_access is dropped'); + Assert.AreEqual('header', Json.GetValue('bearer_methods_supported[0]')); + finally + Json.Free; + end; + end; + + Assert.AreEqual(404, Send('GET', '/.well-known/other', '', []).Status); + Assert.AreEqual(401, Send('GET', '/mcp', '', []).Status, 'GET on the endpoint is authenticated before 405'); +end; + +procedure THttpTransportTests.Auth_ScopedTool_Is403_WithInsufficientScope; +const + CALL = '{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_scoped","arguments":{}}}'; +begin + FHarness.ToolsManager.AddTool(TScopedTool.Create); + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['reader'], ['read']); + var Denied := Post(CALL, ['Authorization: Bearer reader']); + Assert.AreEqual(403, Denied.Status); + Assert.AreEqual('Bearer error="insufficient_scope", scope="admin"', Denied.Header('WWW-Authenticate')); + var Json := Denied.Json; + try + Assert.AreEqual(4, Json.GetValue('id')); + Assert.AreEqual(-32600, Json.GetValue('error.code')); + Assert.AreEqual('admin', Json.GetValue('error.data.requiredScope')); + finally + Json.Free; + end; + + FServer.Authorizer := TMCPStaticBearerAuthorizer.Create(['admin-token'], ['read', 'admin']); + var Allowed := Post(CALL, ['Authorization: Bearer admin-token']); + Assert.AreEqual(200, Allowed.Status); + Assert.IsTrue(Allowed.Body.Contains('This is a simple text response'), Allowed.Body); +end; + +procedure THttpTransportTests.Auth_ScopedTool_OnOpenServer_Is403; +begin + FHarness.ToolsManager.AddTool(TScopedTool.Create); + var Reply := Post('{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_scoped","arguments":{}}}', []); + Assert.AreEqual(403, Reply.Status, 'nobody holds a scope on an open server'); +end; + +procedure THttpTransportTests.Host_NotAllowed_Is403; +begin + FSettings.AllowedHosts := 'mcp.example, localhost'; + var Denied := Post(LEGACY_PING, []); + Assert.AreEqual(403, Denied.Status, 'the client sends Host: 127.0.0.1'); + Assert.IsTrue(Denied.Body.Contains('Host not allowed'), Denied.Body); + + FSettings.AllowedHosts := '127.0.0.1:*'; + Assert.AreEqual(200, Post(LEGACY_PING, []).Status); +end; + +end. diff --git a/tests/MCPServer.Tests.HttpHeaders.pas b/tests/MCPServer.Tests.HttpHeaders.pas new file mode 100644 index 0000000..52fcbe3 --- /dev/null +++ b/tests/MCPServer.Tests.HttpHeaders.pas @@ -0,0 +1,181 @@ +unit MCPServer.Tests.HttpHeaders; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + THttpHeadersTests = class + public + [Test] procedure Decode_PlainAsciiValue_IsReturnedAsIs; + [Test] procedure Decode_SentinelValues_FromSpecTable; + [Test] procedure Decode_LiteralSentinelPattern_RoundTrips; + [Test] procedure Decode_BadPadding_Fails; + [Test] procedure Decode_InvalidBase64Characters_Fails; + [Test] procedure Decode_NonAsciiPlainValue_Fails; + [Test] procedure Decode_UppercaseMarkers_AreNotASentinel; + [Test] procedure Accept_ListsMediaTypesCaseInsensitively; + [Test] procedure Accept_WildcardDoesNotCount; + [Test] procedure Origin_LoopbackOnAnyPort_IsAllowed; + [Test] procedure Origin_AbsentAllowed_NullDenied; + [Test] procedure Origin_AllowListMatchesSchemeHostAndPort; + [Test] procedure Origin_PortWildcardAndAllowAll; + [Test] procedure Origin_DefaultPortEqualsExplicitPort; + [Test] procedure Host_AllowList_MatchesNameAndPort; + [Test] procedure NestingDepth_CountsObjectsAndArraysOutsideStrings; + end; + +implementation + +uses + System.SysUtils, + MCPServer.HttpHeaders; + +{ THttpHeadersTests } + +procedure THttpHeadersTests.Decode_PlainAsciiValue_IsReturnedAsIs; +begin + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode('us-west1', Decoded)); + Assert.AreEqual('us-west1', Decoded); + Assert.IsTrue(TMCPHeaderValue.TryDecode('file:///projects/myapp/config.json', Decoded)); + Assert.AreEqual('file:///projects/myapp/config.json', Decoded); +end; + +procedure THttpHeadersTests.Decode_SentinelValues_FromSpecTable; +begin + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode('=?base64?SGVsbG8sIOS4lueVjA==?=', Decoded)); + Assert.AreEqual('Hello, ' + #$4E16 + #$754C, Decoded); + + Assert.IsTrue(TMCPHeaderValue.TryDecode('=?base64?IHBhZGRlZCA=?=', Decoded)); + Assert.AreEqual(' padded ', Decoded); + + Assert.IsTrue(TMCPHeaderValue.TryDecode('=?base64?bGluZTEKbGluZTI=?=', Decoded)); + Assert.AreEqual('line1'#10'line2', Decoded); +end; + +procedure THttpHeadersTests.Decode_LiteralSentinelPattern_RoundTrips; +begin + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode('=?base64?PT9iYXNlNjQ/bGl0ZXJhbD89?=', Decoded)); + Assert.AreEqual('=?base64?literal?=', Decoded); +end; + +procedure THttpHeadersTests.Decode_BadPadding_Fails; +begin + var Decoded: string; + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64?SGVsbG8?=', Decoded), 'length not a multiple of four'); + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64?SGVs=bG8=?=', Decoded), 'padding in the middle'); + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64?SG===?=', Decoded), 'three padding characters'); + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64??=', Decoded), 'empty payload'); +end; + +procedure THttpHeadersTests.Decode_InvalidBase64Characters_Fails; +begin + var Decoded: string; + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64?SGVs bG8=?=', Decoded)); + Assert.IsFalse(TMCPHeaderValue.TryDecode('=?base64?SGVs-bG8=?=', Decoded)); +end; + +procedure THttpHeadersTests.Decode_NonAsciiPlainValue_Fails; +begin + var Decoded: string; + Assert.IsFalse(TMCPHeaderValue.TryDecode('caf' + #$00E9, Decoded)); + Assert.IsFalse(TMCPHeaderValue.TryDecode('line1'#10'line2', Decoded)); +end; + +procedure THttpHeadersTests.Decode_UppercaseMarkers_AreNotASentinel; +begin + var Decoded: string; + Assert.IsFalse(TMCPHeaderValue.IsSentinel('=?BASE64?SGVsbG8=?=')); + Assert.IsTrue(TMCPHeaderValue.TryDecode('=?BASE64?SGVsbG8=?=', Decoded)); + Assert.AreEqual('=?BASE64?SGVsbG8=?=', Decoded); +end; + +procedure THttpHeadersTests.Accept_ListsMediaTypesCaseInsensitively; +begin + Assert.IsTrue(TMCPAcceptHeader.Accepts('application/json, text/event-stream', 'text/event-stream')); + Assert.IsTrue(TMCPAcceptHeader.Accepts('application/json, text/event-stream', 'application/json')); + Assert.IsTrue(TMCPAcceptHeader.Accepts('text/event-stream;q=0.9', 'text/event-stream')); + Assert.IsTrue(TMCPAcceptHeader.Accepts('TEXT/EVENT-STREAM', 'text/event-stream')); + Assert.IsFalse(TMCPAcceptHeader.Accepts('application/json', 'text/event-stream')); +end; + +procedure THttpHeadersTests.Accept_WildcardDoesNotCount; +begin + Assert.IsFalse(TMCPAcceptHeader.Accepts('*/*', 'text/event-stream')); + Assert.IsFalse(TMCPAcceptHeader.Accepts('text/*', 'text/event-stream')); +end; + +procedure THttpHeadersTests.Origin_LoopbackOnAnyPort_IsAllowed; +begin + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('http://localhost', nil)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('http://localhost:3000', nil)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://127.0.0.1:8443', nil)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('http://[::1]:5173', nil)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('HTTP://LOCALHOST:3000', nil)); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('ftp://localhost', nil)); +end; + +procedure THttpHeadersTests.Origin_AbsentAllowed_NullDenied; +begin + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('', nil)); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('null', nil)); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('http://evil.example', nil)); +end; + +procedure THttpHeadersTests.Origin_AllowListMatchesSchemeHostAndPort; +begin + var AllowList: TArray := ['https://app.example', 'http://app.example:8080']; + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://app.example', AllowList)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://APP.example', AllowList)); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('http://app.example:8080', AllowList)); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('http://app.example', AllowList), 'scheme differs'); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('https://app.example:8443', AllowList), 'port differs'); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('https://app.example.evil', AllowList)); +end; + +procedure THttpHeadersTests.Origin_PortWildcardAndAllowAll; +begin + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://app.example:8443', ['https://app.example:*'])); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://app.example', ['https://app.example:*'])); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://anything.example', ['*'])); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('null', ['*'])); +end; + +procedure THttpHeadersTests.Origin_DefaultPortEqualsExplicitPort; +begin + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://app.example:443', ['https://app.example'])); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('https://app.example', ['https://app.example:443'])); + Assert.IsTrue(TMCPOriginPolicy.IsAllowed('http://app.example:80', ['http://app.example'])); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('http://app.example:8080', ['http://app.example'])); + Assert.IsFalse(TMCPOriginPolicy.IsAllowed('http://app.example:443', ['https://app.example'])); +end; + +procedure THttpHeadersTests.Host_AllowList_MatchesNameAndPort; +begin + Assert.IsTrue(TMCPHostPolicy.IsAllowed('anything.example:3000', nil), 'empty list allows every host'); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('mcp.example:3000', ['mcp.example'])); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('MCP.example', ['mcp.example'])); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('mcp.example:3000', ['mcp.example:3000'])); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('mcp.example:3000', ['mcp.example:*'])); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('[::1]:3000', ['[::1]'])); + Assert.IsTrue(TMCPHostPolicy.IsAllowed('evil.example', ['*'])); + Assert.IsFalse(TMCPHostPolicy.IsAllowed('mcp.example:3001', ['mcp.example:3000'])); + Assert.IsFalse(TMCPHostPolicy.IsAllowed('evil.example', ['mcp.example', 'localhost'])); + Assert.IsFalse(TMCPHostPolicy.IsAllowed('', ['mcp.example'])); +end; + +procedure THttpHeadersTests.NestingDepth_CountsObjectsAndArraysOutsideStrings; +begin + Assert.AreEqual(0, TMCPJsonLimits.NestingDepth('"scalar"')); + Assert.AreEqual(1, TMCPJsonLimits.NestingDepth('{"a":1}')); + Assert.AreEqual(3, TMCPJsonLimits.NestingDepth('{"a":[{"b":1}]}')); + Assert.AreEqual(1, TMCPJsonLimits.NestingDepth('{"a":"[[[{{{"}')); + Assert.AreEqual(2, TMCPJsonLimits.NestingDepth('{"a":"\"[","b":[1]}')); +end; + +end. diff --git a/tests/MCPServer.Tests.Logger.pas b/tests/MCPServer.Tests.Logger.pas new file mode 100644 index 0000000..979e92f --- /dev/null +++ b/tests/MCPServer.Tests.Logger.pas @@ -0,0 +1,110 @@ +unit MCPServer.Tests.Logger; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TLoggerStdoutGuardTests = class + private + FOriginalUseStdErr: Boolean; + FOriginalStdoutReserved: Boolean; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure StdoutReserved_ForcesUseStdErr; + [Test] procedure StdoutReserved_RefusesUseStdErrFalse_AndWarnsOnce; + [Test] procedure StdoutReleased_AllowsUseStdErrFalseAgain; + [Test] procedure StdioTransport_Create_ReservesStdout; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + MCPServer.Logger, + MCPServer.StdioTransport, + MCPServer.Tests.Harness; + +{ TLoggerStdoutGuardTests } + +procedure TLoggerStdoutGuardTests.Setup; +begin + FOriginalUseStdErr := TLogger.UseStdErr; + FOriginalStdoutReserved := TLogger.StdoutReserved; + TLogger.StdoutReserved := False; + TLogger.UseStdErr := False; +end; + +procedure TLoggerStdoutGuardTests.TearDown; +begin + TLogger.OnLogMessage := nil; + TLogger.StdoutReserved := FOriginalStdoutReserved; + TLogger.UseStdErr := FOriginalUseStdErr; +end; + +procedure TLoggerStdoutGuardTests.StdoutReserved_ForcesUseStdErr; +begin + Assert.IsFalse(TLogger.UseStdErr); + + TLogger.StdoutReserved := True; + + Assert.IsTrue(TLogger.UseStdErr); +end; + +procedure TLoggerStdoutGuardTests.StdoutReserved_RefusesUseStdErrFalse_AndWarnsOnce; +begin + var Warnings := TStringList.Create; + try + TLogger.OnLogMessage := + procedure(const Message: string) + begin + if Message.Contains('[WARN ]') and Message.Contains('stdout is reserved') then + Warnings.Add(Message); + end; + + TLogger.StdoutReserved := True; + TLogger.UseStdErr := False; + TLogger.UseStdErr := False; + + Assert.IsTrue(TLogger.UseStdErr, 'UseStdErr must stay True while stdout is reserved'); + Assert.AreEqual(1, Warnings.Count, 'the refusal is logged once'); + finally + TLogger.OnLogMessage := nil; + Warnings.Free; + end; +end; + +procedure TLoggerStdoutGuardTests.StdoutReleased_AllowsUseStdErrFalseAgain; +begin + TLogger.StdoutReserved := True; + TLogger.StdoutReserved := False; + + TLogger.UseStdErr := False; + + Assert.IsFalse(TLogger.UseStdErr); +end; + +procedure TLoggerStdoutGuardTests.StdioTransport_Create_ReservesStdout; +begin + var Harness := TMCPTestHarness.Create; + try + var Transport := TMCPStdioTransport.Create(Harness.ManagerRegistry, Harness.CoreManager); + try + Assert.IsTrue(TLogger.StdoutReserved); + Assert.IsTrue(TLogger.UseStdErr); + finally + Transport.Free; + end; + finally + Harness.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Mrtr.pas b/tests/MCPServer.Tests.Mrtr.pas new file mode 100644 index 0000000..f3306fe --- /dev/null +++ b/tests/MCPServer.Tests.Mrtr.pas @@ -0,0 +1,676 @@ +unit MCPServer.Tests.Mrtr; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + [TestFixture] + TRequestStateSealerTests = class + public + [Test] procedure Seal_Open_RoundTripsState; + [Test] procedure Open_TamperedToken_Fails; + [Test] procedure Open_OtherMethodOrDigestOrPrincipal_Fails; + [Test] procedure Open_Expired_Fails; + [Test] procedure Open_OtherKey_Fails; + [Test] procedure DigestOf_IgnoresMetaInputResponsesAndRequestState; + [Test] procedure EmptyKey_IsEphemeral; + end; + + [TestFixture] + TInputRequestsTests = class + public + [Test] procedure ToJson_HasMethodAndParamsPerKey; + [Test] procedure RequiredCapability_PerMethod; + [Test] procedure FieldSchema_IsObjectWithRequiredField; + [Test] procedure InputResponse_Readers; + end; + + [TestFixture] + TInputRequiredFlowTests = class + private + FHarness: TMCPTestHarness; + FProcessor: TMCPJsonRpcProcessor; + function Call(const Method, ParamsJson: string; const Capabilities: string = '{"elicitation":{},"sampling":{},"roots":{"listChanged":true}}'): TJSONObject; + function CallTool(const Name, ExtraParams: string; const Capabilities: string = '{"elicitation":{},"sampling":{},"roots":{"listChanged":true}}'): TJSONObject; + function CallLegacy(const Name: string): TJSONObject; + function ResultText(const Response: TJSONObject): string; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Elicitation_RoundOne_IsInputRequired_WithResultType; + [Test] procedure Elicitation_RoundTwo_Completes; + [Test] procedure Elicitation_WrongKey_ReRequests; + [Test] procedure Elicitation_ExtraKeys_AreIgnored; + [Test] procedure InputResponses_NotObject_IsInvalidParams; + [Test] procedure InputResponses_ValueNotObject_IsInvalidParams; + [Test] procedure Sampling_RoundTrip; + [Test] procedure ListRoots_RoundTrip; + [Test] procedure RequestState_RoundTrip_MentionsStateOk; + [Test] procedure RequestState_Tampered_IsInvalidParams; + [Test] procedure RequestState_OtherTool_IsInvalidParams; + [Test] procedure MultipleInputs_RoundTrip; + [Test] procedure MultiRound_StateChangesPerRound; + [Test] procedure Capabilities_OnlyDeclaredKinds; + [Test] procedure Capabilities_UndeclaredKind_Is32021; + [Test] procedure MissingCapabilityTool_Is32021_WithRequiredCapabilities; + [Test] procedure Legacy_IsInternalError; + [Test] procedure Prompt_RoundTrip; + [Test] procedure ToolsList_IsNeverInputRequired; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + MCPServer.Errors, + MCPServer.Mrtr; + +const + SEALER_KEY = 'unit-test-key'; + DIGEST_A = 'digest-a'; + PRINCIPAL_A = 'alice'; + +{ TRequestStateSealerTests } + +procedure TRequestStateSealerTests.Seal_Open_RoundTripsState; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + var State := TJSONObject.Create; + try + State.AddPair('round', TJSONNumber.Create(2)); + State.AddPair('name', 'Alice'); + var Token := Sealer.Seal(State, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.IsFalse(Token.Contains('='), 'base64url without padding'); + + var Opened := Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A); + try + Assert.AreEqual(2, Opened.GetValue('round')); + Assert.AreEqual('Alice', Opened.GetValue('name')); + finally + Opened.Free; + end; + finally + State.Free; + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_TamperedToken_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + for var Tampered in [Token + '-TAMPERED', Token.Substring(1), 'not.a.token', '', Token.Replace('.', '')] do + begin + Assert.WillRaise( + procedure + begin + Sealer.Open(Tampered, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError, Tampered); + end; + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_OtherMethodOrDigestOrPrincipal_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'prompts/get', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError, 'method'); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', 'digest-b', PRINCIPAL_A).Free; + end, EMCPError, 'digest'); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', DIGEST_A, 'bob').Free; + end, EMCPError, 'principal'); + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_Expired_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY, -5); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError); + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_OtherKey_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + var Other := TMCPRequestStateSealer.Create('another-key'); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Other.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError); + finally + Other.Free; + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.DigestOf_IgnoresMetaInputResponsesAndRequestState; +begin + var Plain := TJSONObject.ParseJSONValue('{"name":"t","arguments":{"b":1,"a":[1,2]}}') as TJSONObject; + var Reordered := TJSONObject.ParseJSONValue( + '{"arguments":{"a":[1,2],"b":1},"name":"t","_meta":{"x":1},"inputResponses":{"k":{}},"requestState":"s"}') as TJSONObject; + var Different := TJSONObject.ParseJSONValue('{"name":"t","arguments":{"b":2,"a":[1,2]}}') as TJSONObject; + try + Assert.AreEqual(TMCPRequestStateSealer.DigestOf(Plain), TMCPRequestStateSealer.DigestOf(Reordered)); + Assert.AreNotEqual(TMCPRequestStateSealer.DigestOf(Plain), TMCPRequestStateSealer.DigestOf(Different)); + Assert.AreEqual(TMCPRequestStateSealer.DigestOf(nil), TMCPRequestStateSealer.DigestOf(nil)); + finally + Plain.Free; + Reordered.Free; + Different.Free; + end; +end; + +procedure TRequestStateSealerTests.EmptyKey_IsEphemeral; +begin + var Sealer := TMCPRequestStateSealer.Create(''); + var Fixed := TMCPRequestStateSealer.Create(SEALER_KEY); + try + Assert.IsTrue(Sealer.KeyIsEphemeral); + Assert.IsFalse(Fixed.KeyIsEphemeral); + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + finally + Fixed.Free; + Sealer.Free; + end; +end; + +{ TInputRequestsTests } + +procedure TInputRequestsTests.ToJson_HasMethodAndParamsPerKey; +begin + var Requests := TMCPInputRequests.Create + .AddElicitation('who', 'Who?', TMCPInputRequests.FieldSchema('name')) + .AddSampling('what', 'What?', 10, 'Be brief') + .AddListRoots('roots'); + try + Assert.AreEqual(3, Requests.Count); + Assert.AreEqual(3, Integer(Length(Requests.Methods))); + var Json := Requests.ToJson; + try + Assert.AreEqual('elicitation/create', Json.GetValue('who.method')); + Assert.AreEqual('form', Json.GetValue('who.params.mode')); + Assert.AreEqual('Who?', Json.GetValue('who.params.message')); + Assert.AreEqual('string', Json.GetValue('who.params.requestedSchema.properties.name.type')); + Assert.AreEqual('sampling/createMessage', Json.GetValue('what.method')); + Assert.AreEqual('What?', Json.GetValue('what.params.messages[0].content.text')); + Assert.AreEqual('Be brief', Json.GetValue('what.params.systemPrompt')); + Assert.AreEqual(10, Json.GetValue('what.params.maxTokens')); + Assert.AreEqual('roots/list', Json.GetValue('roots.method')); + Assert.IsNotNull(Json.FindValue('roots.params')); + finally + Json.Free; + end; + finally + Requests.Free; + end; +end; + +procedure TInputRequestsTests.RequiredCapability_PerMethod; +begin + Assert.AreEqual('elicitation', TMCPInputRequests.RequiredCapability('elicitation/create')); + Assert.AreEqual('sampling', TMCPInputRequests.RequiredCapability('sampling/createMessage')); + Assert.AreEqual('roots', TMCPInputRequests.RequiredCapability('roots/list')); + Assert.AreEqual('', TMCPInputRequests.RequiredCapability('tools/call')); +end; + +procedure TInputRequestsTests.FieldSchema_IsObjectWithRequiredField; +begin + var Schema := TMCPInputRequests.FieldSchema('ok', 'boolean'); + try + Assert.AreEqual('object', Schema.GetValue('type')); + Assert.AreEqual('boolean', Schema.GetValue('properties.ok.type')); + Assert.AreEqual('ok', Schema.GetValue('required[0]')); + finally + Schema.Free; + end; +end; + +procedure TInputRequestsTests.InputResponse_Readers; +begin + var Accepted := TJSONObject.ParseJSONValue('{"action":"accept","content":{"name":"Alice","ok":true}}') as TJSONObject; + var Declined := TJSONObject.ParseJSONValue('{"action":"decline"}') as TJSONObject; + var Sampled := TJSONObject.ParseJSONValue('{"role":"assistant","content":{"type":"text","text":"Paris"}}') as TJSONObject; + var Roots := TJSONObject.ParseJSONValue('{"roots":[{"uri":"file:///r"}]}') as TJSONObject; + try + Assert.AreEqual('Alice', TMCPInputResponse.ElicitationField(Accepted, 'name')); + Assert.AreEqual('true', TMCPInputResponse.ElicitationField(Accepted, 'ok')); + Assert.AreEqual('', TMCPInputResponse.ElicitationField(Accepted, 'missing')); + Assert.IsNull(TMCPInputResponse.ElicitationContent(Declined)); + Assert.AreEqual('', TMCPInputResponse.ElicitationField(nil, 'name')); + Assert.AreEqual('Paris', TMCPInputResponse.SamplingText(Sampled)); + Assert.AreEqual('', TMCPInputResponse.SamplingText(Accepted)); + Assert.AreEqual(1, TMCPInputResponse.Roots(Roots).Count); + Assert.IsNull(TMCPInputResponse.Roots(Sampled)); + finally + Accepted.Free; + Declined.Free; + Sampled.Free; + Roots.Free; + end; +end; + +{ TInputRequiredFlowTests } + +procedure TInputRequiredFlowTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FHarness.Settings.RequestStateKey := SEALER_KEY; + FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FHarness.Settings); +end; + +procedure TInputRequiredFlowTests.TearDown; +begin + FProcessor.Free; + FHarness.Free; +end; + +function TInputRequiredFlowTests.Call(const Method, ParamsJson: string; const Capabilities: string): TJSONObject; +begin + var Meta := Format('"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":%s}', + [Capabilities]); + var Params := ParamsJson; + if Params = '' then + Params := Meta + else + Params := Params + ',' + Meta; + var Body := Format('{"jsonrpc":"2.0","id":7,"method":"%s","params":{%s}}', [Method, Params]); + var Outcome := FProcessor.ProcessRequestEx(Body, TMCPTransportHints.None); + Result := TJSONObject.ParseJSONValue(Outcome.Body) as TJSONObject; + Assert.IsNotNull(Result, 'response is not a JSON object: ' + Outcome.Body); + Result.AddPair('httpStatus', TJSONNumber.Create(Outcome.HttpStatus)); +end; + +function TInputRequiredFlowTests.CallTool(const Name, ExtraParams: string; const Capabilities: string): TJSONObject; +begin + var Params := Format('"name":"%s","arguments":{}', [Name]); + if ExtraParams <> '' then + Params := Params + ',' + ExtraParams; + Result := Call('tools/call', Params, Capabilities); +end; + +function TInputRequiredFlowTests.CallLegacy(const Name: string): TJSONObject; +begin + var Body := Format('{"jsonrpc":"2.0","id":7,"method":"tools/call","params":{"name":"%s","arguments":{}}}', [Name]); + var Outcome := FProcessor.ProcessRequestEx(Body, TMCPTransportHints.ForHttp(True, '2025-11-25')); + Result := TJSONObject.ParseJSONValue(Outcome.Body) as TJSONObject; + Assert.IsNotNull(Result, 'response is not a JSON object: ' + Outcome.Body); +end; + +function TInputRequiredFlowTests.ResultText(const Response: TJSONObject): string; +begin + Result := Response.GetValue('result.content[0].text', ''); +end; + +procedure TInputRequiredFlowTests.Elicitation_RoundOne_IsInputRequired_WithResultType; +begin + var Response := CallTool('test_input_required_result_elicitation', ''); + try + Assert.AreEqual(200, Response.GetValue('httpStatus')); + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.AreEqual('elicitation/create', Response.GetValue('result.inputRequests.user_name.method')); + Assert.AreEqual('What is your name?', Response.GetValue('result.inputRequests.user_name.params.message')); + Assert.AreEqual('name', Response.GetValue('result.inputRequests.user_name.params.requestedSchema.required[0]')); + Assert.IsNull(Response.FindValue('result.requestState')); + Assert.IsNull(Response.FindValue('result.ttlMs'), 'cache hints only on complete results'); + Assert.IsNotNull((Response.FindValue('result._meta') as TJSONObject).GetValue(MCP_META_SERVER_INFO)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_RoundTwo_Completes; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}}}'); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.AreEqual('Hello, Alice!', ResultText(Response)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_WrongKey_ReRequests; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"wrong_key":{"action":"accept","content":{"data":"wrong"}}}'); + try + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.IsNotNull(Response.FindValue('result.inputRequests.user_name')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_ExtraKeys_AreIgnored; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}},"unknown_extra_key":{"action":"accept","content":{}}}'); + try + Assert.AreEqual('Hello, Alice!', ResultText(Response)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.InputResponses_NotObject_IsInvalidParams; +begin + var Response := CallTool('test_input_required_result_elicitation', '"inputResponses":null'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.InputResponses_ValueNotObject_IsInvalidParams; +begin + var Response := CallTool('test_input_required_result_elicitation', '"inputResponses":{"user_name":12345}'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Sampling_RoundTrip; +begin + var First := CallTool('test_input_required_result_sampling', ''); + try + Assert.AreEqual('sampling/createMessage', First.GetValue('result.inputRequests.capital_question.method')); + Assert.AreEqual('What is the capital of France?', + First.GetValue('result.inputRequests.capital_question.params.messages[0].content.text')); + Assert.AreEqual(100, First.GetValue('result.inputRequests.capital_question.params.maxTokens')); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_sampling', + '"inputResponses":{"capital_question":{"role":"assistant","content":{"type":"text","text":"Paris"},"model":"m","stopReason":"endTurn"}}'); + try + Assert.AreEqual('LLM response: Paris', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.ListRoots_RoundTrip; +begin + var First := CallTool('test_input_required_result_list_roots', ''); + try + Assert.AreEqual('roots/list', First.GetValue('result.inputRequests.client_roots.method')); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_list_roots', + '"inputResponses":{"client_roots":{"roots":[{"uri":"file:///test/root","name":"Test Root"}]}}'); + try + Assert.AreEqual('Roots: file:///test/root', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_RoundTrip_MentionsStateOk; +begin + var First := CallTool('test_input_required_result_request_state', ''); + var Token := ''; + try + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.confirm.method')); + Assert.AreEqual('boolean', First.GetValue('result.inputRequests.confirm.params.requestedSchema.properties.ok.type')); + Token := First.GetValue('result.requestState'); + Assert.IsTrue(Token <> ''); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_request_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s"', [Token])); + try + Assert.AreEqual('complete', Second.GetValue('result.resultType')); + Assert.IsTrue(ResultText(Second).Contains('state-ok'), ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_Tampered_IsInvalidParams; +begin + var First := CallTool('test_input_required_result_tampered_state', ''); + var Token := ''; + try + Token := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_tampered_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s-TAMPERED"', [Token])); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Second.GetValue('error.code')); + Assert.AreEqual(200, Second.GetValue('httpStatus')); + finally + Second.Free; + end; + + var Third := CallTool('test_input_required_result_tampered_state', + '"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":42'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Third.GetValue('error.code')); + finally + Third.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_OtherTool_IsInvalidParams; +begin + var First := CallTool('test_input_required_result_request_state', ''); + var Token := ''; + try + Token := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_tampered_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s"', [Token])); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Second.GetValue('error.code')); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.MultipleInputs_RoundTrip; +begin + var First := CallTool('test_input_required_result_multiple_inputs', ''); + var Token := ''; + try + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.user_name.method')); + Assert.AreEqual('sampling/createMessage', First.GetValue('result.inputRequests.greeting.method')); + Assert.AreEqual('roots/list', First.GetValue('result.inputRequests.client_roots.method')); + Token := First.GetValue('result.requestState'); + Assert.IsTrue(Token <> ''); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_multiple_inputs', Format( + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}},' + + '"greeting":{"role":"assistant","content":{"type":"text","text":"Hello there"}},' + + '"client_roots":{"roots":[{"uri":"file:///test/root"}]}},"requestState":"%s"', [Token])); + try + Assert.AreEqual('Hello there, Alice! Roots: file:///test/root', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.MultiRound_StateChangesPerRound; +begin + var First := CallTool('test_input_required_result_multi_round', ''); + var Token1 := ''; + try + Assert.IsNotNull(First.FindValue('result.inputRequests.step1')); + Token1 := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_multi_round', + Format('"inputResponses":{"step1":{"action":"accept","content":{"name":"Alice"}}},"requestState":"%s"', [Token1])); + var Token2 := ''; + try + Assert.AreEqual('input_required', Second.GetValue('result.resultType')); + Assert.IsNotNull(Second.FindValue('result.inputRequests.step2')); + Assert.IsNull(Second.FindValue('result.inputRequests.step1')); + Token2 := Second.GetValue('result.requestState'); + Assert.AreNotEqual(Token1, Token2); + finally + Second.Free; + end; + + var Third := CallTool('test_input_required_result_multi_round', + Format('"inputResponses":{"step2":{"action":"accept","content":{"color":"blue"}}},"requestState":"%s"', [Token2])); + try + Assert.AreEqual('Hello, Alice! Your favorite color is blue.', ResultText(Third)); + finally + Third.Free; + end; +end; + +procedure TInputRequiredFlowTests.Capabilities_OnlyDeclaredKinds; +begin + var Response := CallTool('test_input_required_result_capabilities', '', '{"sampling":{}}'); + try + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.IsNotNull(Response.FindValue('result.inputRequests.capital_question')); + Assert.IsNull(Response.FindValue('result.inputRequests.user_name')); + Assert.IsNull(Response.FindValue('result.inputRequests.client_roots')); + finally + Response.Free; + end; + + var None := CallTool('test_input_required_result_capabilities', '', '{}'); + try + Assert.AreEqual('complete', None.GetValue('result.resultType')); + finally + None.Free; + end; +end; + +procedure TInputRequiredFlowTests.Capabilities_UndeclaredKind_Is32021; +begin + var Response := CallTool('test_input_required_result_elicitation', '', '{"sampling":{}}'); + try + Assert.AreEqual(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, Response.GetValue('error.code')); + Assert.AreEqual(400, Response.GetValue('httpStatus')); + Assert.IsNotNull(Response.FindValue('error.data.requiredCapabilities.elicitation')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.MissingCapabilityTool_Is32021_WithRequiredCapabilities; +begin + var Response := CallTool('test_missing_capability', '', '{"elicitation":{}}'); + try + Assert.AreEqual(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, Response.GetValue('error.code')); + Assert.AreEqual(400, Response.GetValue('httpStatus')); + Assert.IsTrue(Response.FindValue('error.data.requiredCapabilities.sampling') is TJSONObject); + finally + Response.Free; + end; + + var Declared := CallTool('test_missing_capability', '', '{"sampling":{}}'); + try + Assert.AreEqual('complete', Declared.GetValue('result.resultType')); + finally + Declared.Free; + end; +end; + +procedure TInputRequiredFlowTests.Legacy_IsInternalError; +begin + var Response := CallLegacy('test_input_required_result_elicitation'); + try + Assert.AreEqual(JSONRPC_INTERNAL_ERROR, Response.GetValue('error.code')); + Assert.IsTrue(Response.GetValue('error.message').Contains('2025-11-25')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Prompt_RoundTrip; +begin + var First := Call('prompts/get', '"name":"test_input_required_result_prompt"'); + try + Assert.AreEqual('input_required', First.GetValue('result.resultType')); + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.user_context.method')); + Assert.AreEqual('context', First.GetValue('result.inputRequests.user_context.params.requestedSchema.required[0]')); + finally + First.Free; + end; + + var Second := Call('prompts/get', + '"name":"test_input_required_result_prompt","inputResponses":{"user_context":{"action":"accept","content":{"context":"test context"}}}'); + try + Assert.AreEqual('complete', Second.GetValue('result.resultType')); + Assert.AreEqual('Use this context: test context', Second.GetValue('result.messages[0].content.text')); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.ToolsList_IsNeverInputRequired; +begin + var Response := Call('tools/list', '"inputResponses":{"x":{}},"requestState":"ignored"'); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + finally + Response.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas new file mode 100644 index 0000000..17fc875 --- /dev/null +++ b/tests/MCPServer.Tests.Processor.pas @@ -0,0 +1,362 @@ +unit MCPServer.Tests.Processor; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + System.JSON, + System.Rtti, + MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + TProbeManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx) + public + SeenContext: IMCPRequestContext; + SeenCurrent: IMCPRequestContext; + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + end; + + [TestFixture] + TProcessorTests = class + private + FHarness: TMCPTestHarness; + FSettings: TMCPSettings; + FProcessor: TMCPJsonRpcProcessor; + function Run(const RequestJson: string; const Hints: TMCPTransportHints): TMCPProcessResult; + function Parse(const Body: string): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Modern_UnknownMethod_Is404; + [Test] procedure Legacy_UnknownMethod_Is200; + [Test] procedure ParseError_ModernHeader_Is400_LegacyIs200; + [Test] procedure Modern_MetaValidationError_Is400; + [Test] procedure Modern_ApplicationInvalidParams_Is200; + [Test] procedure Modern_ToolsList_HasEnvelopeAndCacheHints; + [Test] procedure Modern_ToolsCall_HasResultTypeButNoCacheHints; + [Test] procedure Modern_Discover_ListsModernVersionsAndCapabilities; + [Test] procedure Modern_Discover_ListsLegacyVersions_WhenConfigured; + [Test] procedure Modern_ServerInfo_UsesSettings; + [Test] procedure Legacy_Initialize_NegotiatesAndDeclaresCapabilities; + [Test] procedure Legacy_Result_IsUntouched; + [Test] procedure Notification_Returns202WithoutBody; + [Test] procedure ClientResponse_Legacy_IsIgnored_Modern_IsRejected; + [Test] procedure ErrorData_IsEmitted; + [Test] procedure Current_IsSetDuringDispatch_AndClearedAfter; + [Test] procedure Concurrent_Initialize_AllSucceed; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + System.Threading, + MCPServer.ManagerRegistry, + MCPServer.Errors; + +const + META = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + +{ TProbeManager } + +function TProbeManager.GetCapabilityName: string; +begin + Result := 'probe'; +end; + +function TProbeManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = 'probe/run'; +end; + +function TProbeManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, nil); +end; + +function TProbeManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + SeenContext := Context; + SeenCurrent := TMCPRequestContext.Current; + Result := TValue.From(TJSONObject.Create); +end; + +{ TProcessorTests } + +procedure TProcessorTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FSettings := FHarness.Settings; + FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FSettings); +end; + +procedure TProcessorTests.TearDown; +begin + FProcessor.Free; + FHarness.Free; +end; + +function TProcessorTests.Run(const RequestJson: string; const Hints: TMCPTransportHints): TMCPProcessResult; +begin + Result := FProcessor.ProcessRequestEx(RequestJson, Hints); +end; + +function TProcessorTests.Parse(const Body: string): TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Body) as TJSONObject; + Assert.IsNotNull(Result, 'response is not a JSON object: ' + Body); +end; + +procedure TProcessorTests.Modern_UnknownMethod_Is404; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"totally/bogus/method","params":{' + META + '}}', TMCPTransportHints.None); + Assert.AreEqual(404, Outcome.HttpStatus); + Assert.AreEqual(TMCPProtocolEra.Modern, Outcome.Era); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual(JSONRPC_METHOD_NOT_FOUND, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Legacy_UnknownMethod_Is200; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"totally/bogus/method"}', TMCPTransportHints.ForHttp(True, '2025-06-18')); + Assert.AreEqual(200, Outcome.HttpStatus); + Assert.AreEqual(TMCPProtocolEra.Legacy, Outcome.Era); +end; + +procedure TProcessorTests.ParseError_ModernHeader_Is400_LegacyIs200; +begin + Assert.AreEqual(400, Run('{not json', TMCPTransportHints.ForHttp(True, '2026-07-28')).HttpStatus); + Assert.AreEqual(200, Run('{not json', TMCPTransportHints.ForHttp(True, '2025-06-18')).HttpStatus); + Assert.AreEqual(200, Run('{not json', TMCPTransportHints.None).HttpStatus); +end; + +procedure TProcessorTests.Modern_MetaValidationError_Is400; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}', TMCPTransportHints.None); + Assert.AreEqual(400, Outcome.HttpStatus); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Modern_ApplicationInvalidParams_Is200; +begin + var Probe := TProbeManager.Create; + var Registry: IMCPManagerRegistry := TMCPManagerRegistry.Create; + Registry.RegisterManager(Probe); + var Processor := TMCPJsonRpcProcessor.Create(Registry, FSettings); + try + Probe.SeenContext := nil; + var Outcome := Processor.ProcessRequestEx('{"jsonrpc":"2.0","id":1,"method":"probe/run","params":{' + META + '}}', TMCPTransportHints.None); + Assert.AreEqual(200, Outcome.HttpStatus); + finally + Processor.Free; + end; +end; + +procedure TProcessorTests.Modern_ToolsList_HasEnvelopeAndCacheHints; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{' + META + '}}', TMCPTransportHints.None); + Assert.AreEqual(200, Outcome.HttpStatus); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.AreEqual('delphi-mcp-server', Response.GetValue('result._meta["io.modelcontextprotocol/serverInfo"].name')); + Assert.AreEqual(0, Response.GetValue('result.ttlMs')); + Assert.AreEqual('private', Response.GetValue('result.cacheScope')); + Assert.IsNotNull(Response.FindValue('result.tools')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Modern_ToolsCall_HasResultTypeButNoCacheHints; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hi"},' + META + '}}', TMCPTransportHints.None); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.IsNull(Response.FindValue('result.ttlMs')); + Assert.IsNull(Response.FindValue('result.cacheScope')); + Assert.AreEqual('Echo: hi', Response.GetValue('result.content[0].text')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Modern_Discover_ListsModernVersionsAndCapabilities; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":"d","method":"server/discover","params":{' + META + '}}', TMCPTransportHints.None); + Assert.AreEqual(200, Outcome.HttpStatus); + var Response := Parse(Outcome.Body); + try + var Versions := Response.FindValue('result.supportedVersions') as TJSONArray; + Assert.AreEqual(1, Versions.Count); + Assert.AreEqual('2026-07-28', Versions.Items[0].Value); + Assert.IsTrue(Response.GetValue('result.capabilities.tools.listChanged')); + Assert.IsTrue(Response.GetValue('result.capabilities.resources.subscribe')); + Assert.IsNull(Response.FindValue('result.capabilities.logging')); + Assert.AreEqual('public', Response.GetValue('result.cacheScope')); + Assert.AreEqual(0, Response.GetValue('result.ttlMs')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Modern_Discover_ListsLegacyVersions_WhenConfigured; +begin + FSettings.DiscoverListsLegacyVersions := True; + var Outcome := Run('{"jsonrpc":"2.0","id":"d","method":"server/discover","params":{' + META + '}}', TMCPTransportHints.None); + var Response := Parse(Outcome.Body); + try + var Versions := Response.FindValue('result.supportedVersions') as TJSONArray; + Assert.AreEqual(3, Versions.Count); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Modern_ServerInfo_UsesSettings; +begin + FSettings.ServerTitle := 'Test Server'; + FSettings.ServerWebsiteUrl := 'https://example.com'; + FSettings.Instructions := 'Use the echo tool.'; + var Outcome := Run('{"jsonrpc":"2.0","id":"d","method":"server/discover","params":{' + META + '}}', TMCPTransportHints.None); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual('Test Server', Response.GetValue('result._meta["io.modelcontextprotocol/serverInfo"].title')); + Assert.AreEqual('https://example.com', Response.GetValue('result._meta["io.modelcontextprotocol/serverInfo"].websiteUrl')); + Assert.AreEqual('Use the echo tool.', Response.GetValue('result.instructions')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Legacy_Initialize_NegotiatesAndDeclaresCapabilities; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-11-25","capabilities":{"roots":{}},"clientInfo":{"name":"c","version":"1"}}}', TMCPTransportHints.None); + Assert.AreEqual(200, Outcome.HttpStatus); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual('2025-11-25', Response.GetValue('result.protocolVersion')); + Assert.IsFalse(Response.GetValue('result.capabilities.tools.listChanged')); + Assert.IsNull(Response.FindValue('result.sessionId')); + Assert.IsNull(Response.FindValue('result.capabilities.tools.supportsProgress')); + Assert.IsNull(Response.FindValue('result.resultType')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Legacy_Result_IsUntouched; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"tools/list"}', TMCPTransportHints.None); + var Response := Parse(Outcome.Body); + try + Assert.IsNull(Response.FindValue('result.resultType')); + Assert.IsNull(Response.FindValue('result._meta')); + Assert.IsNull(Response.FindValue('result.ttlMs')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Notification_Returns202WithoutBody; +begin + var Outcome := Run('{"jsonrpc":"2.0","method":"notifications/initialized"}', TMCPTransportHints.None); + Assert.AreEqual('', Outcome.Body); + Assert.AreEqual(202, Outcome.HttpStatus); + Assert.IsTrue(Outcome.IsNotification); +end; + +procedure TProcessorTests.ClientResponse_Legacy_IsIgnored_Modern_IsRejected; +begin + var Legacy := Run('{"jsonrpc":"2.0","id":1,"result":{}}', TMCPTransportHints.None); + Assert.AreEqual('', Legacy.Body); + Assert.AreEqual(202, Legacy.HttpStatus); + + var Modern := Run('{"jsonrpc":"2.0","id":1,"result":{}}', TMCPTransportHints.ForHttp(True, '2026-07-28')); + Assert.AreEqual(400, Modern.HttpStatus); + Assert.IsTrue(Modern.Body.Contains('-32600')); +end; + +procedure TProcessorTests.ErrorData_IsEmitted; +begin + var Outcome := Run('{"jsonrpc":"2.0","id":7,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2030-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}', TMCPTransportHints.None); + Assert.AreEqual(400, Outcome.HttpStatus); + var Response := Parse(Outcome.Body); + try + Assert.AreEqual(7, Response.GetValue('id')); + Assert.AreEqual(MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION, Response.GetValue('error.code')); + Assert.AreEqual('2030-01-01', Response.GetValue('error.data.requested')); + Assert.AreEqual('2026-07-28', Response.GetValue('error.data.supported[0]')); + finally + Response.Free; + end; +end; + +procedure TProcessorTests.Current_IsSetDuringDispatch_AndClearedAfter; +begin + var Probe := TProbeManager.Create; + var Registry: IMCPManagerRegistry := TMCPManagerRegistry.Create; + Registry.RegisterManager(Probe); + var Processor := TMCPJsonRpcProcessor.Create(Registry, FSettings); + try + Processor.ProcessRequestEx('{"jsonrpc":"2.0","id":"x","method":"probe/run","params":{' + META + '}}', TMCPTransportHints.None); + + Assert.IsNotNull(Probe.SeenContext); + Assert.AreSame(Probe.SeenContext, Probe.SeenCurrent); + Assert.AreEqual('x', Probe.SeenContext.RequestId.AsText); + Assert.AreEqual(TMCPProtocolEra.Modern, Probe.SeenContext.Era); + Assert.IsNull(TMCPRequestContext.Current); + finally + Probe.SeenContext := nil; + Probe.SeenCurrent := nil; + Processor.Free; + end; +end; + +procedure TProcessorTests.Concurrent_Initialize_AllSucceed; +const + REQUESTS = 50; +begin + var Failures := 0; + var Tasks: TArray; + SetLength(Tasks, REQUESTS); + for var I := 0 to High(Tasks) do + Tasks[I] := TTask.Run( + procedure + begin + var Outcome := FProcessor.ProcessRequestEx( + '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"c","version":"1"}}}', + TMCPTransportHints.None); + if not Outcome.Body.Contains('"protocolVersion":"2025-06-18"') or Outcome.Body.Contains('"error"') then + AtomicIncrement(Failures); + end); + TTask.WaitForAll(Tasks); + + Assert.AreEqual(0, Failures); +end; + +end. diff --git a/tests/MCPServer.Tests.Prompt.pas b/tests/MCPServer.Tests.Prompt.pas new file mode 100644 index 0000000..5a37049 --- /dev/null +++ b/tests/MCPServer.Tests.Prompt.pas @@ -0,0 +1,205 @@ +unit MCPServer.Tests.Prompt; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.JSON, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Prompt.Base; + +type + TGreetingParams = class + private + FName: string; + FTone: string; + public + [SchemaDescription('Who to greet')] + property Name: string read FName write FName; + [Optional] + [SchemaDescription('Tone of voice')] + property Tone: string read FTone write FTone; + end; + + TGreetingPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TGreetingParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + [TestFixture] + TPromptMessagesTests = class + public + [Test] procedure AddText_ProducesOneMessage; + [Test] procedure ContentIsASingleObject_NotAnArray; + [Test] procedure Image_Audio_ResourceLink_Embedded_Blocks; + [Test] procedure WithAnnotations_AttachesToLastMessage; + [Test] procedure ToJson_ReturnsAClone; + end; + + [TestFixture] + TPromptBaseTests = class + public + [Test] procedure Arguments_DerivedFromRttiWithDescriptionAndRequired; + [Test] procedure Get_BuildsMessages_AndReturnsDescription; + [Test] procedure Get_MissingRequiredArgument_Raises; + end; + +implementation + +{ TGreetingPrompt } + +constructor TGreetingPrompt.Create; +begin + inherited; + FName := 'greeting'; + FDescription := 'Greets someone'; +end; + +function TGreetingPrompt.ExecuteWithParams(const Params: TGreetingParams; Messages: TMCPPromptMessages): string; +begin + var Tone := Params.Tone; + if Tone = '' then + Tone := 'friendly'; + Messages.AddText('user', Format('Write a %s greeting for %s.', [Tone, Params.Name])); + Result := 'Greeting request'; +end; + +{ TPromptMessagesTests } + +procedure TPromptMessagesTests.AddText_ProducesOneMessage; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hello'); + var Json := Messages.ToJson; + try + Assert.AreEqual(1, Json.Count); + Assert.AreEqual('user', Json.Items[0].GetValue('role')); + Assert.AreEqual('text', Json.Items[0].GetValue('content.type')); + Assert.AreEqual('hello', Json.Items[0].GetValue('content.text')); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.ContentIsASingleObject_NotAnArray; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hi'); + var Json := Messages.ToJson; + try + Assert.IsTrue((Json.Items[0] as TJSONObject).GetValue('content') is TJSONObject, + 'prompts/get content is one object per message, not an array'); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.Image_Audio_ResourceLink_Embedded_Blocks; +begin + var Messages := TMCPPromptMessages.Create + .AddImage('user', TEncoding.UTF8.GetBytes('png'), 'image/png') + .AddAudio('assistant', 'AAAA', 'audio/wav') + .AddResourceLink('user', 'file:///a.txt', 'a.txt', 'A file', 'text/plain') + .AddEmbeddedText('user', 'test://x', 'text/plain', 'body'); + var Json := Messages.ToJson; + try + Assert.AreEqual(4, Json.Count); + Assert.AreEqual('image', Json.Items[0].GetValue('content.type')); + Assert.AreEqual('cG5n', Json.Items[0].GetValue('content.data')); + Assert.AreEqual('assistant', Json.Items[1].GetValue('role')); + Assert.AreEqual('audio', Json.Items[1].GetValue('content.type')); + Assert.AreEqual('resource_link', Json.Items[2].GetValue('content.type')); + Assert.AreEqual('A file', Json.Items[2].GetValue('content.description')); + Assert.AreEqual('resource', Json.Items[3].GetValue('content.type')); + Assert.AreEqual('body', Json.Items[3].GetValue('content.resource.text')); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.WithAnnotations_AttachesToLastMessage; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var Messages := TMCPPromptMessages.Create.AddText('user', 'first').AddText('user', 'second'); + Messages.WithAnnotations(Annotations); + var Json := Messages.ToJson; + try + Assert.IsNull(Json.Items[0].FindValue('content.annotations')); + Assert.AreEqual(0.5, Json.Items[1].GetValue('content.annotations.priority'), 0.0001); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.ToJson_ReturnsAClone; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hi'); + var First := Messages.ToJson; + var Second := Messages.ToJson; + try + Assert.AreNotSame(First, Second); + finally + First.Free; + Second.Free; + Messages.Free; + end; +end; + +{ TPromptBaseTests } + +procedure TPromptBaseTests.Arguments_DerivedFromRttiWithDescriptionAndRequired; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Args := Prompt.Arguments; + Assert.AreEqual(2, Integer(Length(Args))); + var NameArg := Args[0]; + var ToneArg := Args[1]; + Assert.AreEqual('name', NameArg.Name); + Assert.AreEqual('Who to greet', NameArg.Description); + Assert.IsTrue(NameArg.Required); + Assert.AreEqual('tone', ToneArg.Name); + Assert.IsFalse(ToneArg.Required); +end; + +procedure TPromptBaseTests.Get_BuildsMessages_AndReturnsDescription; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Arguments := TJSONObject.ParseJSONValue('{"name":"Ada"}') as TJSONObject; + var Messages := TMCPPromptMessages.Create; + try + var Description := Prompt.Get(Arguments, Messages); + Assert.AreEqual('Greeting request', Description); + var Json := Messages.ToJson; + try + Assert.AreEqual('Write a friendly greeting for Ada.', Json.Items[0].GetValue('content.text')); + finally + Json.Free; + end; + finally + Arguments.Free; + Messages.Free; + end; +end; + +procedure TPromptBaseTests.Get_MissingRequiredArgument_Raises; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Arguments := TJSONObject.Create; + var Messages := TMCPPromptMessages.Create; + try + var Call: TProc := procedure begin Prompt.Get(Arguments, Messages) end; + Assert.WillRaise(Call, EArgumentException); + finally + Arguments.Free; + Messages.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.PromptsManager.pas b/tests/MCPServer.Tests.PromptsManager.pas new file mode 100644 index 0000000..ffa1ebe --- /dev/null +++ b/tests/MCPServer.Tests.PromptsManager.pas @@ -0,0 +1,213 @@ +unit MCPServer.Tests.PromptsManager; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.Prompt.Base, + MCPServer.PromptsManager; + +type + TNoteParams = class + private + FText: string; + public + [SchemaDescription('The note text')] + property Text: string read FText write FText; + end; + + TNotePrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoteParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + [TestFixture] + TPromptsManagerTests = class + private + FManager: TMCPPromptsManager; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure List_IsInRegistrationOrder_WithArguments; + [Test] procedure List_CacheHints_ModernOnly; + [Test] procedure List_Cursor_IsInvalidParams; + [Test] procedure Get_MissingName_IsInvalidParams; + [Test] procedure Get_UnknownPrompt_IsInvalidParams_WithName; + [Test] procedure Get_MissingRequiredArgument_IsInvalidParams; + [Test] procedure Get_ReturnsDescriptionAndMessages; + [Test] procedure Get_ResultHasNoCacheHints; + end; + +implementation + +uses + System.Rtti, + System.SysUtils, + System.Generics.Collections, + MCPServer.Errors; + +{ TNotePrompt } + +constructor TNotePrompt.Create; +begin + inherited; + FName := 'note'; + FDescription := 'Wraps a note'; +end; + +function TNotePrompt.ExecuteWithParams(const Params: TNoteParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', Params.Text); + Result := 'Note prompt'; +end; + +{ TPromptsManagerTests } + +procedure TPromptsManagerTests.Setup; +begin + FManager := TMCPPromptsManager.Create; + FManager.AddPrompt(TNotePrompt.Create); +end; + +procedure TPromptsManagerTests.TearDown; +begin + FManager.Free; +end; + +procedure TPromptsManagerTests.List_IsInRegistrationOrder_WithArguments; +begin + var Json := FManager.ListPrompts(nil, TMCPProtocolEra.Legacy).AsType; + try + var Prompts := Json.GetValue('prompts') as TJSONArray; + Assert.AreEqual('summarize_logs', Json.GetValue('prompts[0].name'), 'registration order'); + Assert.AreEqual('note', Prompts.Items[Prompts.Count - 1].GetValue('name')); + var NoteJson := Prompts.Items[Prompts.Count - 1] as TJSONObject; + Assert.AreEqual('text', NoteJson.GetValue('arguments[0].name')); + Assert.IsTrue(NoteJson.GetValue('arguments[0].required')); + finally + Json.Free; + end; +end; + +procedure TPromptsManagerTests.List_CacheHints_ModernOnly; +begin + FManager.ListTtlMs := 60000; + FManager.ListCacheScope := MCP_CACHE_SCOPE_PUBLIC; + + var Legacy := FManager.ListPrompts(nil, TMCPProtocolEra.Legacy).AsType; + var Modern := FManager.ListPrompts(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Legacy.GetValue('ttlMs')); + Assert.AreEqual(60000, Modern.GetValue('ttlMs')); + Assert.AreEqual('public', Modern.GetValue('cacheScope')); + finally + Legacy.Free; + Modern.Free; + end; +end; + +procedure TPromptsManagerTests.List_Cursor_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"cursor":"abc"}') as TJSONObject; + try + try + FManager.ListPrompts(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_MissingName_IsInvalidParams; +begin + try + FManager.GetPrompt(nil, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + +procedure TPromptsManagerTests.Get_UnknownPrompt_IsInvalidParams_WithName; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"nope"}') as TJSONObject; + try + try + FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.AreEqual('nope', (E.Data as TJSONObject).GetValue('name')); + end; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_MissingRequiredArgument_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note"}') as TJSONObject; + try + try + FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.IsTrue(E.Message.Contains('Missing required parameter "text"')); + end; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_ReturnsDescriptionAndMessages; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note","arguments":{"text":"hi"}}') as TJSONObject; + try + var Json := FManager.GetPrompt(Params, TMCPProtocolEra.Legacy).AsType; + try + Assert.AreEqual('Note prompt', Json.GetValue('description')); + Assert.AreEqual('hi', Json.GetValue('messages[0].content.text')); + finally + Json.Free; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_ResultHasNoCacheHints; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note","arguments":{"text":"hi"}}') as TJSONObject; + try + var Json := FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Json.GetValue('ttlMs'), 'prompts/get is not a cacheable result'); + Assert.IsNull(Json.GetValue('cacheScope')); + finally + Json.Free; + end; + finally + Params.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas new file mode 100644 index 0000000..c09df91 --- /dev/null +++ b/tests/MCPServer.Tests.Registration.pas @@ -0,0 +1,102 @@ +unit MCPServer.Tests.Registration; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TRegistryTests = class + public + [Test] procedure BuiltInTools_AreRegisteredFromInitialization; + [Test] procedure BuiltInResources_AreRegisteredFromInitialization; + [Test] procedure BuiltInPrompts_AreRegisteredFromInitialization; + [Test] procedure BuiltInResourceTemplates_AreRegisteredFromInitialization; + [Test] procedure ServerStatus_IsRegisteredByDefault; + [Test] procedure CreateTool_UnknownName_Raises; + [Test] procedure CreateResource_UnknownUri_Raises; + [Test] procedure CreateTool_ReturnsFreshInstances; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Registration, + MCPServer.Tool.Base; + +{ TRegistryTests } + +procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasTool('echo')); + Assert.IsTrue(TMCPRegistry.HasTool('get_time')); + Assert.IsTrue(TMCPRegistry.HasTool('list_files')); + Assert.IsTrue(TMCPRegistry.HasTool('calculate')); + Assert.AreEqual(26, Integer(Length(TMCPRegistry.GetToolNames))); +end; + +procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasResource('project://info')); + Assert.IsTrue(TMCPRegistry.HasResource('project://readme')); + Assert.IsTrue(TMCPRegistry.HasResource('logs://recent')); + Assert.IsTrue(TMCPRegistry.HasResource('server://status')); + Assert.AreEqual(6, Integer(Length(TMCPRegistry.GetResourceURIs))); +end; + +procedure TRegistryTests.BuiltInPrompts_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasPrompt('summarize_logs')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_simple_prompt')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_arguments')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_embedded_resource')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_image')); + Assert.AreEqual(6, Integer(Length(TMCPRegistry.GetPromptNames))); +end; + +procedure TRegistryTests.BuiltInResourceTemplates_AreRegisteredFromInitialization; +begin + Assert.AreEqual(2, Integer(Length(TMCPRegistry.GetResourceTemplateURIs))); + Assert.AreEqual('logs://{level}', TMCPRegistry.GetResourceTemplateURIs[0]); + Assert.AreEqual('test://template/{id}/data', TMCPRegistry.GetResourceTemplateURIs[1]); +end; + +procedure TRegistryTests.ServerStatus_IsRegisteredByDefault; +begin + var Status := TMCPRegistry.CreateResource('server://status'); + Assert.AreEqual('server://status', Status.URI); + Assert.AreEqual('server_status', Status.Name); +end; + +procedure TRegistryTests.CreateTool_UnknownName_Raises; +begin + var Probe: TProc := + procedure + begin + TMCPRegistry.CreateTool('no_such_tool'); + end; + Assert.WillRaise(Probe, Exception); +end; + +procedure TRegistryTests.CreateResource_UnknownUri_Raises; +begin + var Probe: TProc := + procedure + begin + TMCPRegistry.CreateResource('nope://missing'); + end; + Assert.WillRaise(Probe, Exception); +end; + +procedure TRegistryTests.CreateTool_ReturnsFreshInstances; +begin + var First: IMCPTool := TMCPRegistry.CreateTool('echo'); + var Second: IMCPTool := TMCPRegistry.CreateTool('echo'); + + Assert.AreEqual('echo', First.Name); + Assert.AreNotSame(First, Second); +end; + +end. diff --git a/tests/MCPServer.Tests.RequestContext.pas b/tests/MCPServer.Tests.RequestContext.pas new file mode 100644 index 0000000..942815d --- /dev/null +++ b/tests/MCPServer.Tests.RequestContext.pas @@ -0,0 +1,363 @@ +unit MCPServer.Tests.RequestContext; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + System.JSON, + MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + [TestFixture] + TRequestContextTests = class + private + FHarness: TMCPTestHarness; + FSettings: TMCPSettings; + FProcessor: TMCPJsonRpcProcessor; + FSession: TMCPLegacySession; + function Build(const RequestJson: string; const Hints: TMCPTransportHints): IMCPRequestContext; + procedure ExpectError(const RequestJson: string; const Hints: TMCPTransportHints; + ExpectedCode, ExpectedStatus: Integer; const Because: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Initialize_WithModernMeta_IsNotFound; + [Test] procedure Initialize_EchoesServedRevision; + [Test] procedure Initialize_UnknownRevision_AnswersLatestLegacy; + [Test] procedure ModernMeta_IsModern; + [Test] procedure ModernMeta_Http_HeaderMissing_IsHeaderMismatch; + [Test] procedure ModernMeta_Http_HeaderDiffers_IsHeaderMismatch; + [Test] procedure ModernMeta_Http_HeaderMatches_IsModern; + [Test] procedure ModernMeta_Http_NameHeader_IsDecodedAndCompared; + [Test] procedure ModernMeta_UnknownVersion_ListsSupported; + [Test] procedure ModernMeta_MissingClientCapabilities_IsInvalidParams; + [Test] procedure ModernMeta_ClientInfoNotObject_IsInvalidParams; + [Test] procedure ModernMeta_InvalidLogLevel_IsInvalidParams; + [Test] procedure ModernMeta_Ping_IsMethodNotFound; + [Test] procedure ModernMeta_Ping_LenientSetting_Allows; + [Test] procedure ModernMeta_LegacyOnlyMethods_AreNotFound; + [Test] procedure ModernOnlyMethod_WithoutMeta_IsInvalidParams; + [Test] procedure Http_ModernHeader_WithoutMeta_IsInvalidParams; + [Test] procedure Http_UnknownHeaderVersion_IsInvalidRequest; + [Test] procedure Http_LegacyHeader_IsLegacyWithHeaderVersion; + [Test] procedure Http_NoHeader_NoMeta_IsLegacy; + [Test] procedure Stdio_SessionVersion_IsUsedForLegacyRequests; + [Test] procedure Stdio_NoSessionVersion_IsLatestLegacy; + [Test] procedure LegacyMeta_WithProgressTokenOnly_IsLegacy; + [Test] procedure Meta_NotAnObject_IsInvalidParams; + [Test] procedure ClientCapabilities_AreReadable; + [Test] procedure RequireClientCapability_RaisesMissingCapability; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors; + +const + META_MODERN = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28",' + + '"io.modelcontextprotocol/clientCapabilities":{"elicitation":{"form":{}}},' + + '"io.modelcontextprotocol/clientInfo":{"name":"ctx-client","version":"2.0"},' + + '"io.modelcontextprotocol/logLevel":"info"}'; + +function Request(const Method: string; const ParamsJson: string = ''): string; +begin + if ParamsJson = '' then + Result := Format('{"jsonrpc":"2.0","id":1,"method":"%s"}', [Method]) + else + Result := Format('{"jsonrpc":"2.0","id":1,"method":"%s","params":%s}', [Method, ParamsJson]); +end; + +{ TRequestContextTests } + +procedure TRequestContextTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FSettings := FHarness.Settings; + FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FSettings); + FSession := TMCPLegacySession.Create; +end; + +procedure TRequestContextTests.TearDown; +begin + FSession.Free; + FProcessor.Free; + FHarness.Free; +end; + +function TRequestContextTests.Build(const RequestJson: string; const Hints: TMCPTransportHints): IMCPRequestContext; +begin + var Message := TJSONObject.ParseJSONValue(RequestJson) as TJSONObject; + try + var Method := Message.GetValue('method').Value; + var Params := Message.GetValue('params') as TJSONObject; + var RequestId := TMCPRequestId.FromJson(Message.GetValue('id')); + Result := FProcessor.BuildRequestContext(Method, Params, RequestId, Hints); + finally + Message.Free; + end; +end; + +procedure TRequestContextTests.ExpectError(const RequestJson: string; const Hints: TMCPTransportHints; + ExpectedCode, ExpectedStatus: Integer; const Because: string); +begin + try + Build(RequestJson, Hints); + Assert.Fail('expected EMCPError ' + ExpectedCode.ToString + ': ' + Because); + except + on E: EMCPError do + begin + Assert.AreEqual(ExpectedCode, E.Code, Because + ' (code)'); + Assert.AreEqual(ExpectedStatus, E.HttpStatus, Because + ' (http status)'); + end; + end; +end; + +procedure TRequestContextTests.Initialize_WithModernMeta_IsNotFound; +begin + ExpectError(Request('initialize', '{"protocolVersion":"2025-11-25",' + META_MODERN + '}'), TMCPTransportHints.None, + JSONRPC_METHOD_NOT_FOUND, 404, 'initialize is legacy-only'); + + var Context := Build(Request('initialize', '{"protocolVersion":"2025-11-25","_meta":{"progressToken":"p"}}'), TMCPTransportHints.None); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); + Assert.AreEqual('2025-11-25', Context.ProtocolVersion); +end; + +procedure TRequestContextTests.Initialize_EchoesServedRevision; +begin + Assert.AreEqual('2025-06-18', Build(Request('initialize', '{"protocolVersion":"2025-06-18"}'), TMCPTransportHints.None).ProtocolVersion); + Assert.AreEqual('2025-11-25', Build(Request('initialize', '{"protocolVersion":"2025-11-25"}'), TMCPTransportHints.None).ProtocolVersion); +end; + +procedure TRequestContextTests.Initialize_UnknownRevision_AnswersLatestLegacy; +begin + Assert.AreEqual('2025-11-25', Build(Request('initialize', '{"protocolVersion":"2025-03-26"}'), TMCPTransportHints.None).ProtocolVersion); + Assert.AreEqual('2025-11-25', Build(Request('initialize', '{"protocolVersion":"1900-01-01"}'), TMCPTransportHints.None).ProtocolVersion); + Assert.AreEqual('2025-11-25', Build(Request('initialize'), TMCPTransportHints.None).ProtocolVersion); +end; + +procedure TRequestContextTests.ModernMeta_IsModern; +begin + var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.None); + + Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); + Assert.AreEqual('2026-07-28', Context.ProtocolVersion); + Assert.AreEqual('tools/list', Context.Method); + Assert.IsNotNull(Context.ClientCapabilities); + Assert.AreEqual('ctx-client', Context.ClientInfo.GetValue('name').Value); + Assert.AreEqual('info', Context.LogLevel); +end; + +procedure TRequestContextTests.ModernMeta_Http_HeaderMissing_IsHeaderMismatch; +begin + ExpectError(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.ForHttp(False, ''), + MCP_ERROR_HEADER_MISMATCH, 400, 'modern body without MCP-Protocol-Version header'); +end; + +procedure TRequestContextTests.ModernMeta_Http_HeaderDiffers_IsHeaderMismatch; +begin + ExpectError(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.ForHttp(True, '2025-11-25'), + MCP_ERROR_HEADER_MISMATCH, 400, 'header differs from _meta'); +end; + +procedure TRequestContextTests.ModernMeta_Http_HeaderMatches_IsModern; +begin + var Hints := TMCPTransportHints.ForHttp(True, '2026-07-28'); + Hints.HasMethodHeader := True; + Hints.MethodHeader := 'tools/list'; + var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), Hints); + Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); + + Hints.MethodHeader := 'TOOLS/LIST'; + ExpectError(Request('tools/list', '{' + META_MODERN + '}'), Hints, + MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Method differs from the body'); + + Hints.HasMethodHeader := False; + ExpectError(Request('tools/list', '{' + META_MODERN + '}'), Hints, + MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Method is required on modern HTTP requests'); +end; + +procedure TRequestContextTests.ModernMeta_Http_NameHeader_IsDecodedAndCompared; +begin + var Hints := TMCPTransportHints.ForHttp(True, '2026-07-28'); + Hints.HasMethodHeader := True; + Hints.MethodHeader := 'resources/read'; + var Body := Request('resources/read', '{"uri":"file:///caf' + #$00E9 + '.txt",' + META_MODERN + '}'); + + ExpectError(Body, Hints, MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Name is required for resources/read'); + + Hints.HasNameHeader := True; + Hints.NameHeader := 'file:///cafe.txt'; + ExpectError(Body, Hints, MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Name differs from params.uri'); + + Hints.NameHeader := '=?base64?ZmlsZTovLy9jYWbDqS50eHQ=?='; + var Context := Build(Body, Hints); + Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); + + Hints.NameHeader := '=?base64?not base64?='; + ExpectError(Body, Hints, MCP_ERROR_HEADER_MISMATCH, 400, 'malformed sentinel value'); +end; + +procedure TRequestContextTests.ModernMeta_UnknownVersion_ListsSupported; +begin + var Body := Request('tools/list', '{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}'); + try + Build(Body, TMCPTransportHints.None); + Assert.Fail('expected unsupported version'); + except + on E: EMCPError do + begin + Assert.AreEqual(MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION, E.Code); + Assert.AreEqual(400, E.HttpStatus); + var Data := E.Data as TJSONObject; + Assert.AreEqual('1900-01-01', Data.GetValue('requested').Value); + var Supported := Data.GetValue('supported') as TJSONArray; + Assert.AreEqual(1, Supported.Count); + Assert.AreEqual('2026-07-28', Supported.Items[0].Value); + end; + end; +end; + +procedure TRequestContextTests.ModernMeta_MissingClientCapabilities_IsInvalidParams; +begin + ExpectError(Request('tools/list', '{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}'), + TMCPTransportHints.None, JSONRPC_INVALID_PARAMS, 400, 'clientCapabilities is required'); + ExpectError(Request('tools/list', '{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":"yes"}}'), + TMCPTransportHints.None, JSONRPC_INVALID_PARAMS, 400, 'clientCapabilities must be an object'); +end; + +procedure TRequestContextTests.ModernMeta_ClientInfoNotObject_IsInvalidParams; +begin + ExpectError(Request('tools/list', '{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},"io.modelcontextprotocol/clientInfo":"me"}}'), + TMCPTransportHints.None, JSONRPC_INVALID_PARAMS, 400, 'clientInfo must be an object'); +end; + +procedure TRequestContextTests.ModernMeta_InvalidLogLevel_IsInvalidParams; +begin + ExpectError(Request('tools/list', '{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},"io.modelcontextprotocol/logLevel":"loud"}}'), + TMCPTransportHints.None, JSONRPC_INVALID_PARAMS, 400, 'logLevel outside the LoggingLevel set'); +end; + +procedure TRequestContextTests.ModernMeta_Ping_IsMethodNotFound; +begin + ExpectError(Request('ping', '{' + META_MODERN + '}'), TMCPTransportHints.None, + JSONRPC_METHOD_NOT_FOUND, 404, 'ping was removed in 2026-07-28'); +end; + +procedure TRequestContextTests.ModernMeta_Ping_LenientSetting_Allows; +begin + FSettings.LenientModernPing := True; + var Context := Build(Request('ping', '{' + META_MODERN + '}'), TMCPTransportHints.None); + Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); +end; + +procedure TRequestContextTests.ModernMeta_LegacyOnlyMethods_AreNotFound; +begin + for var Method in ['logging/setLevel', 'resources/subscribe', 'resources/unsubscribe'] do + ExpectError(Request(Method, '{' + META_MODERN + '}'), TMCPTransportHints.None, + JSONRPC_METHOD_NOT_FOUND, 404, Method + ' is legacy-only'); +end; + +procedure TRequestContextTests.ModernOnlyMethod_WithoutMeta_IsInvalidParams; +begin + ExpectError(Request('server/discover'), TMCPTransportHints.None, + JSONRPC_INVALID_PARAMS, 400, 'server/discover needs _meta'); + ExpectError(Request('subscriptions/listen', '{"subscriptions":[]}'), TMCPTransportHints.None, + JSONRPC_INVALID_PARAMS, 400, 'subscriptions/listen needs _meta'); +end; + +procedure TRequestContextTests.Http_ModernHeader_WithoutMeta_IsInvalidParams; +begin + ExpectError(Request('tools/list'), TMCPTransportHints.ForHttp(True, '2026-07-28'), + JSONRPC_INVALID_PARAMS, 400, 'modern header names a revision the body does not carry'); +end; + +procedure TRequestContextTests.Http_UnknownHeaderVersion_IsInvalidRequest; +begin + ExpectError(Request('tools/list'), TMCPTransportHints.ForHttp(True, '1900-01-01'), + JSONRPC_INVALID_REQUEST, 400, 'header version in neither set'); +end; + +procedure TRequestContextTests.Http_LegacyHeader_IsLegacyWithHeaderVersion; +begin + var Context := Build(Request('tools/list'), TMCPTransportHints.ForHttp(True, '2025-06-18')); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); + Assert.AreEqual('2025-06-18', Context.ProtocolVersion); + + Context := Build(Request('tools/list'), TMCPTransportHints.ForHttp(True, '2025-03-26')); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); +end; + +procedure TRequestContextTests.Http_NoHeader_NoMeta_IsLegacy; +begin + var Context := Build(Request('tools/list'), TMCPTransportHints.ForHttp(False, '')); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); + Assert.AreEqual('2025-11-25', Context.ProtocolVersion); +end; + +procedure TRequestContextTests.Stdio_SessionVersion_IsUsedForLegacyRequests; +begin + FSession.ProtocolVersion := '2025-06-18'; + var Context := Build(Request('tools/list'), TMCPTransportHints.ForStdio(FSession)); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); + Assert.AreEqual('2025-06-18', Context.ProtocolVersion); + Assert.AreSame(FSession, Context.LegacySession); +end; + +procedure TRequestContextTests.Stdio_NoSessionVersion_IsLatestLegacy; +begin + var Context := Build(Request('tools/list'), TMCPTransportHints.ForStdio(FSession)); + Assert.AreEqual('2025-11-25', Context.ProtocolVersion); +end; + +procedure TRequestContextTests.LegacyMeta_WithProgressTokenOnly_IsLegacy; +begin + var Context := Build(Request('tools/call', '{"name":"echo","arguments":{},"_meta":{"progressToken":"p1"}}'), TMCPTransportHints.None); + Assert.AreEqual(TMCPProtocolEra.Legacy, Context.Era); + Assert.AreEqual('p1', Context.ProgressToken.Value); + Assert.IsNull(Context.ClientCapabilities); +end; + +procedure TRequestContextTests.Meta_NotAnObject_IsInvalidParams; +begin + ExpectError(Request('tools/list', '{"_meta":5}'), TMCPTransportHints.None, + JSONRPC_INVALID_PARAMS, 400, '_meta must be an object'); +end; + +procedure TRequestContextTests.ClientCapabilities_AreReadable; +begin + var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.None); + + Assert.IsTrue(Context.HasClientCapability('elicitation')); + Assert.IsTrue(Context.HasClientCapability('elicitation.form')); + Assert.IsFalse(Context.HasClientCapability('elicitation.url')); + Assert.IsFalse(Context.HasClientCapability('sampling')); +end; + +procedure TRequestContextTests.RequireClientCapability_RaisesMissingCapability; +begin + var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.None); + try + Context.RequireClientCapability('sampling.tools'); + Assert.Fail('expected -32021'); + except + on E: EMCPError do + begin + Assert.AreEqual(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, E.Code); + Assert.AreEqual(400, E.HttpStatus); + var Required := (E.Data as TJSONObject).GetValue('requiredCapabilities') as TJSONObject; + Assert.IsNotNull((Required.GetValue('sampling') as TJSONObject).GetValue('tools')); + end; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.ResourcesManager.pas b/tests/MCPServer.Tests.ResourcesManager.pas new file mode 100644 index 0000000..1ee4d3e --- /dev/null +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -0,0 +1,382 @@ +unit MCPServer.Tests.ResourcesManager; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.Resource.Base, + MCPServer.ResourcesManager; + +type + TFailingData = class + end; + + TFailingResource = class(TMCPResourceBase) + protected + function GetResourceData: TFailingData; override; + public + constructor Create; override; + end; + + TEchoTemplateData = class + private + FValue: string; + public + property Value: string read FValue write FValue; + end; + + TEchoResource = class(TMCPResourceBase) + private + FValue: string; + protected + function GetResourceData: TEchoTemplateData; override; + public + constructor CreateForValue(const AUri, AValue: string); + end; + + TEchoTemplate = class(TMCPResourceTemplateBase) + public + constructor Create; override; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; override; + end; + + [TestFixture] + TResourcesManagerTests = class + private + FManager: TMCPResourcesManager; + function Read(const Uri: string; Era: TMCPProtocolEra): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Unknown_Modern_Is32602_WithUri; + [Test] procedure Unknown_Legacy_Is32002_WithUri; + [Test] procedure MissingUri_IsInvalidParams; + [Test] procedure ReadFailure_IsInternalError; + [Test] procedure Text_ReadsText; + [Test] procedure Binary_ReadsBlob; + [Test] procedure Read_CacheHints_ModernOnly_FromResource; + [Test] procedure List_HasMetadata_AndOmitsEmptyFields; + [Test] procedure List_CacheHints_ModernOnly; + [Test] procedure Templates_ListsRegisteredTemplates_WithHints; + [Test] procedure Templates_Cursor_IsInvalidParams; + [Test] procedure Read_ViaTemplate_ResolvesWithActualUri; + [Test] procedure Read_TemplateMismatch_IsNotFound; + [Test] procedure Read_ViaTemplate_PercentDecodes_KeepsPlusLiteral; + [Test] procedure Read_ViaTemplate_ConcurrentReads_Succeed; + [Test] procedure RemoveResourceTemplate_StopsMatching; + end; + +implementation + +uses + System.SysUtils, + System.Threading, + System.Generics.Collections, + MCPServer.Errors; + +{ TFailingResource } + +constructor TFailingResource.Create; +begin + inherited; + FURI := 'test://failing'; + FName := 'Failing'; + FMimeType := 'application/json'; +end; + +function TFailingResource.GetResourceData: TFailingData; +begin + raise Exception.Create('disk on fire'); +end; + +{ TEchoResource } + +constructor TEchoResource.CreateForValue(const AUri, AValue: string); +begin + inherited Create; + FURI := AUri; + FName := 'Echo'; + FMimeType := 'application/json'; + FValue := AValue; +end; + +function TEchoResource.GetResourceData: TEchoTemplateData; +begin + Result := TEchoTemplateData.Create; + Result.Value := FValue; +end; + +{ TEchoTemplate } + +constructor TEchoTemplate.Create; +begin + inherited; + FUriTemplate := 'echo://{value}'; + FName := 'Echo template'; + FDescription := 'Echoes the captured value'; + FMimeType := 'application/json'; +end; + +function TEchoTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TEchoResource.CreateForValue(URI, Vars['value']); +end; + +{ TResourcesManagerTests } + +procedure TResourcesManagerTests.Setup; +begin + FManager := TMCPResourcesManager.Create; + FManager.AddResource(TFailingResource.Create); + FManager.AddResourceTemplate(TEchoTemplate.Create); +end; + +procedure TResourcesManagerTests.TearDown; +begin + FManager.Free; +end; + +function TResourcesManagerTests.Read(const Uri: string; Era: TMCPProtocolEra): TJSONObject; +begin + var Params := TJSONObject.Create; + try + Params.AddPair('uri', Uri); + Result := FManager.ReadResource(Params, Era).AsType; + finally + Params.Free; + end; +end; + +procedure TResourcesManagerTests.Unknown_Modern_Is32602_WithUri; +begin + try + Read('test://missing', TMCPProtocolEra.Modern).Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.AreEqual('test://missing', (E.Data as TJSONObject).GetValue('uri')); + end; + end; +end; + +procedure TResourcesManagerTests.Unknown_Legacy_Is32002_WithUri; +begin + try + Read('test://missing', TMCPProtocolEra.Legacy).Free; + Assert.Fail('expected -32002'); + except + on E: EMCPError do + begin + Assert.AreEqual(MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY, E.Code); + Assert.AreEqual('test://missing', (E.Data as TJSONObject).GetValue('uri')); + end; + end; +end; + +procedure TResourcesManagerTests.MissingUri_IsInvalidParams; +begin + try + FManager.ReadResource(nil, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + +procedure TResourcesManagerTests.ReadFailure_IsInternalError; +begin + try + Read('test://failing', TMCPProtocolEra.Modern).Free; + Assert.Fail('expected -32603'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INTERNAL_ERROR, E.Code); + Assert.IsTrue(E.Message.Contains('disk on fire')); + end; + end; +end; + +procedure TResourcesManagerTests.Text_ReadsText; +begin + var Json := Read('test://static-text', TMCPProtocolEra.Legacy); + try + Assert.AreEqual('test://static-text', Json.GetValue('contents[0].uri')); + Assert.AreEqual('text/plain', Json.GetValue('contents[0].mimeType')); + Assert.IsTrue(Json.GetValue('contents[0].text').Contains('static text resource')); + Assert.IsNull(Json.FindValue('contents[0].blob')); + Assert.IsNull(Json.GetValue('ttlMs')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.Binary_ReadsBlob; +begin + var Json := Read('test://static-binary', TMCPProtocolEra.Modern); + try + Assert.AreEqual('image/png', Json.GetValue('contents[0].mimeType')); + Assert.IsTrue(Json.GetValue('contents[0].blob').StartsWith('iVBORw0KGgo')); + Assert.IsNull(Json.FindValue('contents[0].text')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.Read_CacheHints_ModernOnly_FromResource; +begin + var ProjectInfo := Read('project://info', TMCPProtocolEra.Modern); + var Logs := Read('logs://recent', TMCPProtocolEra.Modern); + try + Assert.AreEqual(3600000, ProjectInfo.GetValue('ttlMs')); + Assert.AreEqual('public', ProjectInfo.GetValue('cacheScope')); + Assert.AreEqual(0, Logs.GetValue('ttlMs')); + Assert.AreEqual('private', Logs.GetValue('cacheScope')); + finally + ProjectInfo.Free; + Logs.Free; + end; +end; + +procedure TResourcesManagerTests.List_HasMetadata_AndOmitsEmptyFields; +begin + var Json := FManager.ListResources(nil, TMCPProtocolEra.Legacy).AsType; + try + var Resources := Json.GetValue('resources') as TJSONArray; + Assert.AreEqual('server://status', Json.GetValue('resources[0].uri'), 'registration order'); + var Found := False; + for var Item in Resources do + if Item.GetValue('uri') = 'test://static-text' then + begin + Found := True; + Assert.AreEqual('Static text resource', Item.GetValue('title')); + end; + Assert.IsTrue(Found); + var Failing := Resources.Items[Resources.Count - 1] as TJSONObject; + Assert.AreEqual('test://failing', Failing.GetValue('uri')); + Assert.IsNull(Failing.GetValue('description'), 'empty description is omitted'); + Assert.IsNull(Failing.GetValue('title')); + Assert.IsNull(Failing.GetValue('size')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.List_CacheHints_ModernOnly; +begin + var Legacy := FManager.ListResources(nil, TMCPProtocolEra.Legacy).AsType; + var Modern := FManager.ListResources(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Legacy.GetValue('cacheScope')); + Assert.AreEqual(0, Modern.GetValue('ttlMs')); + Assert.AreEqual('private', Modern.GetValue('cacheScope')); + finally + Legacy.Free; + Modern.Free; + end; +end; + +procedure TResourcesManagerTests.Templates_ListsRegisteredTemplates_WithHints; +begin + var Modern := FManager.ListResourceTemplates(nil, TMCPProtocolEra.Modern).AsType; + try + var Templates := Modern.GetValue('resourceTemplates') as TJSONArray; + Assert.AreEqual('logs://{level}', Modern.GetValue('resourceTemplates[0].uriTemplate'), + 'the built-in template is listed first'); + var LastTemplate := Templates.Items[Templates.Count - 1] as TJSONObject; + Assert.AreEqual('echo://{value}', LastTemplate.GetValue('uriTemplate')); + Assert.AreEqual('Echo template', LastTemplate.GetValue('name')); + Assert.AreEqual('Echoes the captured value', LastTemplate.GetValue('description')); + Assert.AreEqual('application/json', LastTemplate.GetValue('mimeType')); + Assert.AreEqual('private', Modern.GetValue('cacheScope')); + finally + Modern.Free; + end; +end; + +procedure TResourcesManagerTests.Templates_Cursor_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"cursor":"abc"}') as TJSONObject; + try + try + FManager.ListResourceTemplates(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TResourcesManagerTests.Read_ViaTemplate_ResolvesWithActualUri; +begin + var Json := Read('echo://hello', TMCPProtocolEra.Modern); + try + Assert.AreEqual('echo://hello', Json.GetValue('contents[0].uri')); + Assert.AreEqual('application/json', Json.GetValue('contents[0].mimeType')); + Assert.AreEqual('{"value":"hello"}', Json.GetValue('contents[0].text')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.Read_ViaTemplate_PercentDecodes_KeepsPlusLiteral; +begin + var Json := Read('echo://a%20b+c%2Fd', TMCPProtocolEra.Modern); + try + Assert.AreEqual('{"value":"a b+c/d"}', Json.GetValue('contents[0].text')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.Read_ViaTemplate_ConcurrentReads_Succeed; +const + READS = 400; +begin + TParallel.For(1, READS, + procedure(Index: Integer) + begin + var Json := Read(Format('echo://item%d', [Index]), TMCPProtocolEra.Modern); + try + Assert.AreEqual(Format('{"value":"item%d"}', [Index]), Json.GetValue('contents[0].text')); + finally + Json.Free; + end; + end); +end; + +procedure TResourcesManagerTests.RemoveResourceTemplate_StopsMatching; +begin + FManager.RemoveResourceTemplate('echo://{value}'); + try + Read('echo://hello', TMCPProtocolEra.Modern).Free; + Assert.Fail('the template is gone'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + +procedure TResourcesManagerTests.Read_TemplateMismatch_IsNotFound; +begin + try + Read('echo://a/b', TMCPProtocolEra.Modern).Free; + Assert.Fail('expected -32602: {value} does not match a path with a slash'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Schema.pas b/tests/MCPServer.Tests.Schema.pas new file mode 100644 index 0000000..4705a44 --- /dev/null +++ b/tests/MCPServer.Tests.Schema.pas @@ -0,0 +1,273 @@ +unit MCPServer.Tests.Schema; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + MCPServer.Types; + +type + TLevel = (Low, Mid, High); + TLevels = set of TLevel; + + TPoint = class + private + FX: Integer; + FY: Integer; + public + property X: Integer read FX write FX; + property Y: Integer read FY write FY; + end; + + TSchemaParams = class + private + FCount: Integer; + FBig: Int64; + FRatio: Double; + FWhen: TDateTime; + FFlag: Boolean; + FLevel: TLevel; + FLevels: TLevels; + FNames: TArray; + FPoints: TList; + FOrigin: TPoint; + FCode: string; + FScore: Integer; + FTag: string; + public + [SchemaDescription('How many')] + [SchemaMinimum(1)] + [SchemaMaximum(10)] + property Count: Integer read FCount write FCount; + property Big: Int64 read FBig write FBig; + property Ratio: Double read FRatio write FRatio; + [SchemaTitle('When it happened')] + property When: TDateTime read FWhen write FWhen; + property Flag: Boolean read FFlag write FFlag; + property Level: TLevel read FLevel write FLevel; + property Levels: TLevels read FLevels write FLevels; + property Names: TArray read FNames write FNames; + property Points: TList read FPoints write FPoints; + property Origin: TPoint read FOrigin write FOrigin; + [Optional] + [SchemaFormat('uri')] + property Code: string read FCode write FCode; + [SchemaEnum('one', 'two')] + property Score: Integer read FScore write FScore; + [SchemaMinLength(2)] + [SchemaMaxLength(5)] + [SchemaPattern('^[a-z]+$')] + [SchemaDefault('"blue"')] + [SchemaName('colour_tag')] + property Tag: string read FTag write FTag; + end; + + TEmptyParams = class + end; + + [SchemaAdditionalProperties(False)] + [SchemaDialect('https://json-schema.org/draft/2020-12/schema')] + TStrictParams = class + private + FName: string; + public + property Name: string read FName write FName; + end; + + TWrapperParams = class + private + FStrict: TStrictParams; + public + property Strict: TStrictParams read FStrict write FStrict; + end; + + [TestFixture] + TSchemaGeneratorTests = class + public + [Test] procedure Integers_AreInteger_FloatsAreNumber; + [Test] procedure DateTime_IsStringWithFormat; + [Test] procedure Boolean_And_Enum; + [Test] procedure Set_IsArrayOfEnumNames; + [Test] procedure DynArray_And_List_HaveItems; + [Test] procedure NestedObject_HasProperties; + [Test] procedure Attributes_AreApplied; + [Test] procedure Optional_IsNotRequired; + [Test] procedure NoParameters_ForbidsAdditionalProperties; + [Test] procedure StringConstraints_AreApplied; + [Test] procedure SchemaName_OverridesPropertyName; + [Test] procedure ClassAttributes_AdditionalPropertiesAndDialect; + [Test] procedure Dialect_OnlyAppliesAtRoot; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Schema.Generator; + +{ TSchemaGeneratorTests } + +procedure TSchemaGeneratorTests.Integers_AreInteger_FloatsAreNumber; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('integer', Schema.GetValue('properties.count.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.big.type')); + Assert.AreEqual('number', Schema.GetValue('properties.ratio.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.DateTime_IsStringWithFormat; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('string', Schema.GetValue('properties.when.type')); + Assert.AreEqual('date-time', Schema.GetValue('properties.when.format')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Boolean_And_Enum; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('boolean', Schema.GetValue('properties.flag.type')); + Assert.AreEqual('string', Schema.GetValue('properties.level.type')); + Assert.AreEqual('Mid', Schema.GetValue('properties.level.enum[1]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Set_IsArrayOfEnumNames; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('array', Schema.GetValue('properties.levels.type')); + Assert.AreEqual('string', Schema.GetValue('properties.levels.items.type')); + Assert.AreEqual('High', Schema.GetValue('properties.levels.items.enum[2]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.DynArray_And_List_HaveItems; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('array', Schema.GetValue('properties.names.type')); + Assert.AreEqual('string', Schema.GetValue('properties.names.items.type')); + Assert.AreEqual('array', Schema.GetValue('properties.points.type')); + Assert.AreEqual('object', Schema.GetValue('properties.points.items.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.points.items.properties.x.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.NestedObject_HasProperties; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('object', Schema.GetValue('properties.origin.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.origin.properties.y.type')); + Assert.AreEqual('x', Schema.GetValue('properties.origin.required[0]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Attributes_AreApplied; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('How many', Schema.GetValue('properties.count.description')); + Assert.AreEqual(1, Schema.GetValue('properties.count.minimum')); + Assert.AreEqual(10, Schema.GetValue('properties.count.maximum')); + Assert.AreEqual('When it happened', Schema.GetValue('properties.when.title')); + Assert.AreEqual('uri', Schema.GetValue('properties.code.format')); + Assert.AreEqual('one', Schema.GetValue('properties.score.enum[0]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Optional_IsNotRequired; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + var Required := Schema.GetValue('required') as TJSONArray; + for var Item in Required do + Assert.AreNotEqual('code', Item.Value); + Assert.AreEqual('count', Required.Items[0].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.NoParameters_ForbidsAdditionalProperties; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TEmptyParams); + try + Assert.AreEqual(0, (Schema.GetValue('properties') as TJSONObject).Count); + Assert.IsFalse(Schema.GetValue('additionalProperties')); + Assert.IsNull(Schema.GetValue('required')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.StringConstraints_AreApplied; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual(2, Schema.GetValue('properties.colour_tag.minLength')); + Assert.AreEqual(5, Schema.GetValue('properties.colour_tag.maxLength')); + Assert.AreEqual('^[a-z]+$', Schema.GetValue('properties.colour_tag.pattern')); + Assert.AreEqual('blue', Schema.GetValue('properties.colour_tag.default')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.SchemaName_OverridesPropertyName; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.IsNull(Schema.FindValue('properties.tag'), 'the Pascal name is not used on the wire'); + Assert.IsNotNull(Schema.FindValue('properties.colour_tag')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.ClassAttributes_AdditionalPropertiesAndDialect; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TStrictParams); + try + Assert.IsFalse(Schema.GetValue('additionalProperties')); + Assert.AreEqual('https://json-schema.org/draft/2020-12/schema', Schema.GetValue('$schema')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Dialect_OnlyAppliesAtRoot; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TWrapperParams); + try + Assert.IsNull(Schema.GetValue('$schema'), 'the wrapper itself has no [SchemaDialect]'); + Assert.IsFalse(Schema.GetValue('properties.strict.additionalProperties'), + 'a class attribute applies wherever the class is used'); + Assert.IsNull(Schema.FindValue('properties.strict.$schema'), '$schema is a root-only keyword'); + finally + Schema.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.SchemaValidator.pas b/tests/MCPServer.Tests.SchemaValidator.pas new file mode 100644 index 0000000..8747c02 --- /dev/null +++ b/tests/MCPServer.Tests.SchemaValidator.pas @@ -0,0 +1,297 @@ +unit MCPServer.Tests.SchemaValidator; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TSchemaValidatorTests = class + public + [Test] procedure Type_Mismatch_Fails; + [Test] procedure Type_Array_AcceptsEitherAlternative; + [Test] procedure Integer_RejectsFraction; + [Test] procedure Required_MissingProperty_Fails; + [Test] procedure Properties_RecurseIntoNestedObject; + [Test] procedure AdditionalProperties_False_RejectsExtraKey; + [Test] procedure Items_RecurseIntoArrayElements; + [Test] procedure MinimumMaximum_OutOfRange_Fails; + [Test] procedure MinLengthMaxLengthPattern_Fail; + [Test] procedure Enum_RejectsValueNotListed; + [Test] procedure Const_RejectsDifferentValue; + [Test] procedure Ref_ResolvesSameDocumentDefs; + [Test] procedure Ref_UnsupportedShape_IsAnError; + [Test] procedure Valid_Instance_HasNoErrors; + [Test] procedure ExcessiveNesting_IsAnError; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Schema.Validator; + +{ TSchemaValidatorTests } + +procedure TSchemaValidatorTests.Type_Mismatch_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"string"}') as TJSONObject; + var Instance := TJSONNumber.Create(1); + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.AreEqual(1, Integer(Length(Errors))); + Assert.IsTrue(Errors[0].Contains('expected string')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Type_Array_AcceptsEitherAlternative; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":["string","null"]}') as TJSONObject; + var TextInstance := TJSONString.Create('x'); + var NullInstance := TJSONNull.Create; + var NumberInstance := TJSONNumber.Create(1); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, TextInstance, Errors)); + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, NullInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, NumberInstance, Errors)); + finally + Schema.Free; + TextInstance.Free; + NullInstance.Free; + NumberInstance.Free; + end; +end; + +procedure TSchemaValidatorTests.Integer_RejectsFraction; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"integer"}') as TJSONObject; + var WholeInstance := TJSONNumber.Create(3); + var FractionInstance := TJSONNumber.Create(3.5); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, WholeInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, FractionInstance, Errors)); + finally + Schema.Free; + WholeInstance.Free; + FractionInstance.Free; + end; +end; + +procedure TSchemaValidatorTests.Required_MissingProperty_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"object","required":["a"]}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('missing required property "a"')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Properties_RecurseIntoNestedObject; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"child":{"type":"object","required":["x"]}}}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"child":{}}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('value.child')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.AdditionalProperties_False_RejectsExtraKey; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"a":{"type":"string"}},"additionalProperties":false}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"a":"x","b":1}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('unexpected property "b"')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Items_RecurseIntoArrayElements; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"array","items":{"type":"integer"}}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('[1,2,"x"]') as TJSONArray; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('value[2]')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.MinimumMaximum_OutOfRange_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"number","minimum":0,"maximum":10}') as TJSONObject; + var InRange := TJSONNumber.Create(5); + var BelowRange := TJSONNumber.Create(-1); + var AboveRange := TJSONNumber.Create(11); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, InRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, BelowRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, AboveRange, Errors)); + finally + Schema.Free; + InRange.Free; + BelowRange.Free; + AboveRange.Free; + end; +end; + +procedure TSchemaValidatorTests.MinLengthMaxLengthPattern_Fail; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"string","minLength":2,"maxLength":4,"pattern":"^[a-z]+$"}') as TJSONObject; + var Ok := TJSONString.Create('abc'); + var TooShort := TJSONString.Create('a'); + var TooLong := TJSONString.Create('abcde'); + var WrongPattern := TJSONString.Create('AB'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Ok, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, TooShort, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, TooLong, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, WrongPattern, Errors)); + finally + Schema.Free; + Ok.Free; + TooShort.Free; + TooLong.Free; + WrongPattern.Free; + end; +end; + +procedure TSchemaValidatorTests.Enum_RejectsValueNotListed; +begin + var Schema := TJSONObject.ParseJSONValue('{"enum":["a","b"]}') as TJSONObject; + var Allowed := TJSONString.Create('a'); + var NotAllowed := TJSONString.Create('c'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Allowed, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, NotAllowed, Errors)); + finally + Schema.Free; + Allowed.Free; + NotAllowed.Free; + end; +end; + +procedure TSchemaValidatorTests.Const_RejectsDifferentValue; +begin + var Schema := TJSONObject.ParseJSONValue('{"const":"fixed"}') as TJSONObject; + var SameValue := TJSONString.Create('fixed'); + var DifferentValue := TJSONString.Create('other'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, SameValue, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, DifferentValue, Errors)); + finally + Schema.Free; + SameValue.Free; + DifferentValue.Free; + end; +end; + +procedure TSchemaValidatorTests.Ref_ResolvesSameDocumentDefs; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"a":{"$ref":"#/$defs/Positive"}},' + + '"$defs":{"Positive":{"type":"integer","minimum":1}}}') as TJSONObject; + var Valid := TJSONObject.ParseJSONValue('{"a":5}') as TJSONObject; + var Invalid := TJSONObject.ParseJSONValue('{"a":0}') as TJSONObject; + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Valid, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Invalid, Errors)); + finally + Schema.Free; + Valid.Free; + Invalid.Free; + end; +end; + +procedure TSchemaValidatorTests.Ref_UnsupportedShape_IsAnError; +begin + var Schema := TJSONObject.ParseJSONValue('{"$ref":"https://example.com/schema.json"}') as TJSONObject; + var Instance := TJSONString.Create('x'); + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('unsupported $ref')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Valid_Instance_HasNoErrors; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","required":["name"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}}}') + as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"name":"a","age":3}') as TJSONObject; + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.AreEqual(0, Integer(Length(Errors))); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.ExcessiveNesting_IsAnError; +begin + var Schema := TJSONObject.Create; + var Instance := TJSONObject.Create; + try + var CurrentSchema := Schema; + var CurrentInstance := Instance; + for var I := 1 to TMCPSchemaValidator.MAX_DEPTH + 5 do + begin + CurrentSchema.AddPair('type', 'object'); + var ChildSchema := TJSONObject.Create; + var Properties := TJSONObject.Create; + Properties.AddPair('child', ChildSchema); + CurrentSchema.AddPair('properties', Properties); + var ChildInstance := TJSONObject.Create; + CurrentInstance.AddPair('child', ChildInstance); + CurrentSchema := ChildSchema; + CurrentInstance := ChildInstance; + end; + + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[Length(Errors) - 1].Contains('nested too deeply')); + finally + Schema.Free; + Instance.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Serializer.pas b/tests/MCPServer.Tests.Serializer.pas new file mode 100644 index 0000000..cc21dde --- /dev/null +++ b/tests/MCPServer.Tests.Serializer.pas @@ -0,0 +1,259 @@ +unit MCPServer.Tests.Serializer; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + MCPServer.Types; + +type + TColour = (Red, Green, Blue); + TColours = set of TColour; + + TNested = class + private + FLabel: string; + public + property Label_: string read FLabel write FLabel; + end; + + TSampleParams = class + private + FName: string; + FCount: Integer; + FRatio: Double; + FEnabled: Boolean; + FColour: TColour; + FWhen: TDateTime; + FTags: TArray; + FNested: TNested; + FNote: string; + public + destructor Destroy; override; + property Name: string read FName write FName; + property Count: Integer read FCount write FCount; + [Optional] property Ratio: Double read FRatio write FRatio; + [Optional] property Enabled: Boolean read FEnabled write FEnabled; + [Optional] property Colour: TColour read FColour write FColour; + [Optional] property When: TDateTime read FWhen write FWhen; + [Optional] property Tags: TArray read FTags write FTags; + [Optional] property Nested: TNested read FNested write FNested; + [Optional] property Note: string read FNote write FNote; + end; + + TRenamedParams = class + private + FDisplayName: string; + public + [SchemaName('display_name')] + property DisplayName: string read FDisplayName write FDisplayName; + end; + + TSampleResult = class + private + FColour: TColour; + FColours: TColours; + FValues: TArray; + FChild: TNested; + FStamp: TDateTime; + public + property Colour: TColour read FColour write FColour; + property Colours: TColours read FColours write FColours; + property Values: TArray read FValues write FValues; + property Child: TNested read FChild write FChild; + property Stamp: TDateTime read FStamp write FStamp; + end; + + [TestFixture] + TSerializerTests = class + private + function Deserialize(const Json: string): TSampleParams; + procedure ExpectArgumentError(const Json, Fragment: string); + public + [Test] procedure Deserialize_AllTypes; + [Test] procedure MissingRequired_Raises; + [Test] procedure Null_CountsAsAbsent; + [Test] procedure WrongType_String_Raises; + [Test] procedure WrongType_Integer_Raises; + [Test] procedure Fraction_ForInteger_Raises; + [Test] procedure WrongType_Boolean_Raises; + [Test] procedure UnknownParameter_Raises; + [Test] procedure Enum_ByName_AndInvalidRaises; + [Test] procedure Serialize_Enum_Set_Array_DateTime; + [Test] procedure Serialize_NilObject_IsNull; + [Test] procedure SchemaName_UsedForDeserializeAndSerialize; + end; + +implementation + +uses + System.SysUtils, + System.DateUtils, + System.JSON, + MCPServer.Serializer; + +{ TSampleParams } + +destructor TSampleParams.Destroy; +begin + FNested.Free; + inherited; +end; + +{ TSerializerTests } + +function TSerializerTests.Deserialize(const Json: string): TSampleParams; +begin + var Obj := TJSONObject.ParseJSONValue(Json) as TJSONObject; + try + Result := TMCPSerializer.Deserialize(Obj); + finally + Obj.Free; + end; +end; + +procedure TSerializerTests.ExpectArgumentError(const Json, Fragment: string); +begin + try + Deserialize(Json).Free; + Assert.Fail('expected EArgumentException for ' + Json); + except + on E: EArgumentException do + Assert.IsTrue(E.Message.Contains(Fragment), E.Message + ' does not mention ' + Fragment); + end; +end; + +procedure TSerializerTests.Deserialize_AllTypes; +begin + var Params := Deserialize('{"name":"n","count":3,"ratio":1.5,"enabled":true,"colour":"Green",' + + '"when":"2026-09-03T10:00:00Z","tags":["a","b"],"nested":{"label_":"x"}}'); + try + Assert.AreEqual('n', Params.Name); + Assert.AreEqual(3, Params.Count); + Assert.AreEqual(1.5, Params.Ratio, 0.0001); + Assert.IsTrue(Params.Enabled); + Assert.AreEqual(Green, Params.Colour); + Assert.AreEqual(2026, YearOf(Params.When)); + Assert.AreEqual(2, Integer(Length(Params.Tags))); + Assert.AreEqual('x', Params.Nested.Label_); + finally + Params.Free; + end; +end; + +procedure TSerializerTests.MissingRequired_Raises; +begin + ExpectArgumentError('{"name":"n"}', 'Missing required parameter "count"'); + ExpectArgumentError('{}', 'Missing required parameter "name"'); +end; + +procedure TSerializerTests.Null_CountsAsAbsent; +begin + ExpectArgumentError('{"name":null,"count":1}', 'Missing required parameter "name"'); + var Params := Deserialize('{"name":"n","count":1,"note":null}'); + try + Assert.AreEqual('', Params.Note); + finally + Params.Free; + end; +end; + +procedure TSerializerTests.WrongType_String_Raises; +begin + ExpectArgumentError('{"name":5,"count":1}', 'Parameter "name": expected a string'); +end; + +procedure TSerializerTests.WrongType_Integer_Raises; +begin + ExpectArgumentError('{"name":"n","count":"two"}', 'Parameter "count": expected an integer'); +end; + +procedure TSerializerTests.Fraction_ForInteger_Raises; +begin + ExpectArgumentError('{"name":"n","count":1.5}', 'expected an integer'); +end; + +procedure TSerializerTests.WrongType_Boolean_Raises; +begin + ExpectArgumentError('{"name":"n","count":1,"enabled":"yes"}', 'expected a boolean'); +end; + +procedure TSerializerTests.UnknownParameter_Raises; +begin + ExpectArgumentError('{"name":"n","count":1,"bogus":1}', 'Unknown parameter "bogus"'); +end; + +procedure TSerializerTests.Enum_ByName_AndInvalidRaises; +begin + var Params := Deserialize('{"name":"n","count":1,"colour":"Blue"}'); + try + Assert.AreEqual(Blue, Params.Colour); + finally + Params.Free; + end; + ExpectArgumentError('{"name":"n","count":1,"colour":"Purple"}', 'Valid values: Red, Green, Blue'); +end; + +procedure TSerializerTests.Serialize_Enum_Set_Array_DateTime; +begin + var Value := TSampleResult.Create; + var Json := TJSONObject.Create; + try + Value.Colour := Blue; + Value.Colours := [Red, Blue]; + Value.Values := [1, 2, 3]; + Value.Child := TNested.Create; + Value.Child.Label_ := 'c'; + Value.Stamp := EncodeDateTime(2026, 9, 3, 10, 30, 0, 0); + TMCPSerializer.Serialize(Value, Json); + + Assert.AreEqual('Blue', Json.GetValue('colour')); + Assert.AreEqual('Red', Json.GetValue('colours[0]')); + Assert.AreEqual('Blue', Json.GetValue('colours[1]')); + Assert.AreEqual(3, (Json.GetValue('values') as TJSONArray).Count); + Assert.AreEqual('c', Json.GetValue('child.label_')); + Assert.IsTrue(Json.GetValue('stamp').StartsWith('2026-09-03T10:30:00')); + finally + Value.Child.Free; + Value.Free; + Json.Free; + end; +end; + +procedure TSerializerTests.Serialize_NilObject_IsNull; +begin + var Value := TSampleResult.Create; + var Json := TJSONObject.Create; + try + TMCPSerializer.Serialize(Value, Json); + Assert.IsTrue(Json.GetValue('child') is TJSONNull); + Assert.AreEqual(0, (Json.GetValue('values') as TJSONArray).Count); + finally + Value.Free; + Json.Free; + end; +end; + +procedure TSerializerTests.SchemaName_UsedForDeserializeAndSerialize; +begin + var Json := TJSONObject.ParseJSONValue('{"display_name":"Ada"}') as TJSONObject; + var Params := TMCPSerializer.Deserialize(Json); + try + Assert.AreEqual('Ada', Params.DisplayName); + + var OutJson := TJSONObject.Create; + try + TMCPSerializer.Serialize(Params, OutJson); + Assert.AreEqual('Ada', OutJson.GetValue('display_name')); + Assert.IsNull(OutJson.GetValue('displayname')); + finally + OutJson.Free; + end; + finally + Json.Free; + Params.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.ServerStatus.pas b/tests/MCPServer.Tests.ServerStatus.pas new file mode 100644 index 0000000..1df4212 --- /dev/null +++ b/tests/MCPServer.Tests.ServerStatus.pas @@ -0,0 +1,124 @@ +unit MCPServer.Tests.ServerStatus; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TServerStatusResourceTests = class + private + procedure ReadCounters(out RequestCount: Int64; out ActiveConnections: Integer); + public + [Setup] + procedure Setup; + + [Test] procedure Counters_StartAtZero; + [Test] procedure Counters_AreExactUnderConcurrentUpdates; + [Test] procedure ConnectionClosed_NeverGoesBelowZero; + [Test] procedure Read_ProducesJsonWithStatusFields; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + System.JSON, + System.Threading, + MCPServer.Resource.Base, + MCPServer.Resource.Server; + +const + THREAD_COUNT = 8; + ITERATIONS_PER_THREAD = 20000; + +{ TServerStatusResourceTests } + +procedure TServerStatusResourceTests.Setup; +begin + TServerStatusResource.Initialize; +end; + +procedure TServerStatusResourceTests.ReadCounters(out RequestCount: Int64; out ActiveConnections: Integer); +begin + var Resource: IMCPResource := TServerStatusResource.Create; + var Status := TJSONObject.ParseJSONValue(Resource.Read) as TJSONObject; + try + Assert.IsNotNull(Status, 'server://status must return a JSON object'); + RequestCount := Status.GetValue('requestcount'); + ActiveConnections := Status.GetValue('activeconnections'); + finally + Status.Free; + end; +end; + +procedure TServerStatusResourceTests.Counters_StartAtZero; +begin + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(Int64(0), RequestCount); + Assert.AreEqual(0, ActiveConnections); +end; + +procedure TServerStatusResourceTests.Counters_AreExactUnderConcurrentUpdates; +begin + var Tasks: TArray; + SetLength(Tasks, THREAD_COUNT); + for var I := 0 to High(Tasks) do + Tasks[I] := TTask.Run( + procedure + begin + for var J := 1 to ITERATIONS_PER_THREAD do + begin + TServerStatusResource.ConnectionOpened; + TServerStatusResource.IncrementRequestCount; + TServerStatusResource.ConnectionClosed; + end; + end); + TTask.WaitForAll(Tasks); + + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(Int64(THREAD_COUNT) * ITERATIONS_PER_THREAD, RequestCount, 'lost request increments'); + Assert.AreEqual(0, ActiveConnections, 'every opened connection was closed'); +end; + +procedure TServerStatusResourceTests.ConnectionClosed_NeverGoesBelowZero; +begin + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionOpened; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(0, ActiveConnections); +end; + +procedure TServerStatusResourceTests.Read_ProducesJsonWithStatusFields; +begin + var Resource: IMCPResource := TServerStatusResource.Create; + Assert.AreEqual('server://status', Resource.URI); + Assert.AreEqual('application/json', Resource.MimeType); + + var Status := TJSONObject.ParseJSONValue(Resource.Read) as TJSONObject; + try + Assert.IsNotNull(Status); + Assert.AreEqual('running', Status.GetValue('status')); + Assert.IsNotNull(Status.GetValue('uptime')); + Assert.IsNotNull(Status.GetValue('memoryused')); + finally + Status.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Stdio.pas b/tests/MCPServer.Tests.Stdio.pas new file mode 100644 index 0000000..31f6a4f --- /dev/null +++ b/tests/MCPServer.Tests.Stdio.pas @@ -0,0 +1,334 @@ +unit MCPServer.Tests.Stdio; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types, + MCPServer.StdioTransport, + MCPServer.Tests.Harness; + +type + [TestFixture] + TStdioTransportTests = class + private + FHarness: TMCPTestHarness; + FOutputBytes: TBytes; + FElapsedMs: Int64; + function Run(const Lines: array of string; DrainMs: Integer = TMCPStdioTransport.DEFAULT_SHUTDOWN_DRAIN_MS; + const Separator: string = #10): TArray; + function ParseLine(const Line: string): TJSONObject; + function FindById(const Lines: TArray; const Id: string): TJSONObject; + function FindNotification(const Lines: TArray; const Method: string): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Handshake_And_ToolsList; + [Test] procedure Utf8_RoundTrip_LfFraming_NoBom; + [Test] procedure CrLf_Input_IsAccepted; + [Test] procedure InvalidJson_IsParseError_WithNullId; + [Test] procedure Notification_ProducesNoOutput; + [Test] procedure DuplicateId_WhileInFlight_IsInvalidRequest; + [Test] procedure Cancelled_GetsNoResponse_PingIsStillAnswered; + [Test] procedure Progress_IsSentBeforeTheResponse; + [Test] procedure ModernRequest_OverStdio; + [Test] procedure Eof_WithRunningRequest_ReturnsAfterDrain; + [Test] procedure Listen_AckThenCancel_HasNoResponse; + [Test] procedure Listen_Eof_ClosesGracefully; + end; + +implementation + +uses + System.Diagnostics; + +const + INITIALIZE = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"t","version":"1"}}}'; + INITIALIZED = '{"jsonrpc":"2.0","method":"notifications/initialized"}'; + +{ TStdioTransportTests } + +procedure TStdioTransportTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TStdioTransportTests.TearDown; +begin + FHarness.Free; +end; + +function TStdioTransportTests.Run(const Lines: array of string; DrainMs: Integer; + const Separator: string): TArray; +begin + var Input := ''; + for var Line in Lines do + Input := Input + Line + Separator; + + var InputStream := TBytesStream.Create(TEncoding.UTF8.GetBytes(Input)); + var OutputStream := TBytesStream.Create; + var Transport := TMCPStdioTransport.Create(FHarness.ManagerRegistry, FHarness.CoreManager); + try + Transport.Settings := FHarness.Settings; + Transport.ShutdownDrainMs := DrainMs; + var Watch := TStopwatch.StartNew; + Transport.RunWith(InputStream, OutputStream); + FElapsedMs := Watch.ElapsedMilliseconds; + + FOutputBytes := Copy(OutputStream.Bytes, 0, OutputStream.Size); + Result := TEncoding.UTF8.GetString(FOutputBytes).Split([#10], TStringSplitOptions.ExcludeEmpty); + finally + Transport.Free; + OutputStream.Free; + InputStream.Free; + end; +end; + +function TStdioTransportTests.ParseLine(const Line: string): TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Line) as TJSONObject; + Assert.IsNotNull(Result, 'stdout line is JSON: ' + Line); +end; + +function TStdioTransportTests.FindById(const Lines: TArray; const Id: string): TJSONObject; +begin + for var Line in Lines do + begin + var Json := ParseLine(Line); + var IdValue := Json.GetValue('id'); + if Assigned(IdValue) and (IdValue.Value = Id) then + Exit(Json); + Json.Free; + end; + Result := nil; +end; + +function TStdioTransportTests.FindNotification(const Lines: TArray; const Method: string): TJSONObject; +begin + for var Line in Lines do + begin + var Json := ParseLine(Line); + var MethodValue := Json.GetValue('method'); + if IsJsonString(MethodValue) and (TJSONString(MethodValue).Value = Method) then + Exit(Json); + Json.Free; + end; + Result := nil; +end; + +procedure TStdioTransportTests.Handshake_And_ToolsList; +begin + var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"tools/list"}']); + Assert.AreEqual(2, Integer(Length(Lines))); + var Init := FindById(Lines, '1'); + var Tools := FindById(Lines, '2'); + try + Assert.AreEqual('2025-06-18', Init.GetValue('result.protocolVersion')); + Assert.AreEqual('echo', Tools.GetValue('result.tools[0].name')); + finally + Init.Free; + Tools.Free; + end; +end; + +procedure TStdioTransportTests.Utf8_RoundTrip_LfFraming_NoBom; +begin + var Probe := 'h' + Char($00E9) + 'llo w' + Char($00F6) + 'rld ' + Char($D83D) + Char($DE00); + var Lines := Run([INITIALIZE, INITIALIZED, + '{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"' + Probe + '"}}}']); + var Echo := FindById(Lines, '3'); + try + Assert.AreEqual('Echo: ' + Probe, Echo.GetValue('result.content[0].text')); + finally + Echo.Free; + end; + Assert.AreEqual($7B, Integer(FOutputBytes[0]), 'no byte-order mark'); + Assert.AreEqual(10, Integer(FOutputBytes[High(FOutputBytes)]), 'ends with LF'); + for var B in FOutputBytes do + Assert.AreNotEqual(13, Integer(B), 'no CR on stdout'); +end; + +procedure TStdioTransportTests.CrLf_Input_IsAccepted; +begin + var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"ping"}'], 2000, #13#10); + var Pong := FindById(Lines, '2'); + try + Assert.IsNotNull(Pong); + Assert.IsNotNull(Pong.GetValue('result')); + finally + Pong.Free; + end; +end; + +procedure TStdioTransportTests.InvalidJson_IsParseError_WithNullId; +begin + var Lines := Run(['this is not json', '{"jsonrpc":"2.0","id":2,"method":"ping"}']); + Assert.AreEqual(2, Integer(Length(Lines))); + var Error := ParseLine(Lines[0]); + try + Assert.IsTrue(Error.GetValue('id') is TJSONNull); + Assert.AreEqual(JSONRPC_PARSE_ERROR, Error.GetValue('error.code')); + finally + Error.Free; + end; +end; + +procedure TStdioTransportTests.Notification_ProducesNoOutput; +begin + var Lines := Run([INITIALIZED, '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":99}}']); + Assert.AreEqual(0, Integer(Length(Lines))); +end; + +procedure TStdioTransportTests.DuplicateId_WhileInFlight_IsInvalidRequest; +begin + var Slow := '{"jsonrpc":"2.0","id":7,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":4,"stepMs":100}}}'; + var Lines := Run([Slow, '{"jsonrpc":"2.0","id":7,"method":"ping"}']); + Lines := Run([Slow, Slow]); + Assert.AreEqual(2, Integer(Length(Lines))); + var First := ParseLine(Lines[0]); + var Second := ParseLine(Lines[1]); + try + Assert.AreEqual(JSONRPC_INVALID_REQUEST, First.GetValue('error.code'), 'the duplicate is refused at once'); + Assert.IsNotNull(Second.GetValue('result'), 'the first request still completes'); + finally + First.Free; + Second.Free; + end; +end; + +procedure TStdioTransportTests.Cancelled_GetsNoResponse_PingIsStillAnswered; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":50,"stepMs":100}}}', + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":5,"reason":"test"}}', + '{"jsonrpc":"2.0","id":6,"method":"ping"}']); + Assert.AreEqual(1, Integer(Length(Lines)), 'only the ping is answered'); + var Pong := FindById(Lines, '6'); + try + Assert.IsNotNull(Pong); + finally + Pong.Free; + end; + Assert.IsTrue(FElapsedMs < 3000, 'the cancelled tool stopped early: ' + FElapsedMs.ToString + ' ms'); +end; + +procedure TStdioTransportTests.Progress_IsSentBeforeTheResponse; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":8,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":80},"_meta":{"progressToken":"p1"}}}']); + Assert.IsTrue(Length(Lines) >= 4, 'at least three progress notifications and the response'); + + var LastProgress := -1.0; + var ProgressCount := 0; + for var I := 0 to High(Lines) do + begin + var Json := ParseLine(Lines[I]); + try + if I = High(Lines) then + begin + Assert.AreEqual('8', Json.GetValue('id').Value, 'the response comes last'); + Assert.AreEqual('Completed 3 steps', Json.GetValue('result.content[0].text')); + end + else + begin + Assert.AreEqual('notifications/progress', Json.GetValue('method')); + Assert.AreEqual('p1', Json.GetValue('params.progressToken')); + var Progress := Json.GetValue('params.progress'); + Assert.IsTrue(Progress > LastProgress, 'progress increases'); + LastProgress := Progress; + Inc(ProgressCount); + end; + finally + Json.Free; + end; + end; + Assert.IsTrue(ProgressCount >= 3); + Assert.AreEqual(3.0, LastProgress, 0.0001, 'the final notification reaches the total'); +end; + +procedure TStdioTransportTests.ModernRequest_OverStdio; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}']); + var Json := FindById(Lines, '1'); + try + Assert.AreEqual('complete', Json.GetValue('result.resultType')); + Assert.AreEqual(0, Json.GetValue('result.ttlMs')); + finally + Json.Free; + end; +end; + +procedure TStdioTransportTests.Eof_WithRunningRequest_ReturnsAfterDrain; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":100,"stepMs":100}}}'], + 300); + Assert.AreEqual(0, Integer(Length(Lines)), 'the request was cancelled at shutdown and got no response'); + Assert.IsTrue(FElapsedMs < 3000, 'Run returned after the drain timeout: ' + FElapsedMs.ToString + ' ms'); +end; + +procedure TStdioTransportTests.Listen_AckThenCancel_HasNoResponse; +const + LISTEN = '{"jsonrpc":"2.0","id":9,"method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + CANCEL = '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":9}}'; + PING = '{"jsonrpc":"2.0","id":10,"method":"ping"}'; +begin + var Lines := Run([LISTEN, PING, CANCEL]); + Assert.AreEqual(2, Integer(Length(Lines)), string.Join(' | ', Lines)); + var Ack := FindNotification(Lines, 'notifications/subscriptions/acknowledged'); + try + Assert.IsNotNull(Ack, 'the subscription is acknowledged'); + Assert.AreEqual(9, TJSONNumber(TJSONObject(Ack.FindValue('params._meta')).GetValue(MCP_META_SUBSCRIPTION_ID)).AsInt); + Assert.IsTrue(Ack.GetValue('params.notifications.toolsListChanged')); + finally + Ack.Free; + end; + var Pong := FindById(Lines, '10'); + try + Assert.IsNotNull(Pong, 'ping is answered while a subscription is open'); + finally + Pong.Free; + end; + var Response := FindById(Lines, '9'); + Assert.IsNull(Response, 'a cancelled subscription gets no response'); +end; + +procedure TStdioTransportTests.Listen_Eof_ClosesGracefully; +const + LISTEN = '{"jsonrpc":"2.0","id":9,"method":"subscriptions/listen","params":{"notifications":{"promptsListChanged":true},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + TRIGGER = '{"jsonrpc":"2.0","id":11,"method":"tools/call","params":{"name":"test_trigger_prompt_change","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + SLOW = '{"jsonrpc":"2.0","id":10,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":100}}}'; +begin + var Lines := Run([LISTEN, SLOW, TRIGGER]); + Assert.IsTrue(Length(Lines) >= 4, string.Join(' | ', Lines)); + var Ack := FindNotification(Lines, 'notifications/subscriptions/acknowledged'); + try + Assert.IsNotNull(Ack, 'the subscription is acknowledged'); + finally + Ack.Free; + end; + var Changed := False; + for var Line in Lines do + begin + if Line.Contains('"notifications/prompts/list_changed"') then + Changed := True; + end; + Assert.IsTrue(Changed, 'the prompt change reached the subscription'); + var Response := FindById(Lines, '9'); + try + Assert.IsNotNull(Response, 'stdin closing ends the subscription with a response'); + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.AreEqual(9, TJSONNumber(TJSONObject(Response.FindValue('result._meta')).GetValue(MCP_META_SUBSCRIPTION_ID)).AsInt); + finally + Response.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.StdioChannel.pas b/tests/MCPServer.Tests.StdioChannel.pas new file mode 100644 index 0000000..d837b72 --- /dev/null +++ b/tests/MCPServer.Tests.StdioChannel.pas @@ -0,0 +1,233 @@ +unit MCPServer.Tests.StdioChannel; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + MCPServer.Types, + MCPServer.StdioChannel; + +type + [TestFixture] + TStdioChannelTests = class + private + function ReadAll(const Bytes: TBytes; MaxLineBytes: Integer; out Statuses: TArray): TArray; + public + [Test] procedure Reader_SplitsOnLf_DropsCr_LastLineWithoutNewline; + [Test] procedure Reader_SkipsByteOrderMark; + [Test] procedure Reader_DecodesUtf8; + [Test] procedure Reader_ReportsOverlongLine_AndContinues; + [Test] procedure Reader_ReportsInvalidUtf8_AndContinues; + [Test] procedure Reader_OverlongLineWithoutNewline_EndsStream; + [Test] procedure Reader_OverlongLineBeyondChunk_IsSkippedUpToNewline; + [Test] procedure Reader_EmptyStream_HasNoLines; + [Test] procedure Writer_OneLinePerMessage_Utf8_NoBom; + [Test] procedure Writer_ReplacesEmbeddedNewlines; + [Test] procedure Writer_ConcurrentSends_DoNotInterleave; + end; + +implementation + +uses + System.SyncObjs, + System.Generics.Collections; + +{ TStdioChannelTests } + +function TStdioChannelTests.ReadAll(const Bytes: TBytes; MaxLineBytes: Integer; + out Statuses: TArray): TArray; +var + Line: string; + Status: TMCPLineStatus; +begin + Result := nil; + Statuses := nil; + var Stream := TBytesStream.Create(Bytes); + var Reader := TMCPLineReader.Create(Stream, MaxLineBytes); + try + while Reader.ReadLine(Line, Status) do + begin + Result := Result + [Line]; + Statuses := Statuses + [Status]; + end; + finally + Reader.Free; + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Reader_SplitsOnLf_DropsCr_LastLineWithoutNewline; +var + Statuses: TArray; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes('one'#13#10'two'#10#10'three'), 1024, Statuses); + Assert.AreEqual(4, Integer(Length(Lines))); + Assert.AreEqual('one', Lines[0]); + Assert.AreEqual('two', Lines[1]); + Assert.AreEqual('', Lines[2]); + Assert.AreEqual('three', Lines[3]); + for var Status in Statuses do + Assert.IsTrue(Status = TMCPLineStatus.Ok); +end; + +procedure TStdioChannelTests.Reader_SkipsByteOrderMark; +var + Statuses: TArray; +begin + var Bytes := TBytes.Create($EF, $BB, $BF) + TEncoding.UTF8.GetBytes('{"a":1}'#10); + var Lines := ReadAll(Bytes, 1024, Statuses); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.AreEqual('{"a":1}', Lines[0]); +end; + +procedure TStdioChannelTests.Reader_DecodesUtf8; +var + Statuses: TArray; +begin + var Probe := 'h' + Char($00E9) + 'llo w' + Char($00F6) + 'rld ' + Char($D83D) + Char($DE00); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Probe + #10), 1024, Statuses); + Assert.AreEqual(Probe, Lines[0]); +end; + +procedure TStdioChannelTests.Reader_ReportsOverlongLine_AndContinues; +var + Statuses: TArray; +begin + var Long := StringOfChar('x', 100); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'short'#10), 50, Statuses); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0]); + Assert.IsTrue(Statuses[1] = TMCPLineStatus.Ok); + Assert.AreEqual('short', Lines[1]); +end; + +procedure TStdioChannelTests.Reader_OverlongLineWithoutNewline_EndsStream; +var + Statuses: TArray; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes(StringOfChar('x', 100)), 50, Statuses); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0]); +end; + +procedure TStdioChannelTests.Reader_OverlongLineBeyondChunk_IsSkippedUpToNewline; +const + BEYOND_ONE_CHUNK = 70 * 1024; + LIMIT = 1024; +var + Statuses: TArray; +begin + var Long := StringOfChar('y', BEYOND_ONE_CHUNK); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'after'#10'last'), LIMIT, Statuses); + Assert.AreEqual(3, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.IsTrue(Statuses[1] = TMCPLineStatus.Ok); + Assert.AreEqual('after', Lines[1]); + Assert.IsTrue(Statuses[2] = TMCPLineStatus.Ok); + Assert.AreEqual('last', Lines[2]); +end; + +procedure TStdioChannelTests.Reader_ReportsInvalidUtf8_AndContinues; +var + Statuses: TArray; +begin + var Bytes := TBytes.Create($FF, $FE, $41) + TEncoding.UTF8.GetBytes(#10'ok'#10); + var Lines := ReadAll(Bytes, 1024, Statuses); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.InvalidUtf8, 'first line is not UTF-8'); + Assert.AreEqual('ok', Lines[1]); +end; + +procedure TStdioChannelTests.Reader_EmptyStream_HasNoLines; +var + Statuses: TArray; +begin + var Lines := ReadAll(nil, 1024, Statuses); + Assert.AreEqual(0, Integer(Length(Lines))); +end; + +procedure TStdioChannelTests.Writer_OneLinePerMessage_Utf8_NoBom; +begin + var Stream := TMemoryStream.Create; + try + var SinkIntf: IMCPMessageSink := TMCPLineWriter.Create(Stream); + SinkIntf.Send('{"a":"' + Char($00E9) + '"}'); + SinkIntf.Send('{"b":2}'); + + var Bytes: TBytes; + SetLength(Bytes, Stream.Size); + Move(Stream.Memory^, Bytes[0], Length(Bytes)); + Assert.AreEqual($7B, Integer(Bytes[0]), 'no byte-order mark'); + var Text := TEncoding.UTF8.GetString(Bytes); + Assert.AreEqual('{"a":"' + Char($00E9) + '"}'#10'{"b":2}'#10, Text); + Assert.IsFalse(Text.Contains(#13)); + finally + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Writer_ReplacesEmbeddedNewlines; +begin + var Stream := TMemoryStream.Create; + try + var SinkIntf: IMCPMessageSink := TMCPLineWriter.Create(Stream); + SinkIntf.Send('a'#13#10'b'); + var Bytes: TBytes; + SetLength(Bytes, Stream.Size); + Move(Stream.Memory^, Bytes[0], Length(Bytes)); + Assert.AreEqual('a b'#10, TEncoding.UTF8.GetString(Bytes)); + finally + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Writer_ConcurrentSends_DoNotInterleave; +const + THREADS = 4; + MESSAGES_PER_THREAD = 200; +begin + var Stream := TMemoryStream.Create; + var Done := TCountdownEvent.Create(THREADS); + try + var SinkIntf: IMCPMessageSink := TMCPLineWriter.Create(Stream); + for var T := 1 to THREADS do + begin + var ThreadNo := T; + TThread.CreateAnonymousThread( + procedure + begin + try + for var I := 1 to MESSAGES_PER_THREAD do + SinkIntf.Send('{"thread":' + ThreadNo.ToString + ',"payload":"' + StringOfChar('x', 300) + '"}'); + finally + Done.Signal; + end; + end).Start; + end; + Assert.IsTrue(Done.WaitFor(10000) = TWaitResult.wrSignaled); + + var Bytes: TBytes; + SetLength(Bytes, Stream.Size); + Move(Stream.Memory^, Bytes[0], Length(Bytes)); + var Lines := TEncoding.UTF8.GetString(Bytes).Split([#10]); + var Count := 0; + for var Line in Lines do + begin + if Line = '' then + Continue; + Inc(Count); + Assert.IsTrue(Line.StartsWith('{"thread":') and Line.EndsWith('"}'), 'intact line: ' + Line); + Assert.AreEqual(Length('{"thread":1,"payload":"' + StringOfChar('x', 300) + '"}'), Length(Line)); + end; + Assert.AreEqual(THREADS * MESSAGES_PER_THREAD, Count); + finally + Done.Free; + Stream.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Subscriptions.pas b/tests/MCPServer.Tests.Subscriptions.pas new file mode 100644 index 0000000..a3128ce --- /dev/null +++ b/tests/MCPServer.Tests.Subscriptions.pas @@ -0,0 +1,458 @@ +unit MCPServer.Tests.Subscriptions; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.SyncObjs, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.SubscriptionsManager; + +type + TLockedSink = class(TInterfacedObject, IMCPMessageSink, IMCPKeepAlive) + strict private + FLock: TCriticalSection; + FMessages: TStringList; + FKeepAlives: Integer; + public + constructor Create; + destructor Destroy; override; + procedure Send(const Json: string); + procedure KeepAlive; + function Messages: TArray; + function Count: Integer; + property KeepAlives: Integer read FKeepAlives; + end; + + TRecordingHub = class(TInterfacedObject, IMCPSubscriptionHub) + public + Events: TStringList; + constructor Create; + destructor Destroy; override; + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + end; + + [TestFixture] + TSubscriptionsTests = class + private + FManager: TMCPSubscriptionsManager; + FManagerRef: IInterface; + FSink: TLockedSink; + FSinkRef: IMCPMessageSink; + FContext: IMCPRequestContext; + FResult: TJSONObject; + FError: string; + FThread: TThread; + procedure StartListen(const ParamsJson: string); + procedure WaitUntilOpen; + procedure JoinListen; + function Parse(const Json: string): TJSONObject; + function SubscriptionIdOf(const Json: TJSONObject; const MetaPath: string): Integer; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Filter_FromJson_HonoursBooleansAndUris; + [Test] procedure Listen_AckFirst_ThenTaggedNotifications_ThenCompletion; + [Test] procedure Listen_UnrequestedNotifications_AreNotSent; + [Test] procedure Listen_Cancel_EndsTheWait; + [Test] procedure Listen_KeepAlive_OnInterval; + [Test] procedure Listen_WithoutSink_IsInvalidRequest; + [Test] procedure Listen_NotificationsNotObject_IsInvalidParams; + [Test] procedure Managers_NotifyTheHub_AndAnnounceCapabilities; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.ToolsManager, + MCPServer.PromptsManager, + MCPServer.ResourcesManager, + MCPServer.Tool.ContentSamples, + MCPServer.Prompt.ContentSamples; + +const + MODERN_META = '{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + WAIT_MS = 3000; + +{ TLockedSink } + +constructor TLockedSink.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FMessages := TStringList.Create; +end; + +destructor TLockedSink.Destroy; +begin + FMessages.Free; + FLock.Free; + inherited; +end; + +procedure TLockedSink.Send(const Json: string); +begin + FLock.Enter; + try + FMessages.Add(Json); + finally + FLock.Leave; + end; +end; + +procedure TLockedSink.KeepAlive; +begin + AtomicIncrement(FKeepAlives); +end; + +function TLockedSink.Messages: TArray; +begin + FLock.Enter; + try + Result := FMessages.ToStringArray; + finally + FLock.Leave; + end; +end; + +function TLockedSink.Count: Integer; +begin + Result := Integer(Length(Messages)); +end; + +{ TRecordingHub } + +constructor TRecordingHub.Create; +begin + inherited Create; + Events := TStringList.Create; +end; + +destructor TRecordingHub.Destroy; +begin + Events.Free; + inherited; +end; + +procedure TRecordingHub.ToolsListChanged; +begin + Events.Add('tools'); +end; + +procedure TRecordingHub.PromptsListChanged; +begin + Events.Add('prompts'); +end; + +procedure TRecordingHub.ResourcesListChanged; +begin + Events.Add('resources'); +end; + +procedure TRecordingHub.ResourceUpdated(const Uri: string); +begin + Events.Add('updated:' + Uri); +end; + +procedure TRecordingHub.CloseAll(const Reason: string); +begin + Events.Add('close'); +end; + +function TRecordingHub.ActiveCount: Integer; +begin + Result := 0; +end; + +{ TSubscriptionsTests } + +procedure TSubscriptionsTests.Setup; +begin + FManager := TMCPSubscriptionsManager.Create; + FManagerRef := FManager; + FSink := TLockedSink.Create; + FSinkRef := FSink; + FResult := nil; + FError := ''; + FThread := nil; +end; + +procedure TSubscriptionsTests.TearDown; +begin + FManager.CloseAll('teardown'); + JoinListen; + FResult.Free; + FContext := nil; + FSinkRef := nil; + FManagerRef := nil; +end; + +function TSubscriptionsTests.SubscriptionIdOf(const Json: TJSONObject; const MetaPath: string): Integer; +begin + var Meta := Json.FindValue(MetaPath); + Assert.IsTrue(Meta is TJSONObject, MetaPath); + var Id := TJSONObject(Meta).GetValue(MCP_META_SUBSCRIPTION_ID); + Assert.IsTrue(Id is TJSONNumber, MCP_META_SUBSCRIPTION_ID); + Result := TJSONNumber(Id).AsInt; +end; + +function TSubscriptionsTests.Parse(const Json: string): TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Json) as TJSONObject; + Assert.IsNotNull(Result, Json); +end; + +procedure TSubscriptionsTests.StartListen(const ParamsJson: string); +begin + var Meta := TJSONObject.ParseJSONValue(MODERN_META) as TJSONObject; + try + FContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(5), Meta, nil, nil, FSinkRef); + finally + Meta.Free; + end; + + var Params := TJSONObject.ParseJSONValue(ParamsJson) as TJSONObject; + var Context := FContext; + FThread := TThread.CreateAnonymousThread( + procedure + begin + try + try + FResult := FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, Params, Context).AsType; + except + on E: Exception do + FError := E.ClassName + ': ' + E.Message; + end; + finally + Params.Free; + end; + end); + FThread.FreeOnTerminate := False; + FThread.Start; +end; + +procedure TSubscriptionsTests.WaitUntilOpen; +begin + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FManager.ActiveCount = 0) and (FError = '') and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.AreEqual('', FError); + Assert.AreEqual(1, FManager.ActiveCount, 'the subscription is registered'); +end; + +procedure TSubscriptionsTests.JoinListen; +begin + if not Assigned(FThread) then + Exit; + FThread.WaitFor; + FreeAndNil(FThread); +end; + +procedure TSubscriptionsTests.Filter_FromJson_HonoursBooleansAndUris; +begin + var Json := TJSONObject.ParseJSONValue( + '{"toolsListChanged":true,"promptsListChanged":"yes","resourcesListChanged":false,"resourceSubscriptions":["a://x",7,""]}'); + try + var Filter := TMCPSubscriptionFilter.FromJson(Json); + Assert.IsTrue(Filter.ToolsListChanged); + Assert.IsFalse(Filter.PromptsListChanged, 'only a JSON true counts'); + Assert.IsFalse(Filter.ResourcesListChanged); + Assert.AreEqual(1, Integer(Length(Filter.ResourceSubscriptions))); + Assert.IsTrue(Filter.WantsResource('a://x')); + Assert.IsFalse(Filter.WantsResource('a://y')); + var Honoured := Filter.ToJson; + try + Assert.IsTrue(Honoured.GetValue('toolsListChanged')); + Assert.IsNull(Honoured.GetValue('promptsListChanged')); + Assert.AreEqual('a://x', Honoured.GetValue('resourceSubscriptions[0]')); + finally + Honoured.Free; + end; + finally + Json.Free; + end; + var Empty := TMCPSubscriptionFilter.FromJson(nil).ToJson; + try + Assert.AreEqual(0, Empty.Count); + finally + Empty.Free; + end; +end; + +procedure TSubscriptionsTests.Listen_AckFirst_ThenTaggedNotifications_ThenCompletion; +begin + StartListen('{"notifications":{"toolsListChanged":true,"resourceSubscriptions":["a://x"]}}'); + WaitUntilOpen; + Assert.AreEqual(1, FSink.Count, 'the acknowledgement is the first message'); + + FManager.ToolsListChanged; + FManager.ResourceUpdated('a://x'); + FManager.ResourceUpdated('a://other'); + FManager.CloseAll('test'); + FThread.WaitFor; + Assert.AreEqual('', FError); + + var Messages := FSink.Messages; + Assert.AreEqual(3, Integer(Length(Messages)), string.Join(' | ', Messages)); + var Ack := Parse(Messages[0]); + var Changed := Parse(Messages[1]); + var Updated := Parse(Messages[2]); + try + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED, Ack.GetValue('method')); + Assert.AreEqual(5, SubscriptionIdOf(Ack, 'params._meta')); + Assert.IsTrue(Ack.GetValue('params.notifications.toolsListChanged')); + Assert.AreEqual('a://x', Ack.GetValue('params.notifications.resourceSubscriptions[0]')); + Assert.IsNull(Ack.GetValue('id')); + + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED, Changed.GetValue('method')); + Assert.AreEqual(5, SubscriptionIdOf(Changed, 'params._meta')); + + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED, Updated.GetValue('method')); + Assert.AreEqual('a://x', Updated.GetValue('params.uri')); + finally + Ack.Free; + Changed.Free; + Updated.Free; + end; + + Assert.IsNotNull(FResult, 'closing on the server side completes the request'); + Assert.AreEqual(5, SubscriptionIdOf(FResult, '_meta')); + Assert.AreEqual(0, FManager.ActiveCount); +end; + +procedure TSubscriptionsTests.Listen_UnrequestedNotifications_AreNotSent; +begin + StartListen('{"notifications":{"promptsListChanged":true}}'); + WaitUntilOpen; + FManager.ToolsListChanged; + FManager.ResourcesListChanged; + FManager.ResourceUpdated('a://x'); + FManager.PromptsListChanged; + FManager.CloseAll('test'); + FThread.WaitFor; + + var Messages := FSink.Messages; + Assert.AreEqual(2, Integer(Length(Messages)), string.Join(' | ', Messages)); + Assert.IsTrue(Messages[1].Contains(MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED), Messages[1]); +end; + +procedure TSubscriptionsTests.Listen_Cancel_EndsTheWait; +begin + StartListen('{"notifications":{"toolsListChanged":true}}'); + WaitUntilOpen; + FContext.Cancel; + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FManager.ActiveCount > 0) and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.AreEqual(0, FManager.ActiveCount, 'cancellation ends the subscription'); + FThread.WaitFor; + Assert.AreEqual(1, FSink.Count, 'nothing after the acknowledgement'); +end; + +procedure TSubscriptionsTests.Listen_KeepAlive_OnInterval; +begin + FManager.KeepAliveIntervalMs := TMCPSubscriptionsManager.POLL_INTERVAL_MS; + StartListen('{}'); + WaitUntilOpen; + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FSink.KeepAlives < 2) and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.IsTrue(FSink.KeepAlives >= 2, 'keep-alives are sent while the subscription is quiet'); + Assert.AreEqual(1, FSink.Count, 'keep-alives are not messages'); +end; + +procedure TSubscriptionsTests.Listen_WithoutSink_IsInvalidRequest; +begin + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(1), nil, nil, nil, nil); + try + FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, nil, Context).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_REQUEST, E.Code); + end; +end; + +procedure TSubscriptionsTests.Listen_NotificationsNotObject_IsInvalidParams; +begin + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(1), nil, nil, nil, FSinkRef); + var Params := TJSONObject.ParseJSONValue('{"notifications":[1]}') as TJSONObject; + try + try + FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, Params, Context).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TSubscriptionsTests.Managers_NotifyTheHub_AndAnnounceCapabilities; +begin + var Hub := TRecordingHub.Create; + var HubRef: IMCPSubscriptionHub := Hub; + var Tools := TMCPToolsManager.Create; + var Prompts := TMCPPromptsManager.Create; + var Resources := TMCPResourcesManager.Create; + var ToolsRef: IInterface := Tools; + var PromptsRef: IInterface := Prompts; + var ResourcesRef: IInterface := Resources; + var Legacy := TJSONObject.Create; + var Modern := TJSONObject.Create; + try + Tools.DescribeCapabilities(Legacy, TMCPProtocolEra.Legacy); + Assert.IsFalse(Legacy.GetValue('tools.listChanged'), 'without a hub nothing is announced'); + Legacy.RemovePair('tools').Free; + + Tools.ChangeNotifier := HubRef; + Prompts.ChangeNotifier := HubRef; + Resources.ChangeNotifier := HubRef; + Tools.DescribeCapabilities(Legacy, TMCPProtocolEra.Legacy); + Tools.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Resources.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Prompts.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Assert.IsFalse(Legacy.GetValue('tools.listChanged'), 'legacy clients cannot listen'); + Assert.IsTrue(Modern.GetValue('tools.listChanged')); + Assert.IsTrue(Modern.GetValue('prompts.listChanged')); + Assert.IsTrue(Modern.GetValue('resources.listChanged')); + Assert.IsTrue(Modern.GetValue('resources.subscribe')); + + Tools.AddTool(TSimpleTextTool.Create); + Assert.IsTrue(Tools.HasTool('test_simple_text')); + Tools.RemoveTool('test_simple_text'); + Tools.RemoveTool('test_simple_text'); + Assert.IsFalse(Tools.HasTool('test_simple_text')); + Prompts.AddPrompt(TSimplePrompt.Create); + Prompts.RemovePrompt('test_simple_prompt'); + Resources.ResourceUpdated('a://x'); + Assert.AreEqual('tools,tools,prompts,prompts,updated:a://x', string.Join(',', Hub.Events.ToStringArray)); + finally + Modern.Free; + Legacy.Free; + ResourcesRef := nil; + PromptsRef := nil; + ToolsRef := nil; + HubRef := nil; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.ToolResult.pas b/tests/MCPServer.Tests.ToolResult.pas new file mode 100644 index 0000000..7edf90c --- /dev/null +++ b/tests/MCPServer.Tests.ToolResult.pas @@ -0,0 +1,155 @@ +unit MCPServer.Tests.ToolResult; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TToolResultTests = class + public + [Test] procedure Text_ProducesOneTextBlock; + [Test] procedure Image_Audio_Embedded_Blocks; + [Test] procedure StructuredOnly_GetsTextFallback; + [Test] procedure StructuredArray_LegacyDropsIt_ModernKeepsIt; + [Test] procedure Error_SetsIsError; + [Test] procedure Meta_IsEmitted; + [Test] procedure Annotations_AttachToLastBlock; + [Test] procedure Base64Blob_HasNoLineBreaks; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Types, + MCPServer.ContentBlocks, + MCPServer.Tool.Result; + +{ TToolResultTests } + +procedure TToolResultTests.Text_ProducesOneTextBlock; +begin + var ToolResult := TMCPToolResult.Text('hello'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Legacy); + try + Assert.AreEqual('text', Json.GetValue('content[0].type')); + Assert.AreEqual('hello', Json.GetValue('content[0].text')); + Assert.IsNull(Json.GetValue('isError')); + Assert.IsNull(Json.GetValue('structuredContent')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Image_Audio_Embedded_Blocks; +begin + var ToolResult := TMCPToolResult.Create + .AddImage(TEncoding.UTF8.GetBytes('png'), 'image/png') + .AddAudio('AAAA', 'audio/wav') + .AddEmbeddedText('test://x', 'text/plain', 'body') + .AddEmbeddedBlob('test://y', 'application/octet-stream', TEncoding.UTF8.GetBytes('bin')) + .AddResourceLink('file:///a.txt', 'a.txt', 'A file', 'text/plain'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.AreEqual(5, (Json.GetValue('content') as TJSONArray).Count); + Assert.AreEqual('image', Json.GetValue('content[0].type')); + Assert.AreEqual('cG5n', Json.GetValue('content[0].data')); + Assert.AreEqual('image/png', Json.GetValue('content[0].mimeType')); + Assert.AreEqual('audio', Json.GetValue('content[1].type')); + Assert.AreEqual('resource', Json.GetValue('content[2].type')); + Assert.AreEqual('body', Json.GetValue('content[2].resource.text')); + Assert.AreEqual('Ymlu', Json.GetValue('content[3].resource.blob')); + Assert.AreEqual('resource_link', Json.GetValue('content[4].type')); + Assert.AreEqual('A file', Json.GetValue('content[4].description')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.StructuredOnly_GetsTextFallback; +begin + var ToolResult := TMCPToolResult.Create.SetStructuredContent(TJSONObject.ParseJSONValue('{"a":1}')); + var Json := ToolResult.ToJson(TMCPProtocolEra.Legacy); + try + Assert.AreEqual('{"a":1}', Json.GetValue('content[0].text')); + Assert.AreEqual(1, Json.GetValue('structuredContent.a')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.StructuredArray_LegacyDropsIt_ModernKeepsIt; +begin + var ToolResult := TMCPToolResult.Text('list').SetStructuredContent(TJSONObject.ParseJSONValue('[1,2]')); + var Legacy := ToolResult.ToJson(TMCPProtocolEra.Legacy); + var Modern := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsNull(Legacy.GetValue('structuredContent'), 'legacy schemas only allow objects'); + Assert.IsTrue(Modern.GetValue('structuredContent') is TJSONArray); + finally + Legacy.Free; + Modern.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Error_SetsIsError; +begin + var ToolResult := TMCPToolResult.Error('boom'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.AreEqual('boom', Json.GetValue('content[0].text')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Meta_IsEmitted; +begin + var Meta := TJSONObject.Create; + Meta.AddPair('com.example/trace', 'abc'); + var ToolResult := TMCPToolResult.Text('x').SetMeta(Meta); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.AreEqual('abc', Json.GetValue('_meta["com.example/trace"]')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Annotations_AttachToLastBlock; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var ToolResult := TMCPToolResult.Text('first').AddText('second').WithAnnotations(Annotations); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsNull(Json.FindValue('content[0].annotations')); + Assert.AreEqual(0.5, Json.GetValue('content[1].annotations.priority'), 0.0001); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Base64Blob_HasNoLineBreaks; +begin + var Bytes: TBytes; + SetLength(Bytes, 300); + for var I := 0 to High(Bytes) do + Bytes[I] := Byte(I); + var Encoded := EncodeBase64Blob(Bytes); + Assert.AreEqual(400, Length(Encoded)); + Assert.IsFalse(Encoded.Contains(#13) or Encoded.Contains(#10)); +end; + +end. diff --git a/tests/MCPServer.Tests.ToolsManager.pas b/tests/MCPServer.Tests.ToolsManager.pas new file mode 100644 index 0000000..db37108 --- /dev/null +++ b/tests/MCPServer.Tests.ToolsManager.pas @@ -0,0 +1,332 @@ +unit MCPServer.Tests.ToolsManager; + +interface + +uses + DUnitX.TestFramework, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base, + MCPServer.ToolsManager; + +type + TStructuredParams = class + private + FValue: Integer; + public + property Value: Integer read FValue write FValue; + end; + + TStructuredOutput = class + private + FDoubled: Integer; + public + property Doubled: Integer read FDoubled write FDoubled; + end; + + TDoublingTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TStructuredParams): TStructuredOutput; override; + public + constructor Create; override; + end; + + THandWrittenTool = class(TMCPToolBase) + protected + function BuildSchema: TJSONObject; override; + function DoExecute(const Arguments: TJSONObject): TValue; override; + public + constructor Create; override; + end; + + [TestFixture] + TToolsManagerTests = class + private + FManager: TMCPToolsManager; + function Call(const ParamsJson: string; Era: TMCPProtocolEra): TJSONObject; + procedure ExpectError(const ParamsJson: string; Era: TMCPProtocolEra; ExpectedCode: Integer); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure UnknownTool_IsInvalidParams_WithName; + [Test] procedure MissingName_IsInvalidParams; + [Test] procedure ArgumentsNotObject_IsInvalidParams; + [Test] procedure MissingRequiredArgument_IsErrorResult; + [Test] procedure WrongArgumentType_IsErrorResult; + [Test] procedure UnknownArgument_IsErrorResult; + [Test] procedure ToolError_IsErrorResult; + [Test] procedure ContentBlocks_FromToolResult; + [Test] procedure StructuredResult_HasTextFallback; + [Test] procedure List_IsInRegistrationOrder_WithAnnotations; + [Test] procedure List_CacheHints_ModernOnly; + [Test] procedure List_Cursor_IsInvalidParams; + [Test] procedure HandWrittenTool_ValidArguments_Runs; + [Test] procedure HandWrittenTool_MissingRequired_IsErrorResult; + [Test] procedure HandWrittenTool_WrongType_IsErrorResult; + end; + +implementation + +uses + System.SysUtils, + System.Generics.Collections, + MCPServer.Errors; + +{ TDoublingTool } + +constructor TDoublingTool.Create; +begin + inherited; + FName := 'doubling'; + FDescription := 'Doubles a number'; +end; + +function TDoublingTool.ExecuteWithParams(const Params: TStructuredParams): TStructuredOutput; +begin + Result := TStructuredOutput.Create; + Result.Doubled := Params.Value * 2; +end; + +{ THandWrittenTool } + +constructor THandWrittenTool.Create; +begin + inherited; + FName := 'hand_written'; + FDescription := 'A tool with a hand-written schema'; +end; + +function THandWrittenTool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{"type":"object","required":["count"],"properties":{"count":{"type":"integer"}}}') as TJSONObject; +end; + +function THandWrittenTool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From('count was ' + Arguments.GetValue('count').ToString); +end; + +{ TToolsManagerTests } + +procedure TToolsManagerTests.Setup; +begin + FManager := TMCPToolsManager.Create; + FManager.AddTool(TDoublingTool.Create); + FManager.AddTool(THandWrittenTool.Create); +end; + +procedure TToolsManagerTests.TearDown; +begin + FManager.Free; +end; + +function TToolsManagerTests.Call(const ParamsJson: string; Era: TMCPProtocolEra): TJSONObject; +begin + var Params := TJSONObject.ParseJSONValue(ParamsJson) as TJSONObject; + try + Result := FManager.CallTool(Params, Era).AsType; + finally + Params.Free; + end; +end; + +procedure TToolsManagerTests.ExpectError(const ParamsJson: string; Era: TMCPProtocolEra; ExpectedCode: Integer); +begin + try + Call(ParamsJson, Era).Free; + Assert.Fail('expected EMCPError ' + ExpectedCode.ToString + ' for ' + ParamsJson); + except + on E: EMCPError do + Assert.AreEqual(ExpectedCode, E.Code, E.Message); + end; +end; + +procedure TToolsManagerTests.UnknownTool_IsInvalidParams_WithName; +begin + for var Era in [TMCPProtocolEra.Legacy, TMCPProtocolEra.Modern] do + try + Call('{"name":"nope","arguments":{}}', Era).Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.AreEqual('nope', (E.Data as TJSONObject).GetValue('name')); + end; + end; +end; + +procedure TToolsManagerTests.MissingName_IsInvalidParams; +begin + ExpectError('{}', TMCPProtocolEra.Legacy, JSONRPC_INVALID_PARAMS); + ExpectError('{"name":""}', TMCPProtocolEra.Modern, JSONRPC_INVALID_PARAMS); + ExpectError('{"name":5}', TMCPProtocolEra.Modern, JSONRPC_INVALID_PARAMS); +end; + +procedure TToolsManagerTests.ArgumentsNotObject_IsInvalidParams; +begin + ExpectError('{"name":"echo","arguments":[1]}', TMCPProtocolEra.Modern, JSONRPC_INVALID_PARAMS); +end; + +procedure TToolsManagerTests.MissingRequiredArgument_IsErrorResult; +begin + var Json := Call('{"name":"echo"}', TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('Missing required parameter "message"')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.WrongArgumentType_IsErrorResult; +begin + var Json := Call('{"name":"calculate","arguments":{"operation":"add","a":"two","b":3}}', TMCPProtocolEra.Legacy); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('Parameter "a": expected a number')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.UnknownArgument_IsErrorResult; +begin + var Json := Call('{"name":"echo","arguments":{"message":"hi","extra":1}}', TMCPProtocolEra.Legacy); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('Unknown parameter "extra"')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.ToolError_IsErrorResult; +begin + var Json := Call('{"name":"test_error_handling","arguments":{}}', TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('always fails')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.ContentBlocks_FromToolResult; +begin + var Json := Call('{"name":"test_multiple_content_types","arguments":{}}', TMCPProtocolEra.Modern); + try + Assert.AreEqual(3, (Json.GetValue('content') as TJSONArray).Count); + Assert.AreEqual('text', Json.GetValue('content[0].type')); + Assert.AreEqual('image', Json.GetValue('content[1].type')); + Assert.AreEqual('resource', Json.GetValue('content[2].type')); + Assert.IsNull(Json.GetValue('isError')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.StructuredResult_HasTextFallback; +begin + var Json := Call('{"name":"doubling","arguments":{"value":21}}', TMCPProtocolEra.Legacy); + try + Assert.AreEqual(42, Json.GetValue('structuredContent.doubled')); + Assert.AreEqual('{"doubled":42}', Json.GetValue('content[0].text')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.List_IsInRegistrationOrder_WithAnnotations; +begin + var Json := FManager.ListTools(nil, TMCPProtocolEra.Legacy).AsType; + try + var Tools := Json.GetValue('tools') as TJSONArray; + Assert.AreEqual('echo', Json.GetValue('tools[0].name'), 'registration order starts with echo'); + Assert.AreEqual('hand_written', Tools.Items[Tools.Count - 1].GetValue('name'), + 'the last-added tool comes last'); + Assert.AreEqual('doubling', Tools.Items[Tools.Count - 2].GetValue('name')); + var ReadOnly := False; + for var Tool in Tools do + if Tool.GetValue('name') = 'test_simple_text' then + ReadOnly := Tool.GetValue('annotations.readOnlyHint'); + Assert.IsTrue(ReadOnly); + Assert.AreEqual('integer', + Json.GetValue('tools[' + (Tools.Count - 2).ToString + '].inputSchema.properties.value.type')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.List_CacheHints_ModernOnly; +begin + FManager.ListTtlMs := 300000; + FManager.ListCacheScope := MCP_CACHE_SCOPE_PUBLIC; + + var Legacy := FManager.ListTools(nil, TMCPProtocolEra.Legacy).AsType; + var Modern := FManager.ListTools(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Legacy.GetValue('ttlMs')); + Assert.AreEqual(300000, Modern.GetValue('ttlMs')); + Assert.AreEqual('public', Modern.GetValue('cacheScope')); + finally + Legacy.Free; + Modern.Free; + end; +end; + +procedure TToolsManagerTests.List_Cursor_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"cursor":"abc"}') as TJSONObject; + try + try + FManager.ListTools(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TToolsManagerTests.HandWrittenTool_ValidArguments_Runs; +begin + var Json := Call('{"name":"hand_written","arguments":{"count":3}}', TMCPProtocolEra.Modern); + try + Assert.IsNull(Json.GetValue('isError')); + Assert.AreEqual('count was 3', Json.GetValue('content[0].text')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.HandWrittenTool_MissingRequired_IsErrorResult; +begin + var Json := Call('{"name":"hand_written","arguments":{}}', TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('missing required property "count"')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.HandWrittenTool_WrongType_IsErrorResult; +begin + var Json := Call('{"name":"hand_written","arguments":{"count":"three"}}', TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.IsTrue(Json.GetValue('content[0].text').Contains('expected integer')); + finally + Json.Free; + end; +end; + +end. diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr new file mode 100644 index 0000000..e4f294a --- /dev/null +++ b/tests/MCPServerTests.dpr @@ -0,0 +1,119 @@ +program MCPServerTests; + +{$APPTYPE CONSOLE} +{$STRONGLINKTYPES ON} + +uses + System.SysUtils, + DUnitX.Loggers.Console, + DUnitX.Loggers.Xml.NUnit, + DUnitX.TestFramework, + MCPServer.Types in '..\src\Protocol\MCPServer.Types.pas', + MCPServer.Errors in '..\src\Protocol\MCPServer.Errors.pas', + MCPServer.RequestContext in '..\src\Protocol\MCPServer.RequestContext.pas', + MCPServer.Capabilities in '..\src\Protocol\MCPServer.Capabilities.pas', + MCPServer.HttpHeaders in '..\src\Server\MCPServer.HttpHeaders.pas', + MCPServer.HttpStream in '..\src\Server\MCPServer.HttpStream.pas', + MCPServer.IdHTTPServer in '..\src\Server\MCPServer.IdHTTPServer.pas', + MCPServer.Serializer in '..\src\Protocol\MCPServer.Serializer.pas', + MCPServer.Schema.Generator in '..\src\Protocol\MCPServer.Schema.Generator.pas', + MCPServer.Schema.Validator in '..\src\Protocol\MCPServer.Schema.Validator.pas', + MCPServer.ContentBlocks in '..\src\Protocol\MCPServer.ContentBlocks.pas', + MCPServer.Logger in '..\src\Core\MCPServer.Logger.pas', + MCPServer.Settings in '..\src\Core\MCPServer.Settings.pas', + MCPServer.Authorization in '..\src\Core\MCPServer.Authorization.pas', + MCPServer.Registration in '..\src\Core\MCPServer.Registration.pas', + MCPServer.ManagerRegistry in '..\src\Core\MCPServer.ManagerRegistry.pas', + MCPServer.Tool.Base in '..\src\Tools\MCPServer.Tool.Base.pas', + MCPServer.Resource.Base in '..\src\Resources\MCPServer.Resource.Base.pas', + MCPServer.Prompt.Base in '..\src\Prompts\MCPServer.Prompt.Base.pas', + MCPServer.JsonRpcProcessor in '..\src\Protocol\MCPServer.JsonRpcProcessor.pas', + MCPServer.CoreManager in '..\src\Managers\MCPServer.CoreManager.pas', + MCPServer.ToolsManager in '..\src\Managers\MCPServer.ToolsManager.pas', + MCPServer.ResourcesManager in '..\src\Managers\MCPServer.ResourcesManager.pas', + MCPServer.PromptsManager in '..\src\Managers\MCPServer.PromptsManager.pas', + MCPServer.CompletionManager in '..\src\Managers\MCPServer.CompletionManager.pas', + MCPServer.SubscriptionsManager in '..\src\Managers\MCPServer.SubscriptionsManager.pas', + MCPServer.StdioTransport in '..\src\Server\MCPServer.StdioTransport.pas', + MCPServer.StdioChannel in '..\src\Server\MCPServer.StdioChannel.pas', + // The built-in tools and resources register themselves in their + // initialization sections. Keep the order identical to MCPServer.dpr so the + // registry (and therefore tools/list and resources/list) matches the server. + MCPServer.Resource.Server in '..\src\Resources\MCPServer.Resource.Server.pas', + MCPServer.Tool.Echo in '..\src\Tools\MCPServer.Tool.Echo.pas', + MCPServer.Tool.GetTime in '..\src\Tools\MCPServer.Tool.GetTime.pas', + MCPServer.Tool.ListFiles in '..\src\Tools\MCPServer.Tool.ListFiles.pas', + MCPServer.Tool.Calculate in '..\src\Tools\MCPServer.Tool.Calculate.pas', + MCPServer.Resource.Logs in '..\src\Resources\MCPServer.Resource.Logs.pas', + MCPServer.Resource.Project in '..\src\Resources\MCPServer.Resource.Project.pas', + MCPServer.Tool.ContentSamples in '..\src\Tools\MCPServer.Tool.ContentSamples.pas', + MCPServer.Tool.InputRequiredSamples in '..\src\Tools\MCPServer.Tool.InputRequiredSamples.pas', + MCPServer.Tool.SubscriptionSamples in '..\src\Tools\MCPServer.Tool.SubscriptionSamples.pas', + MCPServer.Resource.Samples in '..\src\Resources\MCPServer.Resource.Samples.pas', + MCPServer.Prompt.SummarizeLogs in '..\src\Prompts\MCPServer.Prompt.SummarizeLogs.pas', + MCPServer.Prompt.ContentSamples in '..\src\Prompts\MCPServer.Prompt.ContentSamples.pas', + MCPServer.Tool.Result in '..\src\Tools\MCPServer.Tool.Result.pas', + MCPServer.Tests.Harness in 'MCPServer.Tests.Harness.pas', + MCPServer.Tests.Golden in 'MCPServer.Tests.Golden.pas', + MCPServer.Tests.Golden.Legacy in 'MCPServer.Tests.Golden.Legacy.pas', + MCPServer.Tests.Constants in 'MCPServer.Tests.Constants.pas', + MCPServer.Tests.ServerStatus in 'MCPServer.Tests.ServerStatus.pas', + MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas', + MCPServer.Tests.Logger in 'MCPServer.Tests.Logger.pas', + MCPServer.Tests.RequestContext in 'MCPServer.Tests.RequestContext.pas', + MCPServer.Tests.Processor in 'MCPServer.Tests.Processor.pas', + MCPServer.Tests.Capabilities in 'MCPServer.Tests.Capabilities.pas', + MCPServer.Tests.Golden.Modern in 'MCPServer.Tests.Golden.Modern.pas', + MCPServer.Tests.HttpHeaders in 'MCPServer.Tests.HttpHeaders.pas', + MCPServer.Tests.Http in 'MCPServer.Tests.Http.pas', + MCPServer.Tests.ToolResult in 'MCPServer.Tests.ToolResult.pas', + MCPServer.Tests.Serializer in 'MCPServer.Tests.Serializer.pas', + MCPServer.Tests.Schema in 'MCPServer.Tests.Schema.pas', + MCPServer.Tests.ToolsManager in 'MCPServer.Tests.ToolsManager.pas', + MCPServer.Tests.ResourcesManager in 'MCPServer.Tests.ResourcesManager.pas', + MCPServer.Tests.StdioChannel in 'MCPServer.Tests.StdioChannel.pas', + MCPServer.Tests.Cancellation in 'MCPServer.Tests.Cancellation.pas', + MCPServer.Tests.Stdio in 'MCPServer.Tests.Stdio.pas', + MCPServer.Tests.SchemaValidator in 'MCPServer.Tests.SchemaValidator.pas', + MCPServer.Tests.Prompt in 'MCPServer.Tests.Prompt.pas', + MCPServer.Tests.Mrtr in 'MCPServer.Tests.Mrtr.pas', + MCPServer.Tests.Subscriptions in 'MCPServer.Tests.Subscriptions.pas', + MCPServer.Tests.Authorization in 'MCPServer.Tests.Authorization.pas', + MCPServer.Tests.PromptsManager in 'MCPServer.Tests.PromptsManager.pas', + MCPServer.Tests.CompletionManager in 'MCPServer.Tests.CompletionManager.pas'; + +procedure RunTests; +begin + TDUnitX.CheckCommandLine; + + var Runner := TDUnitX.CreateRunner; + Runner.UseRTTI := True; + Runner.FailsOnNoAsserts := False; + + if TDUnitX.Options.ConsoleMode <> TDunitXConsoleMode.Off then + Runner.AddLogger(TDUnitXConsoleLogger.Create(TDUnitX.Options.ConsoleMode = TDunitXConsoleMode.Quiet)); + + Runner.AddLogger(TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile)); + + var Results := Runner.Execute; + if not Results.AllPassed then + System.ExitCode := EXIT_ERRORS; + + if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then + begin + System.Write('Done. Press to quit.'); + System.Readln; + end; +end; + +begin + try + RunTests; + except + on E: Exception do + begin + System.Writeln(E.ClassName, ': ', E.Message); + System.ExitCode := EXIT_ERRORS; + end; + end; +end. diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj new file mode 100644 index 0000000..5a765e1 --- /dev/null +++ b/tests/MCPServerTests.dproj @@ -0,0 +1,175 @@ + + + {5C1E6B2A-7D4F-4E8B-9A3C-2F1D0E9B8C7A} + MCPServerTests.dpr + True + Debug + 3 + Console + 20.3 + Win32 + MCPServerTests + None + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + MCPServerTests + true + ..\src;..\src\Managers;..\src\Server;..\src\Tools;..\src\Core;..\src\Protocol;..\src\Libraries;..\src\Resources;..\src\Prompts;$(DUnitX);$(BDS)\source\DUnitX;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + 0 + 0 + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + MCPServerTests.dpr + + + + True + True + + + 12 + + + + diff --git a/tests/fixtures/files/alpha.txt b/tests/fixtures/files/alpha.txt new file mode 100644 index 0000000..fda2f87 --- /dev/null +++ b/tests/fixtures/files/alpha.txt @@ -0,0 +1 @@ +alpha fixture file diff --git a/tests/fixtures/files/beta.txt b/tests/fixtures/files/beta.txt new file mode 100644 index 0000000..9701376 --- /dev/null +++ b/tests/fixtures/files/beta.txt @@ -0,0 +1 @@ +beta fixture file diff --git a/tests/golden/README.md b/tests/golden/README.md new file mode 100644 index 0000000..6a1d565 --- /dev/null +++ b/tests/golden/README.md @@ -0,0 +1,69 @@ +# Golden files + +The golden files pin the wire behaviour of the server. A change in a golden +file is a deliberate change of what clients receive and belongs in the +CHANGELOG; an unintended change is a regression. + +## Layout + +| Directory | Layer | Recorded by | Verified by | +|---|---|---|---| +| `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr`, initialize-based protocol revisions | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TLegacyGoldenTests`) | +| `modern/` | The same layer for requests that carry per-request `_meta` (MCP 2026-07-28), including the rejected shapes | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TModernGoldenTests`) | +| `http/` | Streamable HTTP transport (`TMCPIdHTTPServer`) of the built executable, captured with curl | `scripts\capture-http-goldens.ps1 -Record` | `scripts\capture-http-goldens.ps1` | + +## Legacy case files + +One JSON file per case in `legacy/`: + +```json +{ + "request": { "jsonrpc": "2.0", "id": 1, "method": "ping" }, + "mask": ["result.sessionId"], + "shape": ["result.contents[0].text"], + "workingDirectory": "fixtures", + "expected": { "jsonrpc": "2.0", "id": 1, "result": {} } +} +``` + +- `request` is sent as the request body. Use `requestText` instead for input that + is not JSON (parse errors, empty body, arrays). +- `mask` lists paths whose value is replaced by `""` before comparing + (session ids, timestamps). +- `shape` lists paths whose value is replaced by its shape: every leaf becomes + its JSON type name. A string that contains a JSON document is parsed first, so + resource contents such as `logs://recent` and `server://status` are compared + structurally. +- Paths are dotted member paths with array indexes; `[*]` matches any index. + A path must end at an object member. +- `workingDirectory` (relative to `tests/`) is made current while the request + runs; `list_files` restricts itself to the current directory. +- `expected` holds the normalised response. `expectedText` is used when the + response is empty (notification) or not JSON. + +The tests compare the formatted JSON text of the normalised response with the +formatted `expected` value, so key order and array order matter. + +## Recording procedure + +1. `build.bat Debug Win64` and `build-tests.bat Debug Win64` (the test + program is `tests\MCPServerTests.dpr`). +2. `.\scripts\run-tests.ps1 -Record -NoBuild` rewrites the `expected` sections + in `legacy/`. Use `-Filter` with the fully qualified test names to + re-record single cases. +3. `.\scripts\capture-http-goldens.ps1 -Record` starts `Win64\Debug\MCPServer.exe` + on port 3939 and writes `http/*.txt`. +4. Review the diff: only the cases whose behaviour changed on purpose may + differ. +5. `.\scripts\run-tests.ps1` and `.\scripts\capture-http-goldens.ps1` must be + green before committing. + +## Notes on the recorded behaviour + +- `logs://recent` and `server://status` contain timestamps, counters and log + text, so their `text` field is compared by shape. +- A request with `id: null` is treated as a notification and gets no + response. +- HTTP responses are normalised: `Date` and `Server` headers are dropped, GUIDs + become ``, SSE `id:` lines become `id: `, line endings are LF and + trailing newlines are trimmed. diff --git a/tests/golden/http/delete-endpoint.txt b/tests/golden/http/delete-endpoint.txt new file mode 100644 index 0000000..184a6fb --- /dev/null +++ b/tests/golden/http/delete-endpoint.txt @@ -0,0 +1,10 @@ +HTTP/1.1 405 Method not allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Allow: POST, OPTIONS diff --git a/tests/golden/http/get-endpoint-info.txt b/tests/golden/http/get-endpoint-info.txt new file mode 100644 index 0000000..184a6fb --- /dev/null +++ b/tests/golden/http/get-endpoint-info.txt @@ -0,0 +1,10 @@ +HTTP/1.1 405 Method not allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Allow: POST, OPTIONS diff --git a/tests/golden/http/get-info-path.txt b/tests/golden/http/get-info-path.txt new file mode 100644 index 0000000..9b6de65 --- /dev/null +++ b/tests/golden/http/get-info-path.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 125 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"url":"http://localhost:3939/mcp","transport":"streamable-http","protocolVersions":["2026-07-28","2025-11-25","2025-06-18"]} diff --git a/tests/golden/http/get-sse-stream.txt b/tests/golden/http/get-sse-stream.txt new file mode 100644 index 0000000..184a6fb --- /dev/null +++ b/tests/golden/http/get-sse-stream.txt @@ -0,0 +1,10 @@ +HTTP/1.1 405 Method not allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Allow: POST, OPTIONS diff --git a/tests/golden/http/modern-discover.txt b/tests/golden/http/modern-discover.txt new file mode 100644 index 0000000..c536011 --- /dev/null +++ b/tests/golden/http/modern-discover.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 367 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":true},"resources":{"subscribe":true,"listChanged":true},"prompts":{"listChanged":true},"completions":{}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} diff --git a/tests/golden/http/modern-method-header-mismatch.txt b/tests/golden/http/modern-method-header-mismatch.txt new file mode 100644 index 0000000..ea1d2a1 --- /dev/null +++ b/tests/golden/http/modern-method-header-mismatch.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 154 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":27,"error":{"code":-32020,"message":"Header mismatch: Mcp-Method header value 'tools/call' does not match body value 'tools/list'"}} diff --git a/tests/golden/http/modern-missing-client-capabilities.txt b/tests/golden/http/modern-missing-client-capabilities.txt new file mode 100644 index 0000000..f6abb7e --- /dev/null +++ b/tests/golden/http/modern-missing-client-capabilities.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 151 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":24,"error":{"code":-32602,"message":"params._meta.io.modelcontextprotocol/clientCapabilities is required and must be an object"}} diff --git a/tests/golden/http/modern-missing-method-header.txt b/tests/golden/http/modern-missing-method-header.txt new file mode 100644 index 0000000..b5d09ee --- /dev/null +++ b/tests/golden/http/modern-missing-method-header.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 90 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":26,"error":{"code":-32020,"message":"Mcp-Method header is missing"}} diff --git a/tests/golden/http/modern-missing-version-header.txt b/tests/golden/http/modern-missing-version-header.txt new file mode 100644 index 0000000..d8c9799 --- /dev/null +++ b/tests/golden/http/modern-missing-version-header.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 100 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":22,"error":{"code":-32020,"message":"MCP-Protocol-Version header is missing"}} diff --git a/tests/golden/http/modern-notification.txt b/tests/golden/http/modern-notification.txt new file mode 100644 index 0000000..99f580f --- /dev/null +++ b/tests/golden/http/modern-notification.txt @@ -0,0 +1,9 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/modern-tools-call-name-base64.txt b/tests/golden/http/modern-tools-call-name-base64.txt new file mode 100644 index 0000000..3ceae2e --- /dev/null +++ b/tests/golden/http/modern-tools-call-name-base64.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 210 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":25,"result":{"content":[{"type":"text","text":"Echo: hello modern"}],"resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt new file mode 100644 index 0000000..28861bd --- /dev/null +++ b/tests/golden/http/modern-tools-list.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 6327 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/modern-unknown-method.txt b/tests/golden/http/modern-unknown-method.txt new file mode 100644 index 0000000..1a73b9c --- /dev/null +++ b/tests/golden/http/modern-unknown-method.txt @@ -0,0 +1,11 @@ +HTTP/1.1 404 Not Found +Connection: close +Content-Type: application/json +Content-Length: 149 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":21,"error":{"code":-32601,"message":"Method [totally/bogus/method] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/modern-unsupported-version.txt b/tests/golden/http/modern-unsupported-version.txt new file mode 100644 index 0000000..7c4d0fa --- /dev/null +++ b/tests/golden/http/modern-unsupported-version.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 151 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":23,"error":{"code":-32022,"message":"Unsupported protocol version","data":{"supported":["2026-07-28"],"requested":"1900-01-01"}}} diff --git a/tests/golden/http/options-preflight.txt b/tests/golden/http/options-preflight.txt new file mode 100644 index 0000000..48bd820 --- /dev/null +++ b/tests/golden/http/options-preflight.txt @@ -0,0 +1,10 @@ +HTTP/1.1 204 No Content +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Vary: Origin +Access-Control-Allow-Origin: http://localhost +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/post-batch-notifications.txt b/tests/golden/http/post-batch-notifications.txt new file mode 100644 index 0000000..9cff322 --- /dev/null +++ b/tests/golden/http/post-batch-notifications.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 105 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":null,"error":{"code":-32600,"message":"JSON-RPC batch requests are not supported"}} diff --git a/tests/golden/http/post-batch-requests.txt b/tests/golden/http/post-batch-requests.txt new file mode 100644 index 0000000..9cff322 --- /dev/null +++ b/tests/golden/http/post-batch-requests.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 105 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":null,"error":{"code":-32600,"message":"JSON-RPC batch requests are not supported"}} diff --git a/tests/golden/http/post-client-response.txt b/tests/golden/http/post-client-response.txt new file mode 100644 index 0000000..99f580f --- /dev/null +++ b/tests/golden/http/post-client-response.txt @@ -0,0 +1,9 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/post-empty-body.txt b/tests/golden/http/post-empty-body.txt new file mode 100644 index 0000000..7fb9986 --- /dev/null +++ b/tests/golden/http/post-empty-body.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 76 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt new file mode 100644 index 0000000..fb4a535 --- /dev/null +++ b/tests/golden/http/post-initialize-sse.txt @@ -0,0 +1,14 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/event-stream; charset=utf-8 +Content-Length: 297 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +X-Accel-Buffering: no + +event: message +data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-initialize.txt b/tests/golden/http/post-initialize.txt new file mode 100644 index 0000000..173703c --- /dev/null +++ b/tests/golden/http/post-initialize.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 274 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-no-accept-header.txt b/tests/golden/http/post-no-accept-header.txt new file mode 100644 index 0000000..7517a9c --- /dev/null +++ b/tests/golden/http/post-no-accept-header.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 36 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":9,"result":{}} diff --git a/tests/golden/http/post-notification-initialized.txt b/tests/golden/http/post-notification-initialized.txt new file mode 100644 index 0000000..99f580f --- /dev/null +++ b/tests/golden/http/post-notification-initialized.txt @@ -0,0 +1,9 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/post-origin-allowed.txt b/tests/golden/http/post-origin-allowed.txt new file mode 100644 index 0000000..5305fd4 --- /dev/null +++ b/tests/golden/http/post-origin-allowed.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Vary: Origin +Access-Control-Allow-Origin: http://localhost +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":13,"result":{}} diff --git a/tests/golden/http/post-origin-forbidden.txt b/tests/golden/http/post-origin-forbidden.txt new file mode 100644 index 0000000..9577b99 --- /dev/null +++ b/tests/golden/http/post-origin-forbidden.txt @@ -0,0 +1,7 @@ +HTTP/1.1 403 Forbidden +Connection: keep-alive +Content-Type: application/json +Content-Length: 72 +Vary: Origin + +{"jsonrpc":"2.0","error":{"code":-32600,"message":"Origin not allowed"}} diff --git a/tests/golden/http/post-parse-error.txt b/tests/golden/http/post-parse-error.txt new file mode 100644 index 0000000..7fb9986 --- /dev/null +++ b/tests/golden/http/post-parse-error.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 76 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-protocol-version-header.txt b/tests/golden/http/post-protocol-version-header.txt new file mode 100644 index 0000000..cf65117 --- /dev/null +++ b/tests/golden/http/post-protocol-version-header.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":12,"result":{}} diff --git a/tests/golden/http/post-resources-list.txt b/tests/golden/http/post-resources-list.txt new file mode 100644 index 0000000..52dac26 --- /dev/null +++ b/tests/golden/http/post-resources-list.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 878 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"server://status","name":"server_status","description":"Current server status and health information","mimeType":"application/json"},{"uri":"logs://recent","name":"Recent Logs","description":"Recent log entries from all categories","mimeType":"application/json"},{"uri":"project://info","name":"Project Information","description":"Basic information about the Delphi MCP Server project","mimeType":"application/json"},{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"uri":"test://static-text","name":"Static text","title":"Static text resource","description":"A fixed text resource","mimeType":"text/plain"},{"uri":"test://static-binary","name":"Static binary","title":"Static binary resource","description":"A fixed PNG image","mimeType":"image/png"}]}} diff --git a/tests/golden/http/post-resources-read-project-info.txt b/tests/golden/http/post-resources-read-project-info.txt new file mode 100644 index 0000000..c112976 --- /dev/null +++ b/tests/golden/http/post-resources-read-project-info.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 633 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":5,"result":{"contents":[{"uri":"project://info","mimeType":"application/json","text":"{\"name\":\"delphi-mcp-server\",\"version\":\"1.0.0\",\"description\":\"A Model Context Protocol (MCP) server implementation in Delphi\",\"language\":\"Delphi\",\"framework\":\"Indy HTTP Server (TIdHTTPServer)\",\"protocol\":\"MCP 2026-07-28 (initialize-based: 2025-11-25, 2025-06-18)\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}"}]}} diff --git a/tests/golden/http/post-session-echo-lowercase.txt b/tests/golden/http/post-session-echo-lowercase.txt new file mode 100644 index 0000000..8b64f28 --- /dev/null +++ b/tests/golden/http/post-session-echo-lowercase.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Mcp-Session-Id: golden-session-2 + +{"jsonrpc":"2.0","id":11,"result":{}} diff --git a/tests/golden/http/post-session-echo.txt b/tests/golden/http/post-session-echo.txt new file mode 100644 index 0000000..24f3dc0 --- /dev/null +++ b/tests/golden/http/post-session-echo.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Mcp-Session-Id: golden-session-1 + +{"jsonrpc":"2.0","id":10,"result":{}} diff --git a/tests/golden/http/post-tools-call-echo.txt b/tests/golden/http/post-tools-call-echo.txt new file mode 100644 index 0000000..57b6862 --- /dev/null +++ b/tests/golden/http/post-tools-call-echo.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 91 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":3,"result":{"content":[{"type":"text","text":"Echo: hello golden"}]}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt new file mode 100644 index 0000000..07775b6 --- /dev/null +++ b/tests/golden/http/post-tools-list-sse.txt @@ -0,0 +1,14 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/event-stream; charset=utf-8 +Content-Length: 6198 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +X-Accel-Buffering: no + +event: message +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt new file mode 100644 index 0000000..697196b --- /dev/null +++ b/tests/golden/http/post-tools-list.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 6175 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-unknown-method.txt b/tests/golden/http/post-unknown-method.txt new file mode 100644 index 0000000..4eded8b --- /dev/null +++ b/tests/golden/http/post-unknown-method.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 148 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":7,"error":{"code":-32601,"message":"Method [totally/bogus/method] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/post-wrong-path.txt b/tests/golden/http/post-wrong-path.txt new file mode 100644 index 0000000..6246a40 --- /dev/null +++ b/tests/golden/http/post-wrong-path.txt @@ -0,0 +1,9 @@ +HTTP/1.1 404 Not Found +Connection: close +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/put-endpoint.txt b/tests/golden/http/put-endpoint.txt new file mode 100644 index 0000000..184a6fb --- /dev/null +++ b/tests/golden/http/put-endpoint.txt @@ -0,0 +1,10 @@ +HTTP/1.1 405 Method not allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 +Allow: POST, OPTIONS diff --git a/tests/golden/legacy/empty-body.json b/tests/golden/legacy/empty-body.json new file mode 100644 index 0000000..278dc85 --- /dev/null +++ b/tests/golden/legacy/empty-body.json @@ -0,0 +1,11 @@ +{ + "requestText": "", + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32700, + "message": "Invalid JSON" + } + } +} diff --git a/tests/golden/legacy/id-null.json b/tests/golden/legacy/id-null.json new file mode 100644 index 0000000..5f7e085 --- /dev/null +++ b/tests/golden/legacy/id-null.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": null, + "method": "ping" + }, + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32600, + "message": "id must not be null" + } + } +} diff --git a/tests/golden/legacy/id-string.json b/tests/golden/legacy/id-string.json new file mode 100644 index 0000000..3ef2ef1 --- /dev/null +++ b/tests/golden/legacy/id-string.json @@ -0,0 +1,13 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": "request-24", + "method": "ping" + }, + "expected": { + "jsonrpc": "2.0", + "id": "request-24", + "result": { + } + } +} diff --git a/tests/golden/legacy/initialize-2025-03-26.json b/tests/golden/legacy/initialize-2025-03-26.json new file mode 100644 index 0000000..4b70607 --- /dev/null +++ b/tests/golden/legacy/initialize-2025-03-26.json @@ -0,0 +1,44 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize", + "params": { + "protocolVersion": "2025-03-26", + "capabilities": { + }, + "clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-11-25", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} diff --git a/tests/golden/legacy/initialize-2025-06-18.json b/tests/golden/legacy/initialize-2025-06-18.json new file mode 100644 index 0000000..d7f0e52 --- /dev/null +++ b/tests/golden/legacy/initialize-2025-06-18.json @@ -0,0 +1,44 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize", + "params": { + "protocolVersion": "2025-06-18", + "capabilities": { + }, + "clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-06-18", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} diff --git a/tests/golden/legacy/initialize-2025-11-25.json b/tests/golden/legacy/initialize-2025-11-25.json new file mode 100644 index 0000000..207bd34 --- /dev/null +++ b/tests/golden/legacy/initialize-2025-11-25.json @@ -0,0 +1,44 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize", + "params": { + "protocolVersion": "2025-11-25", + "capabilities": { + }, + "clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-11-25", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} diff --git a/tests/golden/legacy/initialize-unknown-version.json b/tests/golden/legacy/initialize-unknown-version.json new file mode 100644 index 0000000..07cb7bb --- /dev/null +++ b/tests/golden/legacy/initialize-unknown-version.json @@ -0,0 +1,44 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize", + "params": { + "protocolVersion": "1900-01-01", + "capabilities": { + }, + "clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-11-25", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} diff --git a/tests/golden/legacy/initialize-without-params.json b/tests/golden/legacy/initialize-without-params.json new file mode 100644 index 0000000..8d495ae --- /dev/null +++ b/tests/golden/legacy/initialize-without-params.json @@ -0,0 +1,35 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize" + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-11-25", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} diff --git a/tests/golden/legacy/missing-jsonrpc-field.json b/tests/golden/legacy/missing-jsonrpc-field.json new file mode 100644 index 0000000..6bb1b4d --- /dev/null +++ b/tests/golden/legacy/missing-jsonrpc-field.json @@ -0,0 +1,14 @@ +{ + "request": { + "id": 25, + "method": "ping" + }, + "expected": { + "jsonrpc": "2.0", + "id": 25, + "error": { + "code": -32600, + "message": "jsonrpc must be \"2.0\"" + } + } +} diff --git a/tests/golden/legacy/missing-method.json b/tests/golden/legacy/missing-method.json new file mode 100644 index 0000000..aef6c0f --- /dev/null +++ b/tests/golden/legacy/missing-method.json @@ -0,0 +1,14 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 26 + }, + "expected": { + "jsonrpc": "2.0", + "id": 26, + "error": { + "code": -32600, + "message": "method must be a string" + } + } +} diff --git a/tests/golden/legacy/notifications-initialized.json b/tests/golden/legacy/notifications-initialized.json new file mode 100644 index 0000000..01e3839 --- /dev/null +++ b/tests/golden/legacy/notifications-initialized.json @@ -0,0 +1,7 @@ +{ + "request": { + "jsonrpc": "2.0", + "method": "notifications/initialized" + }, + "expectedText": "" +} diff --git a/tests/golden/legacy/params-not-an-object.json b/tests/golden/legacy/params-not-an-object.json new file mode 100644 index 0000000..ce32538 --- /dev/null +++ b/tests/golden/legacy/params-not-an-object.json @@ -0,0 +1,19 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 27, + "method": "tools/call", + "params": [ + 1, + 2 + ] + }, + "expected": { + "jsonrpc": "2.0", + "id": 27, + "error": { + "code": -32602, + "message": "params must be an object" + } + } +} diff --git a/tests/golden/legacy/parse-error.json b/tests/golden/legacy/parse-error.json new file mode 100644 index 0000000..1e39de3 --- /dev/null +++ b/tests/golden/legacy/parse-error.json @@ -0,0 +1,11 @@ +{ + "requestText": "{\"jsonrpc\":\"2.0\",\"id\":22,\"method\":", + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32700, + "message": "Invalid JSON" + } + } +} diff --git a/tests/golden/legacy/ping.json b/tests/golden/legacy/ping.json new file mode 100644 index 0000000..3275897 --- /dev/null +++ b/tests/golden/legacy/ping.json @@ -0,0 +1,13 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 2, + "method": "ping" + }, + "expected": { + "jsonrpc": "2.0", + "id": 2, + "result": { + } + } +} diff --git a/tests/golden/legacy/request-not-an-object.json b/tests/golden/legacy/request-not-an-object.json new file mode 100644 index 0000000..389d3e7 --- /dev/null +++ b/tests/golden/legacy/request-not-an-object.json @@ -0,0 +1,11 @@ +{ + "requestText": "[{\"jsonrpc\":\"2.0\",\"id\":23,\"method\":\"ping\"}]", + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32600, + "message": "JSON-RPC batch requests are not supported" + } + } +} diff --git a/tests/golden/legacy/resources-list.json b/tests/golden/legacy/resources-list.json new file mode 100644 index 0000000..951d5a1 --- /dev/null +++ b/tests/golden/legacy/resources-list.json @@ -0,0 +1,53 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 13, + "method": "resources/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 13, + "result": { + "resources": [ + { + "uri": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" + }, + { + "uri": "logs://recent", + "name": "Recent Logs", + "description": "Recent log entries from all categories", + "mimeType": "application/json" + }, + { + "uri": "project://info", + "name": "Project Information", + "description": "Basic information about the Delphi MCP Server project", + "mimeType": "application/json" + }, + { + "uri": "project://readme", + "name": "Project README", + "description": "README.md file contents", + "mimeType": "text/markdown" + }, + { + "uri": "test://static-text", + "name": "Static text", + "title": "Static text resource", + "description": "A fixed text resource", + "mimeType": "text/plain" + }, + { + "uri": "test://static-binary", + "name": "Static binary", + "title": "Static binary resource", + "description": "A fixed PNG image", + "mimeType": "image/png" + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-logs-recent.json b/tests/golden/legacy/resources-read-logs-recent.json new file mode 100644 index 0000000..7cdec3d --- /dev/null +++ b/tests/golden/legacy/resources-read-logs-recent.json @@ -0,0 +1,66 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 16, + "method": "resources/read", + "params": { + "uri": "logs://recent" + } + }, + "shape": [ + "result.contents[0].text" + ], + "expected": { + "jsonrpc": "2.0", + "id": 16, + "result": { + "contents": [ + { + "uri": "logs://recent", + "mimeType": "application/json", + "text": { + "entries": [ + { + "timestamp": "string", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "string", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "string", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "string", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "string", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + } + ], + "totalcount": "number", + "filteredcount": "number" + } + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-project-info.json b/tests/golden/legacy/resources-read-project-info.json new file mode 100644 index 0000000..e02709a --- /dev/null +++ b/tests/golden/legacy/resources-read-project-info.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 14, + "method": "resources/read", + "params": { + "uri": "project://info" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 14, + "result": { + "contents": [ + { + "uri": "project://info", + "mimeType": "application/json", + "text": "{\"name\":\"delphi-mcp-server\",\"version\":\"1.0.0\",\"description\":\"A Model Context Protocol (MCP) server implementation in Delphi\",\"language\":\"Delphi\",\"framework\":\"Indy HTTP Server (TIdHTTPServer)\",\"protocol\":\"MCP 2026-07-28 (initialize-based: 2025-11-25, 2025-06-18)\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}" + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-project-readme.json b/tests/golden/legacy/resources-read-project-readme.json new file mode 100644 index 0000000..7bffb5f --- /dev/null +++ b/tests/golden/legacy/resources-read-project-readme.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 15, + "method": "resources/read", + "params": { + "uri": "project://readme" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 15, + "result": { + "contents": [ + { + "uri": "project://readme", + "mimeType": "text/markdown", + "text": "\r\n# Delphi MCP Server\r\n\r\nA Model Context Protocol (MCP) server implementation in Delphi using Indy HTTP Server.\r\n\r\n## Features\r\n- Tools capability with automatic schema generation\r\n- Resources capability for read-only data access\r\n- JSON-RPC 2.0 protocol support\r\n- CORS support for cross-origin requests\r\n\r\n## Building\r\n```bash\r\nbuild.bat\r\n```\r\n\r\n## Running\r\n```bash\r\nWin32\\Debug\\MCPServer.exe\r\n```\r\n\r\n## Testing\r\n```bash\r\nnpx @wong2/mcp-cli --url http://localhost:8080/mcp\r\n```\r\n'" + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-server-status.json b/tests/golden/legacy/resources-read-server-status.json new file mode 100644 index 0000000..9fe5372 --- /dev/null +++ b/tests/golden/legacy/resources-read-server-status.json @@ -0,0 +1,34 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 28, + "method": "resources/read", + "params": { + "uri": "server://status" + } + }, + "shape": [ + "result.contents[0].text" + ], + "expected": { + "jsonrpc": "2.0", + "id": 28, + "result": { + "contents": [ + { + "uri": "server://status", + "mimeType": "application/json", + "text": { + "status": "string", + "uptime": "number", + "starttime": "string", + "currenttime": "string", + "memoryused": "number", + "requestcount": "number", + "activeconnections": "number" + } + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-unknown-uri.json b/tests/golden/legacy/resources-read-unknown-uri.json new file mode 100644 index 0000000..fb5ed0a --- /dev/null +++ b/tests/golden/legacy/resources-read-unknown-uri.json @@ -0,0 +1,21 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 17, + "method": "resources/read", + "params": { + "uri": "nope://missing" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 17, + "error": { + "code": -32002, + "message": "Resource not found", + "data": { + "uri": "nope://missing" + } + } + } +} diff --git a/tests/golden/legacy/resources-read-without-params.json b/tests/golden/legacy/resources-read-without-params.json new file mode 100644 index 0000000..babb234 --- /dev/null +++ b/tests/golden/legacy/resources-read-without-params.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 18, + "method": "resources/read" + }, + "expected": { + "jsonrpc": "2.0", + "id": 18, + "error": { + "code": -32602, + "message": "params.uri is required" + } + } +} diff --git a/tests/golden/legacy/resources-templates-list.json b/tests/golden/legacy/resources-templates-list.json new file mode 100644 index 0000000..b7e47a8 --- /dev/null +++ b/tests/golden/legacy/resources-templates-list.json @@ -0,0 +1,27 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 19, + "method": "resources/templates/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 19, + "result": { + "resourceTemplates": [ + { + "uriTemplate": "logs://{level}", + "name": "Recent logs by level", + "description": "Recent log entries at the given level, e.g. logs://INFO", + "mimeType": "application/json" + }, + { + "uriTemplate": "test://template/{id}/data", + "name": "Template data", + "description": "Data keyed by an id path segment", + "mimeType": "application/json" + } + ] + } + } +} diff --git a/tests/golden/legacy/server-discover-without-meta.json b/tests/golden/legacy/server-discover-without-meta.json new file mode 100644 index 0000000..1f6f1e2 --- /dev/null +++ b/tests/golden/legacy/server-discover-without-meta.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 21, + "method": "server/discover" + }, + "expected": { + "jsonrpc": "2.0", + "id": 21, + "error": { + "code": -32602, + "message": "server/discover requires params._meta.io.modelcontextprotocol/protocolVersion" + } + } +} diff --git a/tests/golden/legacy/tools-call-calculate-divide-by-zero.json b/tests/golden/legacy/tools-call-calculate-divide-by-zero.json new file mode 100644 index 0000000..d2866db --- /dev/null +++ b/tests/golden/legacy/tools-call-calculate-divide-by-zero.json @@ -0,0 +1,28 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 5, + "method": "tools/call", + "params": { + "name": "calculate", + "arguments": { + "operation": "divide", + "a": 1, + "b": 0 + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 5, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Division by zero" + } + ], + "isError": true + } + } +} diff --git a/tests/golden/legacy/tools-call-calculate.json b/tests/golden/legacy/tools-call-calculate.json new file mode 100644 index 0000000..c9404d2 --- /dev/null +++ b/tests/golden/legacy/tools-call-calculate.json @@ -0,0 +1,27 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 5, + "method": "tools/call", + "params": { + "name": "calculate", + "arguments": { + "operation": "add", + "a": 2, + "b": 3.5 + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 5, + "result": { + "content": [ + { + "type": "text", + "text": "2 add 3,5 = 5,5" + } + ] + } + } +} diff --git a/tests/golden/legacy/tools-call-echo-unicode.json b/tests/golden/legacy/tools-call-echo-unicode.json new file mode 100644 index 0000000..e304d14 --- /dev/null +++ b/tests/golden/legacy/tools-call-echo-unicode.json @@ -0,0 +1,25 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 4, + "method": "tools/call", + "params": { + "name": "echo", + "arguments": { + "message": "héllo wörld ✓ 😀" + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 4, + "result": { + "content": [ + { + "type": "text", + "text": "Echo: héllo wörld ✓ 😀" + } + ] + } + } +} diff --git a/tests/golden/legacy/tools-call-echo.json b/tests/golden/legacy/tools-call-echo.json new file mode 100644 index 0000000..d194999 --- /dev/null +++ b/tests/golden/legacy/tools-call-echo.json @@ -0,0 +1,25 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 4, + "method": "tools/call", + "params": { + "name": "echo", + "arguments": { + "message": "hello golden" + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 4, + "result": { + "content": [ + { + "type": "text", + "text": "Echo: hello golden" + } + ] + } + } +} diff --git a/tests/golden/legacy/tools-call-empty-name.json b/tests/golden/legacy/tools-call-empty-name.json new file mode 100644 index 0000000..da8239d --- /dev/null +++ b/tests/golden/legacy/tools-call-empty-name.json @@ -0,0 +1,20 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 12, + "method": "tools/call", + "params": { + "name": "", + "arguments": { + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 12, + "error": { + "code": -32602, + "message": "params.name is required and must be a non-empty string" + } + } +} diff --git a/tests/golden/legacy/tools-call-get-time.json b/tests/golden/legacy/tools-call-get-time.json new file mode 100644 index 0000000..8c25c4f --- /dev/null +++ b/tests/golden/legacy/tools-call-get-time.json @@ -0,0 +1,27 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 6, + "method": "tools/call", + "params": { + "name": "get_time", + "arguments": { + } + } + }, + "mask": [ + "result.content[0].text" + ], + "expected": { + "jsonrpc": "2.0", + "id": 6, + "result": { + "content": [ + { + "type": "text", + "text": "" + } + ] + } + } +} diff --git a/tests/golden/legacy/tools-call-invalid-argument-type.json b/tests/golden/legacy/tools-call-invalid-argument-type.json new file mode 100644 index 0000000..2af8f1f --- /dev/null +++ b/tests/golden/legacy/tools-call-invalid-argument-type.json @@ -0,0 +1,28 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 10, + "method": "tools/call", + "params": { + "name": "calculate", + "arguments": { + "operation": "add", + "a": "two", + "b": 3 + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 10, + "result": { + "content": [ + { + "type": "text", + "text": "Invalid arguments: Parameter \"a\": expected a number" + } + ], + "isError": true + } + } +} diff --git a/tests/golden/legacy/tools-call-list-files-outside-allowed-directory.json b/tests/golden/legacy/tools-call-list-files-outside-allowed-directory.json new file mode 100644 index 0000000..81c3e95 --- /dev/null +++ b/tests/golden/legacy/tools-call-list-files-outside-allowed-directory.json @@ -0,0 +1,27 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 7, + "method": "tools/call", + "params": { + "name": "list_files", + "arguments": { + "path": "../../.." + } + } + }, + "workingDirectory": "fixtures", + "expected": { + "jsonrpc": "2.0", + "id": 7, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Access denied - path outside allowed directory" + } + ], + "isError": true + } + } +} diff --git a/tests/golden/legacy/tools-call-list-files.json b/tests/golden/legacy/tools-call-list-files.json new file mode 100644 index 0000000..1e473dc --- /dev/null +++ b/tests/golden/legacy/tools-call-list-files.json @@ -0,0 +1,29 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 7, + "method": "tools/call", + "params": { + "name": "list_files", + "arguments": { + "path": "files" + } + } + }, + "workingDirectory": "fixtures", + "mask": [ + "result.content[0].text" + ], + "expected": { + "jsonrpc": "2.0", + "id": 7, + "result": { + "content": [ + { + "type": "text", + "text": "" + } + ] + } + } +} diff --git a/tests/golden/legacy/tools-call-missing-arguments.json b/tests/golden/legacy/tools-call-missing-arguments.json new file mode 100644 index 0000000..54dfb0d --- /dev/null +++ b/tests/golden/legacy/tools-call-missing-arguments.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 8, + "method": "tools/call", + "params": { + "name": "echo" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 8, + "result": { + "content": [ + { + "type": "text", + "text": "Invalid arguments: Missing required parameter \"message\"" + } + ], + "isError": true + } + } +} diff --git a/tests/golden/legacy/tools-call-unknown-tool.json b/tests/golden/legacy/tools-call-unknown-tool.json new file mode 100644 index 0000000..a2c400e --- /dev/null +++ b/tests/golden/legacy/tools-call-unknown-tool.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 9, + "method": "tools/call", + "params": { + "name": "no_such_tool", + "arguments": { + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 9, + "error": { + "code": -32602, + "message": "Unknown tool: no_such_tool", + "data": { + "name": "no_such_tool" + } + } + } +} diff --git a/tests/golden/legacy/tools-call-without-params.json b/tests/golden/legacy/tools-call-without-params.json new file mode 100644 index 0000000..4b82b2f --- /dev/null +++ b/tests/golden/legacy/tools-call-without-params.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 11, + "method": "tools/call" + }, + "expected": { + "jsonrpc": "2.0", + "id": 11, + "error": { + "code": -32602, + "message": "params.name is required" + } + } +} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json new file mode 100644 index 0000000..4046524 --- /dev/null +++ b/tests/golden/legacy/tools-list.json @@ -0,0 +1,393 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 3, + "method": "tools/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 3, + "result": { + "tools": [ + { + "name": "echo", + "description": "Echo a message back to the user", + "inputSchema": { + "type": "object", + "properties": { + "message": { + "type": "string", + "description": "Message to echo back" + } + }, + "required": [ + "message" + ] + } + }, + { + "name": "get_time", + "description": "Get the current server time in ISO format", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "list_files", + "description": "List files in a directory", + "inputSchema": { + "type": "object", + "properties": { + "path": { + "type": "string", + "description": "Directory path to list files from" + }, + "includehidden": { + "type": "boolean", + "description": "Include hidden files in the listing" + } + }, + "required": [ + "path" + ] + } + }, + { + "name": "calculate", + "description": "Perform basic arithmetic calculations", + "inputSchema": { + "type": "object", + "properties": { + "operation": { + "type": "string", + "description": "Operation: add, subtract, multiply, divide", + "enum": [ + "add", + "subtract", + "multiply", + "divide" + ] + }, + "a": { + "type": "number", + "description": "First number" + }, + "b": { + "type": "number", + "description": "Second number" + } + }, + "required": [ + "operation", + "a", + "b" + ] + } + }, + { + "name": "test_simple_text", + "description": "Returns a plain text result", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + }, + "annotations": { + "readOnlyHint": true + } + }, + { + "name": "test_image_content", + "description": "Returns an image content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_audio_content", + "description": "Returns an audio content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_embedded_resource", + "description": "Returns an embedded resource content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_multiple_content_types", + "description": "Returns text, image and embedded resource content in one result", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_tool_with_progress", + "description": "Runs a few steps and reports progress for each; honours cancellation", + "inputSchema": { + "type": "object", + "properties": { + "steps": { + "type": "integer", + "description": "Number of steps to report (default 5)" + }, + "stepms": { + "type": "integer", + "description": "Pause per step in milliseconds (default 100)" + } + } + } + }, + { + "name": "test_error_handling", + "description": "Always fails with a tool execution error", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_logging_tool", + "description": "Emits log notifications at every level; the client sees those at or above its requested level", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "json_schema_2020_12_tool", + "description": "Tool with JSON Schema 2020-12 features", + "inputSchema": { + "$schema": "https://json-schema.org/draft/2020-12/schema", + "type": "object", + "$defs": { + "address": { + "$anchor": "addressDef", + "type": "object", + "properties": { + "street": { + "type": "string" + }, + "city": { + "type": "string" + } + } + } + }, + "properties": { + "name": { + "type": "string" + }, + "address": { + "$ref": "#/$defs/address" + }, + "contactMethod": { + "type": "string", + "enum": [ + "phone", + "email" + ] + }, + "phone": { + "type": "string" + }, + "email": { + "type": "string" + } + }, + "allOf": [ + { + "anyOf": [ + { + "required": [ + "phone" + ] + }, + { + "required": [ + "email" + ] + } + ] + } + ], + "if": { + "properties": { + "contactMethod": { + "const": "phone" + } + }, + "required": [ + "contactMethod" + ] + }, + "then": { + "required": [ + "phone" + ] + }, + "else": { + "required": [ + "email" + ] + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_elicitation", + "description": "Asks the client for a name through an elicitation input request, then greets it", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_sampling", + "description": "Asks the client to sample an answer, then returns that answer", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_list_roots", + "description": "Asks the client for its roots, then lists them", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_request_state", + "description": "Asks for a confirmation and carries a signed requestState across the round trip", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_multiple_inputs", + "description": "Asks for a name, a sampled greeting and the client roots in one round trip", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_multi_round", + "description": "Asks for a name and then a colour in two consecutive round trips", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_tampered_state", + "description": "Asks for a confirmation with a signed requestState that must come back unchanged", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_capabilities", + "description": "Asks only for the kinds of input the client declared it can provide", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_missing_capability", + "description": "Requires the sampling client capability and fails with -32021 when it is absent", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_streaming_elicitation", + "description": "Logs to the response stream, then asks the client for a confirmation", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_tool_change", + "description": "Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_prompt_change", + "description": "Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_resource_change", + "description": "Reports test://static-text as updated to the clients subscribed to it", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + } + ] + } + } +} diff --git a/tests/golden/legacy/unknown-method.json b/tests/golden/legacy/unknown-method.json new file mode 100644 index 0000000..0b3ffbc --- /dev/null +++ b/tests/golden/legacy/unknown-method.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 20, + "method": "totally/bogus/method" + }, + "expected": { + "jsonrpc": "2.0", + "id": 20, + "error": { + "code": -32601, + "message": "Method [totally/bogus/method] not found. The method does not exist or is not available." + } + } +} diff --git a/tests/golden/modern/id-null.json b/tests/golden/modern/id-null.json new file mode 100644 index 0000000..365d5ab --- /dev/null +++ b/tests/golden/modern/id-null.json @@ -0,0 +1,26 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": null, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32600, + "message": "id must not be null" + } + } +} diff --git a/tests/golden/modern/initialize-with-modern-meta.json b/tests/golden/modern/initialize-with-modern-meta.json new file mode 100644 index 0000000..80489ce --- /dev/null +++ b/tests/golden/modern/initialize-with-modern-meta.json @@ -0,0 +1,33 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 12, + "method": "initialize", + "params": { + "protocolVersion": "2025-11-25", + "capabilities": { + }, + "clientInfo": { + "name": "golden-client", + "version": "1.0.0" + }, + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 12, + "error": { + "code": -32601, + "message": "Method [initialize] not found. The method does not exist or is not available." + } + } +} diff --git a/tests/golden/modern/invalid-log-level.json b/tests/golden/modern/invalid-log-level.json new file mode 100644 index 0000000..e14c4a1 --- /dev/null +++ b/tests/golden/modern/invalid-log-level.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 11, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/logLevel": "loud" + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 11, + "error": { + "code": -32602, + "message": "params._meta.io.modelcontextprotocol/logLevel must be one of debug, info, notice, warning, error, critical, alert, emergency" + } + } +} diff --git a/tests/golden/modern/missing-client-capabilities.json b/tests/golden/modern/missing-client-capabilities.json new file mode 100644 index 0000000..68d1299 --- /dev/null +++ b/tests/golden/modern/missing-client-capabilities.json @@ -0,0 +1,20 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 10, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28" + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 10, + "error": { + "code": -32602, + "message": "params._meta.io.modelcontextprotocol/clientCapabilities is required and must be an object" + } + } +} diff --git a/tests/golden/modern/missing-jsonrpc-field.json b/tests/golden/modern/missing-jsonrpc-field.json new file mode 100644 index 0000000..8c4e4d8 --- /dev/null +++ b/tests/golden/modern/missing-jsonrpc-field.json @@ -0,0 +1,25 @@ +{ + "request": { + "id": 13, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 13, + "error": { + "code": -32600, + "message": "jsonrpc must be \"2.0\"" + } + } +} diff --git a/tests/golden/modern/ping.json b/tests/golden/modern/ping.json new file mode 100644 index 0000000..ee4cf15 --- /dev/null +++ b/tests/golden/modern/ping.json @@ -0,0 +1,26 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 7, + "method": "ping", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 7, + "error": { + "code": -32601, + "message": "Method [ping] not found. The method does not exist or is not available." + } + } +} diff --git a/tests/golden/modern/resources-list.json b/tests/golden/modern/resources-list.json new file mode 100644 index 0000000..986f19d --- /dev/null +++ b/tests/golden/modern/resources-list.json @@ -0,0 +1,73 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 4, + "method": "resources/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 4, + "result": { + "resources": [ + { + "uri": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" + }, + { + "uri": "logs://recent", + "name": "Recent Logs", + "description": "Recent log entries from all categories", + "mimeType": "application/json" + }, + { + "uri": "project://info", + "name": "Project Information", + "description": "Basic information about the Delphi MCP Server project", + "mimeType": "application/json" + }, + { + "uri": "project://readme", + "name": "Project README", + "description": "README.md file contents", + "mimeType": "text/markdown" + }, + { + "uri": "test://static-text", + "name": "Static text", + "title": "Static text resource", + "description": "A fixed text resource", + "mimeType": "text/plain" + }, + { + "uri": "test://static-binary", + "name": "Static binary", + "title": "Static binary resource", + "description": "A fixed PNG image", + "mimeType": "image/png" + } + ], + "ttlMs": 0, + "cacheScope": "private", + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/resources-read-project-info.json b/tests/golden/modern/resources-read-project-info.json new file mode 100644 index 0000000..2a5ef13 --- /dev/null +++ b/tests/golden/modern/resources-read-project-info.json @@ -0,0 +1,41 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 5, + "method": "resources/read", + "params": { + "uri": "project://info", + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 5, + "result": { + "contents": [ + { + "uri": "project://info", + "mimeType": "application/json", + "text": "{\"name\":\"delphi-mcp-server\",\"version\":\"1.0.0\",\"description\":\"A Model Context Protocol (MCP) server implementation in Delphi\",\"language\":\"Delphi\",\"framework\":\"Indy HTTP Server (TIdHTTPServer)\",\"protocol\":\"MCP 2026-07-28 (initialize-based: 2025-11-25, 2025-06-18)\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}" + } + ], + "ttlMs": 3600000, + "cacheScope": "public", + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/resources-templates-list.json b/tests/golden/modern/resources-templates-list.json new file mode 100644 index 0000000..56559a1 --- /dev/null +++ b/tests/golden/modern/resources-templates-list.json @@ -0,0 +1,47 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 6, + "method": "resources/templates/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 6, + "result": { + "resourceTemplates": [ + { + "uriTemplate": "logs://{level}", + "name": "Recent logs by level", + "description": "Recent log entries at the given level, e.g. logs://INFO", + "mimeType": "application/json" + }, + { + "uriTemplate": "test://template/{id}/data", + "name": "Template data", + "description": "Data keyed by an id path segment", + "mimeType": "application/json" + } + ], + "ttlMs": 0, + "cacheScope": "private", + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/server-discover-without-meta.json b/tests/golden/modern/server-discover-without-meta.json new file mode 100644 index 0000000..abc12be --- /dev/null +++ b/tests/golden/modern/server-discover-without-meta.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": "discover-2", + "method": "server/discover" + }, + "expected": { + "jsonrpc": "2.0", + "id": "discover-2", + "error": { + "code": -32602, + "message": "server/discover requires params._meta.io.modelcontextprotocol/protocolVersion" + } + } +} diff --git a/tests/golden/modern/server-discover.json b/tests/golden/modern/server-discover.json new file mode 100644 index 0000000..e8c2d7a --- /dev/null +++ b/tests/golden/modern/server-discover.json @@ -0,0 +1,50 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": "discover-1", + "method": "server/discover", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": "discover-1", + "result": { + "resultType": "complete", + "supportedVersions": [ + "2026-07-28" + ], + "capabilities": { + "tools": { + "listChanged": true + }, + "resources": { + "subscribe": true, + "listChanged": true + }, + "prompts": { + "listChanged": true + }, + "completions": { + } + }, + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + }, + "ttlMs": 0, + "cacheScope": "public" + } + } +} diff --git a/tests/golden/modern/tools-call-echo.json b/tests/golden/modern/tools-call-echo.json new file mode 100644 index 0000000..d9d9fe2 --- /dev/null +++ b/tests/golden/modern/tools-call-echo.json @@ -0,0 +1,41 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 2, + "method": "tools/call", + "params": { + "name": "echo", + "arguments": { + "message": "hello modern" + }, + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 2, + "result": { + "content": [ + { + "type": "text", + "text": "Echo: hello modern" + } + ], + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/tools-call-unknown-tool.json b/tests/golden/modern/tools-call-unknown-tool.json new file mode 100644 index 0000000..1a79437 --- /dev/null +++ b/tests/golden/modern/tools-call-unknown-tool.json @@ -0,0 +1,32 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 3, + "method": "tools/call", + "params": { + "name": "no_such_tool", + "arguments": { + }, + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 3, + "error": { + "code": -32602, + "message": "Unknown tool: no_such_tool", + "data": { + "name": "no_such_tool" + } + } + } +} diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json new file mode 100644 index 0000000..5f03ac8 --- /dev/null +++ b/tests/golden/modern/tools-list.json @@ -0,0 +1,413 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "tools": [ + { + "name": "echo", + "description": "Echo a message back to the user", + "inputSchema": { + "type": "object", + "properties": { + "message": { + "type": "string", + "description": "Message to echo back" + } + }, + "required": [ + "message" + ] + } + }, + { + "name": "get_time", + "description": "Get the current server time in ISO format", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "list_files", + "description": "List files in a directory", + "inputSchema": { + "type": "object", + "properties": { + "path": { + "type": "string", + "description": "Directory path to list files from" + }, + "includehidden": { + "type": "boolean", + "description": "Include hidden files in the listing" + } + }, + "required": [ + "path" + ] + } + }, + { + "name": "calculate", + "description": "Perform basic arithmetic calculations", + "inputSchema": { + "type": "object", + "properties": { + "operation": { + "type": "string", + "description": "Operation: add, subtract, multiply, divide", + "enum": [ + "add", + "subtract", + "multiply", + "divide" + ] + }, + "a": { + "type": "number", + "description": "First number" + }, + "b": { + "type": "number", + "description": "Second number" + } + }, + "required": [ + "operation", + "a", + "b" + ] + } + }, + { + "name": "test_simple_text", + "description": "Returns a plain text result", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + }, + "annotations": { + "readOnlyHint": true + } + }, + { + "name": "test_image_content", + "description": "Returns an image content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_audio_content", + "description": "Returns an audio content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_embedded_resource", + "description": "Returns an embedded resource content block", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_multiple_content_types", + "description": "Returns text, image and embedded resource content in one result", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_tool_with_progress", + "description": "Runs a few steps and reports progress for each; honours cancellation", + "inputSchema": { + "type": "object", + "properties": { + "steps": { + "type": "integer", + "description": "Number of steps to report (default 5)" + }, + "stepms": { + "type": "integer", + "description": "Pause per step in milliseconds (default 100)" + } + } + } + }, + { + "name": "test_error_handling", + "description": "Always fails with a tool execution error", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_logging_tool", + "description": "Emits log notifications at every level; the client sees those at or above its requested level", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "json_schema_2020_12_tool", + "description": "Tool with JSON Schema 2020-12 features", + "inputSchema": { + "$schema": "https://json-schema.org/draft/2020-12/schema", + "type": "object", + "$defs": { + "address": { + "$anchor": "addressDef", + "type": "object", + "properties": { + "street": { + "type": "string" + }, + "city": { + "type": "string" + } + } + } + }, + "properties": { + "name": { + "type": "string" + }, + "address": { + "$ref": "#/$defs/address" + }, + "contactMethod": { + "type": "string", + "enum": [ + "phone", + "email" + ] + }, + "phone": { + "type": "string" + }, + "email": { + "type": "string" + } + }, + "allOf": [ + { + "anyOf": [ + { + "required": [ + "phone" + ] + }, + { + "required": [ + "email" + ] + } + ] + } + ], + "if": { + "properties": { + "contactMethod": { + "const": "phone" + } + }, + "required": [ + "contactMethod" + ] + }, + "then": { + "required": [ + "phone" + ] + }, + "else": { + "required": [ + "email" + ] + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_elicitation", + "description": "Asks the client for a name through an elicitation input request, then greets it", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_sampling", + "description": "Asks the client to sample an answer, then returns that answer", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_list_roots", + "description": "Asks the client for its roots, then lists them", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_request_state", + "description": "Asks for a confirmation and carries a signed requestState across the round trip", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_multiple_inputs", + "description": "Asks for a name, a sampled greeting and the client roots in one round trip", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_multi_round", + "description": "Asks for a name and then a colour in two consecutive round trips", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_tampered_state", + "description": "Asks for a confirmation with a signed requestState that must come back unchanged", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_input_required_result_capabilities", + "description": "Asks only for the kinds of input the client declared it can provide", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_missing_capability", + "description": "Requires the sampling client capability and fails with -32021 when it is absent", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_streaming_elicitation", + "description": "Logs to the response stream, then asks the client for a confirmation", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_tool_change", + "description": "Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_prompt_change", + "description": "Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + }, + { + "name": "test_trigger_resource_change", + "description": "Reports test://static-text as updated to the clients subscribed to it", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false + } + } + ], + "ttlMs": 0, + "cacheScope": "private", + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/unknown-method.json b/tests/golden/modern/unknown-method.json new file mode 100644 index 0000000..ef52b9d --- /dev/null +++ b/tests/golden/modern/unknown-method.json @@ -0,0 +1,26 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 8, + "method": "totally/bogus/method", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "2026-07-28", + "io.modelcontextprotocol/clientCapabilities": { + }, + "io.modelcontextprotocol/clientInfo": { + "name": "golden-client", + "version": "1.0.0" + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 8, + "error": { + "code": -32601, + "message": "Method [totally/bogus/method] not found. The method does not exist or is not available." + } + } +} diff --git a/tests/golden/modern/unknown-protocol-version.json b/tests/golden/modern/unknown-protocol-version.json new file mode 100644 index 0000000..815326b --- /dev/null +++ b/tests/golden/modern/unknown-protocol-version.json @@ -0,0 +1,28 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 9, + "method": "tools/list", + "params": { + "_meta": { + "io.modelcontextprotocol/protocolVersion": "1900-01-01", + "io.modelcontextprotocol/clientCapabilities": { + } + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 9, + "error": { + "code": -32022, + "message": "Unsupported protocol version", + "data": { + "supported": [ + "2026-07-28" + ], + "requested": "1900-01-01" + } + } + } +}