diff --git a/.gitignore b/.gitignore index 5de0fe5..cee8dee 100644 --- a/.gitignore +++ b/.gitignore @@ -91,6 +91,9 @@ backup/ *.temp ~$* -# Claude Code specific - # Dependencies +package-lock.json + +# Test and conformance output +tests/results/ +results/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..5bb3b5a --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,497 @@ +# 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`, re-recorded + with `MCP_GOLDEN_RECORD=1`. +- `build-tests.bat` compiles the test project. +- 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, with `MarkReadOnly(OpenWorld)` on the tool bases for the two + hints a client uses to decide about parallel or auto-approved calls + (`test_simple_text` publishes `readOnlyHint: true, openWorldHint: false`); 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, + which is the only cancellation over HTTP: a `notifications/cancelled` + arrives on a connection of its own and is answered `202` and dropped. + `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. +- `MCPServer.Host` (`TMCPServerHost`): the manager composition behind one + class, for an application that embeds the server. `StartHttp` returns as soon + as the server listens, `Stop` and `StartHttp` are idempotent, and `AddTool`, + `RemoveTool`, `HasTool`, `AddResource` and `AddPrompt` fill the managers + directly. A host publishes only what it was given; `SeedFromGlobalRegistry`, + set before the managers are built, takes `TMCPRegistry` instead, so two hosts + in one process publish exactly what each of them was handed. + `[Server] ExposeDiagnosticsResources` is honoured either way. `Create` reads + no settings file, `Create(SettingsFile)` reads the file it is named and + writes none, and `Create(Settings)` takes a `TMCPSettings` the caller keeps + owning; only the standalone server reads `settings.ini` from the executable's + directory. `RunStdio` is the blocking console entry point and + `RunStdioWith(Input, Output)` runs the same dispatch over two streams. + `TMCPServerApplication` is built on the host, so the composition exists once. +- `TMCPToolsManager.Create(SeedFromRegistry)`, and the same overload on + `TMCPResourcesManager` and `TMCPPromptsManager`: a manager that starts empty + instead of reading `TMCPRegistry`. The parameterless constructor still seeds. +- `TMCPIdHTTPServer.BoundPort`: the port the listener took, which is the one to + dial after `Port = 0`. A loopback or all-interfaces server on port 0 now + claims one ephemeral port and gives it to both the IPv4 and the IPv6 binding, + so the bound port is the same one whichever family a client resolves first. +- `MCPServer.Tool.Method` (`TMCPMethodTool`): a tool whose shape comes from a + method. The input schema is generated from the parameter list, the arguments + are marshalled onto it, the method is invoked and its result is converted + back to JSON: `{"ok": true}` for a procedure, `{"result": ...}` for a + function. `MarshalArgument`, `ResultToJson`, `ReleaseResult` and + `ReleaseArguments` are virtual. By default the tool frees every object it + marshalled from the arguments and every object the method returned; a method + that keeps what it is handed, or hands back something it still owns, + overrides the matching release to do nothing. +- `TMCPSchemaGenerator.GenerateSchemaFromMethod`, `GenerateSchemaFromType` and + `GenerateSchemaFromMethodResult`: the input schema of a parameter list, the + schema of a single type, and the `{"result": ...}` wrapper of a return type. + An untyped parameter, and a `var` or `out` parameter, are refused with an + `EArgumentException` naming the parameter, because a tool answers with its + result and not through its arguments. `$schema` from `[SchemaDialect]` stays + on the root schema and is never copied into a parameter or result member. +- `TMCPSerializer.JsonToValue` and `ValueToJson`: the runtime marshal on a + `TRttiType` rather than a class. `JsonToValue` appends every object it + created to the list the caller passes, so the caller can free them. +- `TMCPHeaderValue.Encode`: the counterpart of `TryDecode`, passing a + header-safe value through and wrapping anything else in the `=?base64?...?=` + sentinel. `MCP_HEADER_SESSION_ID`, `MCP_HEADER_PROTOCOL_VERSION`, + `MCP_HEADER_METHOD` and `MCP_HEADER_NAME` in `MCPServer.Types` are the one + place the four MCP header names are spelled; the HTTP server and the JSON-RPC + processor read them from there. +- Records are first-class in a schema and on the wire. + `MCPServer.Schema.Generator` describes a record as the `type: object` a class + produces, with one property per public field, `required` for the fields + without `[Optional]`, and the same depth guard, so records nest, hold arrays, + hold classes, sit inside classes and cannot recurse forever. Every schema + attribute that works on a class property works on a record field. + `MCPServer.Serializer` builds a record from a JSON object and writes one back + out; a record is a value and is never put up for freeing, while an object it + holds is. `TMCPMethodTool` therefore takes a record parameter and returns a + record result with no special case of its own. A `TGUID` is described as a + `string` with `format: uuid` and travels as + `f81d4fae-7dec-11d0-a765-00a0c91e6bf6`, read with or without braces, because + its `D4` member is an anonymous array `System` publishes no type for. A + record whose unit publishes no field RTTI has no fields to describe and keeps + the `string` every record was published as; a method tool refuses such a + record as a parameter, naming the record and the + `{$RTTI EXPLICIT FIELDS([vcPublic])}` that fixes it, and publishes no output + schema for it as a result. +- `TMCPSchemaGenerator` refuses a field, property or array element whose type + carries no RTTI at all, with an `EArgumentException` naming the member. + Reading the type kind off a member that has none was an access violation, and + a `TGUID` was the way into it. +- Delphi 11 Alexandria project files `src/MCPServer.D11.dproj` and + `tests/MCPServerTests.D11.dproj`, which build the same units into a separate + `D11` output directory. The source itself needs nothing newer than + Alexandria; only the Athens project files (`ProjectVersion 20.3`) did. + +### Changed + +- `build.bat` and `build-tests.bat` keep a `DELPHI_PATH` set in the + environment instead of overwriting it, so another Delphi installation can be + used without editing the scripts. + +- `MCPServer.Application` holds the wiring the executable used to repeat for + each transport: `TMCPServerApplication` builds a `TMCPServerHost` seeded from + the global registry, `RunHttp` and `RunStdio` drive it, and the program file + is the command-line entry point only. +- The content block helpers, the protocol version helpers and the redaction + helpers are class functions on `TMCPContentBlock`, `TMCPProtocolVersion` and + `TLogger`; `MCPServer.Schema.Generator` keeps its RTTI context in a class + variable instead of an `initialization` section. +- A type the schema generator cannot describe is refused instead of published + as a string. A parameter, property or field whose type is a pointer, + procedure or method reference, class reference, interface or variant raises + `EArgumentException` naming the member and its type, and so does a record + whose unit publishes no field RTTI, which would otherwise be published as an + object with no members. +- `IMCPAuthorizer.Authorize` returns a `TMCPAuthResult`, a custom authorizer + overrides `TryValidateToken`, `TMCPLineReader.TryReadLine` returns a + `TMCPLine`, `TMCPSchemaValidator.TryValidate` replaces `Validate`, and + `TMCPResourceTemplateBase.CompilePattern` returns a `TMCPCompiledTemplate`. +- `TMCPRegistry` raises `EMCPRegistryNotFound`, the managers raise + `EMCPError.MethodNotFound` for a method they do not handle, and + `TMCPIdHTTPServer` raises `EMCPConfigurationError`; no code path raises the + base `Exception` any more. + +- `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`). +- A record-typed property of a tool's parameter class is published as the + `type: object` its public fields describe and filled from that object. It + used to be published as a `string` and dropped when the arguments were + unmarshalled. Every other property the generator cannot describe, a variant, + an interface, a method pointer or a class reference, keeps that `string`, so + a tool that listed before lists now. MIGRATION.md carries the detail. + +### Fixed + +- A record that failed to convert halfway leaked the objects it already held: + `TMCPSerializer.JsonToValue` adds them to the caller's list only once the + whole record is built, so `{"line": {"sku": "a"}, "count": "x"}` created an + object and destroyed none. The half-built record is emptied on the way out, + the way a nested class already was. +- Enumeration sets with more than 64 elements were truncated when serialised, + and a JSON number outside the range of its target integer type was silently + wrapped instead of rejected. +- `TServerStatusResource.SetNamePrefix` removed the old registration before + adding the new one, so a failure left the server without a status resource. +- `logs://recent` and `logs://{level}` leaked their result when reading the + log buffer failed. +- A rejected `Origin` or `Host` now answers `403` with the CORS headers, so a + browser can read the error instead of seeing an opaque failure. +- `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. +- `build.bat` and `build-tests.bat` quote the TaurusTLS path they pass to the + compiler, so a path with a space no longer splits the `-I` and `-R` + arguments, and a build without TaurusTLS no longer passes a bare `-R`. diff --git a/MIGRATION.md b/MIGRATION.md new file mode 100644 index 0000000..71339c5 --- /dev/null +++ b/MIGRATION.md @@ -0,0 +1,278 @@ +# 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, and that is the +only cancellation over HTTP: a `notifications/cancelled` for a request still +in flight arrives on a connection of its own, is answered `202` and is +dropped, because the tracker a request consults is its own response stream. +Over stdio the same notification does stop 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. + +**A record property is described and filled.** A property whose type is a +record used to be published as `{"type": "string"}` and dropped when the +arguments were unmarshalled. It is now published as the `type: object` its +public fields describe, and filled from that object, so a client that sent a +string for it must send an object, and a tool that always read such a property +as empty now receives what the caller sent. A `TGUID` property stays a string +and gains `format: uuid`. A record whose unit publishes no field RTTI has no +fields to describe and stays the string it was; "Records in a schema" in the +README carries the directive that makes those fields visible. Properties of +every other kind are unchanged: a variant, an interface, a method pointer or a +class reference is still published as `string`, so a tool that listed before +lists now. + +**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). + +## Renamed and reshaped API + +These types are new in this release, so the change only affects code written +against a pre-release build: + +- The content block helpers are class functions on `TMCPContentBlock` + (`TMCPContentBlock.Text`, `.Image`, `.Audio`, `.ResourceLink`, + `.EmbeddedText`, `.EmbeddedBlob`, `.EncodeBlob`). +- The protocol version helpers are class functions on `TMCPProtocolVersion` + (`IsLegacy`, `IsModern`, `NegotiateLegacy`). +- `IMCPAuthorizer.Authorize` returns a `TMCPAuthResult` (decision, principal, + challenge) instead of writing two `out` parameters, and the method a custom + authorizer overrides is `TryValidateToken`. +- `TMCPLineReader.TryReadLine` returns a `TMCPLine` (status and text). +- `TMCPSchemaValidator.TryValidate` is the new name of `Validate`. +- `TMCPRegistry` raises `EMCPRegistryNotFound` for an unknown name, the + managers raise `EMCPError.MethodNotFound`, and `TMCPIdHTTPServer` raises + `EMCPConfigurationError` for a missing registry or certificate. + +## 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..30fbb7e 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,9 @@ # Delphi MCP Server -![Delphi](https://img.shields.io/badge/Delphi-12%2B-red) +![Delphi](https://img.shields.io/badge/Delphi-11%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,36 +13,53 @@ 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) - [Support](#support) +- [Commercial Support](#commercial-support) ## 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 -- **High Performance**: Native implementation using Indy HTTP Server with keep-alive support +- **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 +- **Native HTTP stack**: Indy HTTP server with keep-alive, no external runtime - **Optional Parameters**: Support for optional tool parameters using custom attributes - **Cross-Platform**: Supports Windows (Win32/Win64) and Linux (x64) ## Requirements -- Delphi 12 Athens or later +- Delphi 11 Alexandria or later. The source uses no language feature beyond inline variables (10.3) and no RTL unit newer than Delphi 11; development happens on Delphi 12 Athens, which is what the default project files target. - Windows (Win32/Win64) or Linux (x64) - No external dependencies (all required libraries included) +### Building with Delphi 11 Alexandria + +`build.bat` and `build-tests.bat` compile the `.dpr` directly, so only `DELPHI_PATH` needs to point at your installation: + +```bash +set DELPHI_PATH=C:\Program Files (x86)\Embarcadero\Studio\22.0 +build.bat +``` + +For the IDE and for the Linux64 build, open `src/MCPServer.D11.dproj` (tests: `tests/MCPServerTests.D11.dproj`) instead of the Athens project files. They carry the same units and settings, write their output to a separate `D11` subdirectory, and exist because Alexandria will not load a `ProjectVersion 20.3` project file. + ## Installation ### For Standalone Usage @@ -118,9 +135,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 +149,84 @@ 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: the server's next write to it fails and the tool sees +`IsCancelled`. That is the HTTP cancellation. A `notifications/cancelled` +naming the same request is answered `202` and dropped, because the tracker a +request consults is its own response stream and a notification always arrives +on a connection of its own; only over stdio, where every message shares one +channel, does the notification stop a running 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. + +Notifications are delivered synchronously on the thread that causes the +change, so a subscriber that stops reading can hold up that thread until its +socket buffer drains. + +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,21 +254,25 @@ 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: +2. **Required Units**: `MCPServer.Host` is the only unit a host needs; it pulls + in the managers, the HTTP server and the stdio transport: ```pascal - MCPServer.Types, - MCPServer.Settings, - MCPServer.Registration, - MCPServer.ManagerRegistry, - MCPServer.IdHTTPServer, // For HTTP transport - MCPServer.StdioTransport, // For STDIO transport - MCPServer.JsonRpcProcessor // Shared JSON-RPC processing + MCPServer.Host, // TMCPServerHost, the library facade + MCPServer.Types, // Interfaces, protocol constants, schema attributes + MCPServer.Registration // TMCPRegistry, for self-registering tools ``` + Composing the managers by hand instead needs `MCPServer.Settings`, + `MCPServer.ManagerRegistry`, `MCPServer.CoreManager`, the managers you want, + and `MCPServer.IdHTTPServer` or `MCPServer.StdioTransport`. ### Library Integration -Once you have the project setup complete, the simplest way to add MCP capabilities to your application: +`TMCPServerHost` (`MCPServer.Host`) is the whole composition behind one class: +it builds the managers, owns the HTTP server and drives either transport. +`StartHttp` returns as soon as the server listens, so the host fits into an +application that has a message loop of its own: ```pascal program YourMCPServer; @@ -179,36 +281,77 @@ program YourMCPServer; uses System.SysUtils, - MCPServer.Types in 'lib\mcpserver\src\Protocol\MCPServer.Types.pas', - MCPServer.IdHTTPServer in 'lib\mcpserver\src\Server\MCPServer.IdHTTPServer.pas', - MCPServer.Settings in 'lib\mcpserver\src\Core\MCPServer.Settings.pas', - MCPServer.ManagerRegistry in 'lib\mcpserver\src\Core\MCPServer.ManagerRegistry.pas', - MCPServer.CoreManager in 'lib\mcpserver\src\Managers\MCPServer.CoreManager.pas', - MCPServer.ToolsManager in 'lib\mcpserver\src\Managers\MCPServer.ToolsManager.pas', - MCPServer.ResourcesManager in 'lib\mcpserver\src\Managers\MCPServer.ResourcesManager.pas'; + MCPServer.Host in 'lib\mcpserver\src\Server\MCPServer.Host.pas', + YourProject.Tool.Custom in 'YourProject.Tool.Custom.pas'; + +begin + const Host = TMCPServerHost.Create; + try + Host.Settings.Port := 3000; + Host.AddTool(TCustomTool.Create); + Host.StartHttp; + Writeln('MCP Server running on port ', Host.BoundPort); + Readln; + + Host.Stop; + finally + Host.Free; + end; +end. +``` + +**What a host starts with.** Nothing. A fresh host publishes only the tools, +resources, resource templates and prompts it was handed through `AddTool`, +`AddResource` and `AddPrompt`, so two hosts in one process publish exactly what +each of them was given. `SeedFromGlobalRegistry := True` takes everything from +`TMCPRegistry` instead, which is what the standalone server does; set it before +the first call that builds the managers, or it raises +`EMCPConfigurationError`. `[Server] ExposeDiagnosticsResources` is honoured +either way: with it off, `server://status`, `logs://recent` and `logs://{level}` +never reach the lists. + +**Settings.** `Create` reads no file at all and starts from the built-in +defaults, which `Host.Settings` then lets you change in code. +`Create(SettingsFile)` reads the `.ini` you name and writes none. +`Create(Settings)` takes a `TMCPSettings` you built yourself and keep owning. +Only the standalone server reads `settings.ini` from the executable's own +directory. + +**Ports.** `Settings.Port := 0` asks the operating system for a free port and +`BoundPort` reports the one it gave. A loopback server takes that same port on +both its IPv4 and its IPv6 binding, so `localhost` reaches it whichever family +the client resolves first. `StartHttp` and `Stop` are both idempotent. + +**Transports.** `RunStdio` blocks and is a console entry point only: the stdio +transport claims stdout and redirects the logger to stderr for the whole +process, so a GUI application must never call it. `RunStdioWith(Input, Output)` +runs the same dispatch over two streams, which is how a test drives one line in +and reads one line out. + +Composing the managers by hand still works, and is what to do when you need a +manager the host does not build: + +```pascal var - Server: TMCPIdHTTPServer; - Settings: TMCPSettings; ManagerRegistry: IMCPManagerRegistry; - begin - Settings := TMCPSettings.Create; + const Settings = TMCPSettings.Create; try ManagerRegistry := TMCPManagerRegistry.Create; ManagerRegistry.RegisterManager(TMCPCoreManager.Create(Settings)); - ManagerRegistry.RegisterManager(TMCPToolsManager.Create); - ManagerRegistry.RegisterManager(TMCPResourcesManager.Create); - - Server := TMCPIdHTTPServer.Create(nil); + ManagerRegistry.RegisterManager(TMCPToolsManager.Create(False)); + ManagerRegistry.RegisterManager(TMCPResourcesManager.Create(False)); + + const Server = TMCPIdHTTPServer.Create(nil); try Server.Settings := Settings; Server.ManagerRegistry := ManagerRegistry; Server.Start; - - Writeln('MCP Server running on port ', Settings.Port); - Readln; // Keep running - + + Writeln('MCP Server running on port ', Server.BoundPort); + Readln; + Server.Stop; finally Server.Free; @@ -219,6 +362,14 @@ begin end. ``` +#### Library checklist + +- **Register before you start, or hand them over afterwards.** The parameterless `TMCPToolsManager.Create`, `TMCPResourcesManager.Create` and `TMCPPromptsManager.Create` read `TMCPRegistry` once, so a registration made after the managers exist is not picked up: register your tools, resources and prompts (normally from unit `initialization` sections) first. `Create(False)`, and a `TMCPServerHost` left at its default `SeedFromGlobalRegistry`, read the registry not at all and publish only what you hand them, which you can do at any time. +- **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`, and reaches every manager that seeds from the registry. `TServerStatusResource.SetNamePrefix('myapp_')` renames it to `server://myapp_status`; call it before the managers are created. `[Server] ExposeDiagnosticsResources = false` keeps it, `logs://recent` and `logs://{level}` out of the lists altogether. +- **Error codes and protocol constants** live in `MCPServer.Types` (`JSONRPC_*`, `MCP_ERROR_*`, `MCP_PROTOCOL_VERSION_*`, `MCP_META_*`, and the header names `MCP_HEADER_SESSION_ID`, `MCP_HEADER_PROTOCOL_VERSION`, `MCP_HEADER_METHOD` and `MCP_HEADER_NAME`). The `JSONRPC_*` names in `MCPServer.JsonRpcProcessor` remain as aliases. `TMCPHeaderValue.Encode` (`MCPServer.HttpHeaders`) writes a value into a header the way `TryDecode` reads one back: a header-safe value passes through, anything else is wrapped in the `=?base64?...?=` sentinel. +- **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 +434,251 @@ 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. + +#### Records in a schema + +A record is described exactly the way a class is: `type: object` with one +`properties` member per **public field**, and a `required` array holding the +fields that carry no `[Optional]`. Records nest, hold arrays, hold classes and +sit inside classes; the walk stops at the same depth guard the class walk uses, +so a record that reaches itself through a `TArray` cannot recurse forever. +Every attribute that works on a class property works on a record field: +`[SchemaDescription]`, `[SchemaTitle]`, `[SchemaFormat]`, `[SchemaMinimum]`, +`[SchemaMaximum]`, `[SchemaMinLength]`, `[SchemaMaxLength]`, `[SchemaPattern]`, +`[SchemaDefault]`, `[SchemaName]` and `[Optional]`. + +```pascal +type + TMoney = record + [SchemaDescription('Amount in the smallest unit')] + [SchemaMinimum(0)] + Amount: Double; + + [SchemaName('currency_code')] + [SchemaPattern('^[A-Z]{3}$')] + Currency: string; + + [Optional] + Note: string; + end; +``` + +```json +{ + "type": "object", + "properties": { + "amount": { "type": "number", "description": "Amount in the smallest unit", "minimum": 0 }, + "currency_code": { "type": "string", "pattern": "^[A-Z]{3}$" }, + "note": { "type": "string" } + }, + "required": ["amount", "currency_code"] +} +``` + +The same shape crosses the wire in both directions: `MCPServer.Serializer` +builds the record from a JSON object and writes it back out, with enumerations +by name, `TDateTime` as ISO 8601, and an absent `[Optional]` field left at the +default of its type. A record is a value, so nothing about it is freed after a +call; an object a record holds is owned by the call and freed with it. + +**What a record needs from RTTI.** The generator reads a record's fields and +their attributes through extended RTTI, so the unit that declares the record +must publish field RTTI for the visibility the fields have. Delphi's default +(`FIELDS([vcPrivate, vcProtected, vcPublic])`) already does, so a record in an +ordinary unit needs nothing. A unit that narrows the setting must keep public +fields in it: + +```pascal +{$RTTI EXPLICIT FIELDS([vcPublic])} +``` + +A record whose fields are invisible has nothing to describe. As a property of a +parameter class it keeps the `{"type": "string"}` every record was published as +before, so a tool that has always listed goes on listing. As a parameter of a +method tool it is refused instead, naming the record and this directive, +because a tool written against this version should not ship a schema that does +not match what the method takes. + +The same split applies to a type with no JSON shape at all: a pointer, a +procedure or method reference, a class reference, an interface or a variant is +published as `string` on the class walk, the way it always was, and refused as +a method parameter, naming the parameter and its type. One property the +generator cannot describe therefore never costs a `tools/list` its other tools. +A field, property or array element whose type carries no RTTI at all is refused +wherever it appears, naming the member, because there is nothing left to fall +back on. Private fields are skipped silently, because a private field is not +part of the wire. + +**`TGUID`.** A `TGUID` is a record, but its `D4` member is an anonymous array +that `System` publishes no type for, so a `TGUID` has no members to walk. It is +published as `{"type": "string", "format": "uuid"}` and travels as +`f81d4fae-7dec-11d0-a765-00a0c91e6bf6`, written in lower case without braces +and read with or without them. + +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` or `FIcons` in the constructor to publish them in +`tools/list`; `MarkReadOnly` writes the `readOnlyHint` and `openWorldHint` +pair for a tool that only reads (pass `True` when it reaches outside the +server). `MCPServer.Tool.ContentSamples` +has one small example per content type. + +### A tool from a method + +`TMCPMethodTool` (`MCPServer.Tool.Method`) turns a method you already have into +a tool. The input schema comes from the parameter list, the arguments are +marshalled onto it, the method is invoked, and its result is converted back to +JSON: + +```pascal +type + TOrderService = class + public + function PlaceOrder([SchemaDescription('Customer code')] const Customer: string; + [Optional] const Quantity: Integer): string; + end; + +var + Context: TRttiContext; +begin + const Service = TOrderService.Create; + const Method = Context.GetType(TOrderService).GetMethod('PlaceOrder'); + + Host.AddTool(TMCPMethodTool.Create(TValue.From(Service), Method, + 'place_order', 'Places an order')); +end; +``` + +A parameter is published under its lower-cased name, or under `[SchemaName]` +when it carries one, and is required unless it carries `[Optional]`; every +schema attribute that works on a class property works on a parameter. The +method needs RTTI, which a public method of a class compiled with the default +`{$RTTI}` settings has, and `MarkReadOnly` writes the `readOnlyHint` pair the +same way it does for `TMCPToolBase`. + +The result of a procedure is `{"ok": true}` and the result of a function is +`{"result": }`, which is what `GetOutputSchema` describes. A descendant +that overrides `ResultToJson` replaces that object wholesale, so its envelope is +the whole structured result and is not nested under `result`; such a descendant +overrides `GetOutputSchema` with it, or the two disagree. + +**Who frees what.** Every object the tool marshalled from the arguments, and +every object the method returned, is freed after the call, along with the +elements of a returned dynamic array of objects. That is the wrong rule for a +method that keeps what it is handed, which is the ordinary `Add(Item)` shape in +Delphi, and for a method that hands back something it still owns. Both are +virtual, so a descendant says so: + +```pascal +type + TAdoptingTool = class(TMCPMethodTool) + protected + procedure ReleaseArguments(const Owned: TList); override; + procedure ReleaseResult(const Value: TValue; const ResultType: TRttiType); override; + end; + +procedure TAdoptingTool.ReleaseArguments(const Owned: TList); +begin +end; + +procedure TAdoptingTool.ReleaseResult(const Value: TValue; const ResultType: TRttiType); +begin +end; +``` + +An untyped parameter, and a `var` or `out` parameter, have no place in a schema: +a tool answers with its result, not through its arguments. Both are refused when +the tool is created, with an `EArgumentException` naming the parameter. + +The three generator entry points are usable on their own: +`TMCPSchemaGenerator.GenerateSchemaFromMethod` builds the input schema of a +parameter list, `GenerateSchemaFromType` the schema of a single type, and +`GenerateSchemaFromMethodResult` the `{"result": ...}` wrapper of a return type +(`nil` for a procedure, and for a return type that has no JSON shape). `$schema` +from `[SchemaDialect]` belongs to a root schema only and is never copied into a +parameter or result member. The marshal underneath them is public too: +`TMCPSerializer.JsonToValue` builds a `TValue` of a given `TRttiType` from a +`TJSONValue` and appends every object it created to the list you pass, and +`TMCPSerializer.ValueToJson` writes one back out. + +### 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 +737,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: @@ -435,26 +972,123 @@ The easiest way to test and debug your MCP server is using the official MCP Insp The Inspector provides a web interface to interact with your MCP server, making it perfect for development and debugging. -## Available Example tools +## Available Example Tools - **echo**: Echo a message back to the user - **get_time**: Get the current server time - **list_files**: List files in a directory - **calculate**: Perform basic arithmetic calculations - -## Available Example resources - -The server provides four essential resources accessible via URIs: - +- **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 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,15 +1187,26 @@ 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 variables, named constants instead of literals, typed exceptions, no comments in code 4. Test your changes 5. Submit a pull request ### Development Setup -- Requires Delphi 12+ -- Open `MCPServer.dproj` or build with `build.bat` +- Requires Delphi 11 Alexandria or later; the project files target Delphi 12 Athens +- Open `MCPServer.dproj` or build with `build.bat`; on Alexandria use `MCPServer.D11.dproj` - 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, the HTTP transport and the stdio transport in-process and pins the wire behaviour with golden files (`tests\golden`, see the README there). + +```bat +build-tests.bat Debug Win64 +tests\Win64\Debug\MCPServerTests.exe +``` + +`build-tests.bat [Config] [Platform]` compiles `tests\MCPServerTests.dpr` for Win32 or Win64; the program takes the usual DUnitX switches (`-xml:` for an NUnit report, `-run:` for a selection). Set the environment variable `MCP_GOLDEN_RECORD=1` for one run to re-record the golden expectations, then review the diff. + ## 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..1a05e95 --- /dev/null +++ b/build-tests.bat @@ -0,0 +1,88 @@ +@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 +REM DELPHI_PATH yourself before calling this script to build with another Delphi +REM version, for example Studio\22.0 for Delphi 11 Alexandria. +if "%DELPHI_PATH%"=="" 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!" + set "EXTRA_INCLUDES=;!TAURUS_PATH!" + set "EXTRA_RES=-R!TAURUS_PATH!" +) else ( + set "EXTRA_UNITS=" + set "EXTRA_INCLUDES=" + set "EXTRA_RES=" + 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!EXTRA_INCLUDES!;"!DUNITX_PATH!" !EXTRA_RES! -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!EXTRA_INCLUDES!;"!DUNITX_PATH!" !EXTRA_RES! -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..2766c4d 100644 --- a/build.bat +++ b/build.bat @@ -13,8 +13,10 @@ if "%ERRORLEVEL%"=="0" ( timeout /t 1 /nobreak >NUL ) -REM Set Delphi installation path - adjust if needed -set DELPHI_PATH=C:\Program Files (x86)\Embarcadero\Studio\37.0 +REM Set Delphi installation path - adjust if needed. Set DELPHI_PATH yourself +REM before calling this script to build with another Delphi version, for example +REM Studio\22.0 for Delphi 11 Alexandria. +if "%DELPHI_PATH%"=="" set DELPHI_PATH=C:\Program Files (x86)\Embarcadero\Studio\37.0 REM Check if dcc32 exists if not exist "!DELPHI_PATH!\bin\dcc32.exe" ( @@ -63,17 +65,21 @@ if "!TAURUS_PATH!"=="" if exist "!CATALOG_DIR!\TaurusTLS-12\Source" set "TAURUS_ :TaurusResolved if not "!TAURUS_PATH!"=="" ( echo Using TaurusTLS: !TAURUS_PATH! - set EXTRA_UNITS=;!TAURUS_PATH! + set "EXTRA_UNITS=;!TAURUS_PATH!" + set "EXTRA_INCLUDES=;!TAURUS_PATH!" + set "EXTRA_RES=-R!TAURUS_PATH!" ) else ( - set EXTRA_UNITS= + set "EXTRA_UNITS=" + set "EXTRA_INCLUDES=" + set "EXTRA_RES=" echo Warning: TaurusTLS not found. SSL/TLS support may be limited. ) 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!EXTRA_INCLUDES! !EXTRA_RES! -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!EXTRA_INCLUDES! !EXTRA_RES! -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/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.Application.pas b/src/Core/MCPServer.Application.pas new file mode 100644 index 0000000..8a60d0e --- /dev/null +++ b/src/Core/MCPServer.Application.pas @@ -0,0 +1,101 @@ +unit MCPServer.Application; + +interface + +uses + System.SysUtils, + System.SyncObjs, + MCPServer.Types, + MCPServer.Settings, + MCPServer.Host; + +type + TMCPServerApplication = class + strict private + FSettings: TMCPSettings; + FHost: TMCPServerHost; + function GetManagerRegistry: IMCPManagerRegistry; + function GetCoreManager: IMCPCapabilityManager; + procedure LogBanner(const Transport: string); + public + constructor Create(const WriteSettingsFile: Boolean); + destructor Destroy; override; + + procedure RunHttp(const Shutdown: TEvent); + procedure RunStdio; + + property Settings: TMCPSettings read FSettings; + property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; + property CoreManager: IMCPCapabilityManager read GetCoreManager; + end; + +implementation + +uses + MCPServer.Logger, + MCPServer.Authorization; + +const + BANNER_RULE = '================================'; + BANNER_TITLE = 'Model Context Protocol Server'; + +{ TMCPServerApplication } + +constructor TMCPServerApplication.Create(const WriteSettingsFile: Boolean); +begin + inherited Create; + FSettings := TMCPSettings.Create('', WriteSettingsFile); + FHost := TMCPServerHost.Create(FSettings); + FHost.SeedFromGlobalRegistry := True; +end; + +destructor TMCPServerApplication.Destroy; +begin + FHost.Free; + FSettings.Free; + inherited; +end; + +function TMCPServerApplication.GetManagerRegistry: IMCPManagerRegistry; +begin + Result := FHost.ManagerRegistry; +end; + +function TMCPServerApplication.GetCoreManager: IMCPCapabilityManager; +begin + Result := FHost.CoreManager; +end; + +procedure TMCPServerApplication.LogBanner(const Transport: string); +begin + TLogger.Info(Format('Delphi MCP Server v%s', [FSettings.ServerVersion])); + TLogger.Info(BANNER_RULE); + TLogger.Info(BANNER_TITLE); + TLogger.Info(Format('Transport: %s', [Transport])); +end; + +procedure TMCPServerApplication.RunHttp(const Shutdown: TEvent); +begin + LogBanner('HTTP'); + TLogger.Info(Format('Listening on port %d', [FSettings.Port])); + + const RequiresToken = (Length(FSettings.BearerTokenList) > 0); + if RequiresToken then + FHost.Authorizer := TMCPStaticBearerAuthorizer.Create(FSettings.BearerTokenList); + + FHost.StartHttp; + TLogger.Info('Server started. Press CTRL+C to stop...'); + Shutdown.WaitFor(INFINITE); + + TLogger.Info('Shutting down server...'); + FHost.Stop; + TLogger.Info('Server stopped successfully'); +end; + +procedure TMCPServerApplication.RunStdio; +begin + LogBanner('STDIO'); + FHost.RunStdio; +end; + +end. diff --git a/src/Core/MCPServer.Authorization.pas b/src/Core/MCPServer.Authorization.pas new file mode 100644 index 0000000..2d8ef27 --- /dev/null +++ b/src/Core/MCPServer.Authorization.pas @@ -0,0 +1,486 @@ +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; + + TMCPAuthResult = record + Decision: TMCPAuthDecision; + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; + class function Allowed(const Principal: TMCPPrincipal): TMCPAuthResult; static; + class function Denied(const Decision: TMCPAuthDecision; const Challenge: TMCPAuthChallenge): TMCPAuthResult; static; + end; + + IMCPAuthorizer = interface + ['{7B3D5F1A-9C2E-4A8B-B6D0-1E3F5A7C9B2D}'] + function Authorize(const BearerToken, HttpMethod, Path: string): TMCPAuthResult; + 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): TMCPAuthResult; + class function SameToken(const Presented, Expected: TBytes): Boolean; static; + end; + + TMCPOAuthResourceServerAuthorizer = class abstract(TInterfacedObject, IMCPAuthorizer) + strict private + FExpectedAudience: string; + FRequiredScopes: TArray; + protected + function TryValidateToken(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): TMCPAuthResult; + 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 TryValidateToken(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, + MCPServer.Errors; + +const + CLAIM_SUBJECT = 'sub'; + CLAIM_AUDIENCE = 'aud'; + CLAIM_EXPIRY = 'exp'; + CLAIM_SCOPE = 'scope'; + CLAIM_SCOPE_ARRAY = 'scp'; + CLAIM_ACTIVE = 'active'; + 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 = MCP_SCOPE_ANY) then + Exit(True); + end; + Result := False; +end; + +{ TMCPAuthResult } + +class function TMCPAuthResult.Allowed(const Principal: TMCPPrincipal): TMCPAuthResult; +begin + Result := Default(TMCPAuthResult); + Result.Decision := TMCPAuthDecision.Allow; + Result.Principal := Principal; +end; + +class function TMCPAuthResult.Denied(const Decision: TMCPAuthDecision; + const Challenge: TMCPAuthChallenge): TMCPAuthResult; +begin + Result := Default(TMCPAuthResult); + Result.Decision := Decision; + Result.Challenge := Challenge; +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; + const HasResourceMetadataUrl = (ResourceMetadataUrl <> ''); + if HasResourceMetadataUrl then + Parameters := Parameters + ['resource_metadata=' + Quote(ResourceMetadataUrl)]; + const HasError = (Challenge.Error <> ''); + if HasError then + Parameters := Parameters + ['error=' + Quote(Challenge.Error)]; + const HasErrorDescription = (Challenge.ErrorDescription <> ''); + if HasErrorDescription then + Parameters := Parameters + ['error_description=' + Quote(Challenge.ErrorDescription)]; + const HasScope = (Challenge.Scope <> ''); + if HasScope then + Parameters := Parameters + ['scope=' + Quote(Challenge.Scope)]; + + Result := SCHEME; + const HasParameters = (Length(Parameters) > 0); + if HasParameters 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); + const HasScopes = (Length(Scopes) > 0); + if HasScopes 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); + const HasResourceName = (ResourceName <> ''); + if HasResourceName 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; + const TokensIsEmpty = (Length(FTokens) = 0); + if TokensIsEmpty then + raise EMCPAuthorizationConfiguration.Create('A static bearer authorizer needs at least one token'); + FScopes := Scopes; + const ScopesIsEmpty = (Length(FScopes) = 0); + if ScopesIsEmpty then + FScopes := [MCP_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): TMCPAuthResult; +begin + const Presented = TEncoding.UTF8.GetBytes(BearerToken); + var Matched: Integer := -1; + for var Index := 0 to High(FTokens) do + begin + if SameToken(Presented, FTokens[Index]) then + Matched := Integer(Index); + end; + + const IsKnown = (Matched >= 0); + if not IsKnown then + Exit(TMCPAuthResult.Denied(TMCPAuthDecision.Unauthorized, + TMCPAuthChallenge.InvalidToken('The bearer token is not recognised'))); + + var Principal := TMCPPrincipal.None; + Principal.Subject := Format(STATIC_SUBJECT_FORMAT, [Matched + 1]); + Principal.Scopes := FScopes; + Result := TMCPAuthResult.Allowed(Principal); +end; + +{ TMCPOAuthResourceServerAuthorizer } + +constructor TMCPOAuthResourceServerAuthorizer.Create(const ExpectedAudience: string); +begin + inherited Create; + const ExpectedAudienceIsEmpty = (ExpectedAudience.Trim = ''); + if ExpectedAudienceIsEmpty 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 + begin + Result := SameText(TJSONString(Audience).Value, FExpectedAudience); + Exit; + end; + 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 + begin + Result := TJSONString(Scope).Value.Split([SCOPE_SEPARATOR], TStringSplitOptions.ExcludeEmpty); + Exit; + end; + + 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): TMCPAuthResult; +var + Claims: TJSONObject; +begin + const IsValid = TryValidateToken(BearerToken, Claims); + if not IsValid then + Exit(TMCPAuthResult.Denied(TMCPAuthDecision.Unauthorized, + TMCPAuthChallenge.InvalidToken('The access token is not valid'))); + + try + const IsForThisServer = AudienceMatches(Claims); + if not IsForThisServer then + Exit(TMCPAuthResult.Denied(TMCPAuthDecision.Unauthorized, + TMCPAuthChallenge.InvalidToken('The access token was not issued for this server'))); + + const HasExpired = IsExpired(Claims); + if HasExpired then + Exit(TMCPAuthResult.Denied(TMCPAuthDecision.Unauthorized, + TMCPAuthChallenge.InvalidToken('The access token has expired'))); + + var Principal := TMCPPrincipal.None; + Principal.Subject := Claims.GetValue(CLAIM_SUBJECT, ''); + Principal.Scopes := ScopesOf(Claims); + for var Required in FRequiredScopes do + begin + if not Principal.HasScope(Required) then + Exit(TMCPAuthResult.Denied(TMCPAuthDecision.Forbidden, + TMCPAuthChallenge.InsufficientScope(string.Join(SCOPE_SEPARATOR, FRequiredScopes)))); + end; + Result := TMCPAuthResult.Allowed(Principal); + finally + Claims.Free; + end; +end; + +{ TMCPIntrospectionAuthorizer } + +constructor TMCPIntrospectionAuthorizer.Create(const ExpectedAudience, IntrospectionUrl, ClientId, ClientSecret: string); +begin + inherited Create(ExpectedAudience); + const IntrospectionUrlIsEmpty = (IntrospectionUrl.Trim = ''); + if IntrospectionUrlIsEmpty 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.TryValidateToken(const Token: string; out Claims: TJSONObject): Boolean; +begin + Claims := nil; + const Client = THTTPClient.Create; + try + Client.ConnectionTimeout := FTimeoutMs; + Client.ResponseTimeout := FTimeoutMs; + Client.ContentType := MEDIA_TYPE_FORM; + + const Form = TStringStream.Create(Format('token=%s', [TNetEncoding.URL.EncodeForm(Token)]), TEncoding.UTF8); + try + var Headers: TArray := [TNetHeader.Create('Accept', 'application/json')]; + const HasClientId = (FClientId <> ''); + if HasClientId then + begin + const Credentials = TNetEncoding.Base64.Encode(Format('%s:%s', [FClientId, FClientSecret])); + Headers := Headers + [TNetHeader.Create('Authorization', Format('Basic %s', [Credentials]))]; + end; + + var Body := ''; + try + const Response = Client.Post(FIntrospectionUrl, Form, nil, Headers); + const Answered = (Response.StatusCode = HTTP_STATUS_OK); + if not Answered then + begin + TLogger.Warning(Format('Token introspection answered HTTP %d', [Response.StatusCode])); + Exit(False); + end; + Body := Response.ContentAsString(TEncoding.UTF8); + except + on E: ENetException do + begin + TLogger.Warning(Format('Token introspection failed: %s', [E.Message])); + Exit(False); + end; + end; + + const Parsed = TJSONObject.ParseJSONValue(Body); + const IsActiveToken = (Parsed is TJSONObject) and (TJSONObject(Parsed).GetValue(CLAIM_ACTIVE) is TJSONTrue); + if not IsActiveToken then + begin + Parsed.Free; + Exit(False); + end; + Claims := TJSONObject(Parsed); + Result := True; + finally + Form.Free; + end; + finally + Client.Free; + end; +end; + +end. diff --git a/src/Core/MCPServer.Logger.pas b/src/Core/MCPServer.Logger.pas index d5c9d32..d28430c 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,37 +44,45 @@ 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; + function OpenSharedLogStream: TFileStream; + procedure DisableFileLogging(const Reason: string); procedure DoCloseLogFile; public 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 IsSensitiveKey(const Key: string): Boolean; + class procedure RedactValue(const Value: TJSONValue); + 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,16 +139,47 @@ class function TLogger.Instance: TLogger; Result := FInstance; end; - procedure TLogger.EnsureLogFile; begin - if FLogToFile and not Assigned(FLogFile) then - begin - FLogFile := TStreamWriter.Create(FLogFileName, True, TEncoding.UTF8); + const AlreadyOpen = (not FLogToFile) or Assigned(FLogFile); + if AlreadyOpen then + Exit; + + try + const LogStream = OpenSharedLogStream; + FLogFile := TStreamWriter.Create(LogStream, TEncoding.UTF8); + FLogFile.OwnStream; FLogFile.AutoFlush := True; + except + on E: Exception do + DisableFileLogging(E.Message); end; end; +function TLogger.OpenSharedLogStream: TFileStream; +begin + const Exists = FileExists(FLogFileName); + if Exists then + Result := TFileStream.Create(FLogFileName, fmOpenReadWrite or fmShareDenyNone) + else + Result := TFileStream.Create(FLogFileName, fmCreate or fmShareDenyNone); + Result.Seek(0, soEnd); +end; + +procedure TLogger.DisableFileLogging(const Reason: string); +begin + FLogToFile := False; + if not FLogToConsole then + Exit; + + const Warning = Format('[WARN ] File logging disabled, cannot open "%s": %s', [FLogFileName, Reason]); + const ToStdErr = (FUseStdErr or FStdoutReserved); + if ToStdErr then + WriteLn(ErrOutput, Warning) + else + WriteLn(Warning); +end; + procedure TLogger.DoCloseLogFile; begin FLock.Enter; @@ -152,29 +195,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 +229,17 @@ procedure TLogger.DoWriteLog(const Level: TLogLevel; const Message: string); SetConsoleTextAttribute(ConsoleHandle, 7); {$ENDIF} end; - + if FLogToFile then begin EnsureLogFile; if Assigned(FLogFile) then + begin + FLogFile.BaseStream.Seek(0, soEnd); FLogFile.WriteLine(LogLine); + end; end; - + if Assigned(FOnLogMessage) then FOnLogMessage(LogLine); finally @@ -243,6 +292,56 @@ class procedure TLogger.Error(const Exception: Exception); Instance.DoWriteLog(TLogLevel.Error, System.SysUtils.Format('%s: %s', [Exception.ClassName, Exception.Message])); end; +class function TLogger.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; + +class procedure TLogger.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 + begin + RedactValue(Item); + end; +end; + +class function TLogger.RedactJson(const Json: string): string; +begin + var Parsed := TJSONObject.ParseJSONValue(Json); + if not Assigned(Parsed) then + begin + Result := Format('<%d characters, not JSON>', [Length(Json)]); + Exit; + end; + + try + RedactValue(Parsed); + Result := Parsed.ToJSON; + finally + Parsed.Free; + end; +end; + class function TLogger.GetLogToConsole: Boolean; begin Result := Instance.FLogToConsole; @@ -331,10 +430,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.PathBoundary.pas b/src/Core/MCPServer.PathBoundary.pas new file mode 100644 index 0000000..a122888 --- /dev/null +++ b/src/Core/MCPServer.PathBoundary.pas @@ -0,0 +1,27 @@ +unit MCPServer.PathBoundary; + +interface + +type + TPathBoundary = class + public + class function IsWithin(const Path: string; const BasePath: string): Boolean; static; + end; + +implementation + +uses + System.SysUtils, + System.IOUtils; + +class function TPathBoundary.IsWithin(const Path: string; const BasePath: string): Boolean; +begin + const NormalizedPath = ExcludeTrailingPathDelimiter(TPath.GetFullPath(Path)); + const NormalizedBase = ExcludeTrailingPathDelimiter(TPath.GetFullPath(BasePath)); + + const IsBaseItself = SameText(NormalizedPath, NormalizedBase); + const IsInsideBase = NormalizedPath.StartsWith(IncludeTrailingPathDelimiter(NormalizedBase), True); + Result := (IsBaseItself or IsInsideBase); +end; + +end. diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index 9551b88..827f207 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -7,121 +7,199 @@ interface System.Generics.Collections, MCPServer.Tool.Base, MCPServer.Resource.Base, + MCPServer.Prompt.Base, MCPServer.Logger; type + EMCPRegistryNotFound = class(Exception) + end; + 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 - raise Exception.CreateFmt('Tool not found: %s', [Name]); + raise EMCPRegistryNotFound.CreateFmt('Tool not found: %s', [Name]); end; 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]); + raise EMCPRegistryNotFound.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 EMCPRegistryNotFound.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 EMCPRegistryNotFound.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..523aded 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -22,17 +22,42 @@ 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); + constructor CreateDefaults; 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 +71,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 @@ -53,28 +113,44 @@ implementation uses MCPServer.Logger; +const + SECTION_SERVER = 'Server'; + SECTION_SECURITY = 'Security'; + SECTION_AUTH = 'Auth'; + SECTION_SSL = 'SSL'; + SECTION_PROTOCOL = 'Protocol'; + SECTION_CORS = 'CORS'; + + { TMCPSettings } constructor TMCPSettings.Create(const ASettingsFile: string; const ACreateFile: Boolean); begin inherited Create; - - if ASettingsFile = '' then + + const ASettingsFileIsEmpty = (ASettingsFile = ''); + if ASettingsFileIsEmpty 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; +constructor TMCPSettings.CreateDefaults; +begin + inherited Create; + LoadDefaults; +end; + destructor TMCPSettings.Destroy; begin inherited; @@ -93,6 +169,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; @@ -109,23 +245,57 @@ procedure TMCPSettings.CreateDefaultSettingsFile; begin IniFile := TIniFile.Create(FSettingsFile); try - IniFile.WriteString('Server', '; Server configuration', ''); - IniFile.WriteInteger('Server', 'Port', FPort); - IniFile.WriteString('Server', 'Host', FHost); - IniFile.WriteString('Server', 'Name', FServerName); - IniFile.WriteString('Server', 'Version', FServerVersion); - IniFile.WriteString('Server', 'Endpoint', FEndpoint); - - 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); - IniFile.WriteString('SSL', 'KeyFile', FSSLKeyFile); - IniFile.WriteString('SSL', 'RootCertFile', FSSLRootCertFile); + IniFile.WriteString(SECTION_SERVER, '; Server configuration', ''); + IniFile.WriteInteger(SECTION_SERVER, 'Port', FPort); + IniFile.WriteString(SECTION_SERVER, 'Host', FHost); + IniFile.WriteString(SECTION_SERVER, 'Name', FServerName); + IniFile.WriteString(SECTION_SERVER, 'Version', FServerVersion); + IniFile.WriteString(SECTION_SERVER, 'Endpoint', FEndpoint); + IniFile.WriteString(SECTION_SERVER, '; Optional identity reported to clients', ''); + IniFile.WriteString(SECTION_SERVER, 'Title', FServerTitle); + IniFile.WriteString(SECTION_SERVER, 'Description', FServerDescription); + IniFile.WriteString(SECTION_SERVER, 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString(SECTION_SERVER, 'Instructions', FInstructions); + IniFile.WriteString(SECTION_SERVER, '; Network: BindAddress empty = derived from Host (loopback for localhost)', ''); + IniFile.WriteString(SECTION_SERVER, 'BindAddress', FBindAddress); + IniFile.WriteString(SECTION_SERVER, 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger(SECTION_SERVER, 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger(SECTION_SERVER, 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger(SECTION_SERVER, 'MaxConcurrentRequests', FMaxConcurrentRequests); + IniFile.WriteInteger(SECTION_SERVER, 'MaxConnections', FMaxConnections); + IniFile.WriteString(SECTION_SERVER, '; Serve logs://recent, logs://{level} and server://status (0 = keep diagnostics private)', ''); + IniFile.WriteBool(SECTION_SERVER, 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + + IniFile.WriteString(SECTION_SECURITY, '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); + IniFile.WriteString(SECTION_SECURITY, 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString(SECTION_SECURITY, '; Host header values accepted, comma-separated host[:port] (empty = any)', ''); + IniFile.WriteString(SECTION_SECURITY, 'AllowedHosts', FAllowedHosts); + IniFile.WriteString(SECTION_SECURITY, '; Secret that signs requestState tokens (empty = random per process)', ''); + IniFile.WriteString(SECTION_SECURITY, 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger(SECTION_SECURITY, 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + IniFile.WriteString(SECTION_AUTH, '; Bearer tokens accepted on the HTTP endpoint (comma-separated; empty = open server)', ''); + IniFile.WriteString(SECTION_AUTH, 'BearerTokens', FBearerTokens); + IniFile.WriteString(SECTION_AUTH, '; OAuth authorization servers published in the protected resource metadata', ''); + IniFile.WriteString(SECTION_AUTH, 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString(SECTION_AUTH, 'ResourceUri', FResourceUri); + IniFile.WriteString(SECTION_AUTH, 'ScopesSupported', FScopesSupported); + + IniFile.WriteString(SECTION_PROTOCOL, '; Protocol options (1 = on, 0 = off)', ''); + IniFile.WriteBool(SECTION_PROTOCOL, 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool(SECTION_PROTOCOL, 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger(SECTION_PROTOCOL, 'DiscoverTtlMs', FDiscoverTtlMs); + + IniFile.WriteString(SECTION_CORS, '; Cross-Origin Resource Sharing configuration', ''); + IniFile.WriteBool(SECTION_CORS, 'Enabled', FCorsEnabled); + IniFile.WriteString(SECTION_CORS, '; Comma-separated list of allowed origins', ''); + IniFile.WriteString(SECTION_CORS, 'AllowedOrigins', FCorsAllowedOrigins); + + IniFile.WriteString(SECTION_SSL, '; SSL/TLS configuration (optional)', ''); + IniFile.WriteBool(SECTION_SSL, 'Enabled', FSSLEnabled); + IniFile.WriteString(SECTION_SSL, 'CertFile', FSSLCertFile); + IniFile.WriteString(SECTION_SSL, 'KeyFile', FSSLKeyFile); + IniFile.WriteString(SECTION_SSL, 'RootCertFile', FSSLRootCertFile); finally IniFile.Free; end; @@ -137,29 +307,55 @@ procedure TMCPSettings.LoadFromFile; begin if not TFile.Exists(FSettingsFile) then Exit; - + IniFile := TIniFile.Create(FSettingsFile); try - FPort := IniFile.ReadInteger('Server', 'Port', FPort); - FHost := IniFile.ReadString('Server', 'Host', FHost); - FServerName := IniFile.ReadString('Server', 'Name', FServerName); - FServerVersion := IniFile.ReadString('Server', 'Version', FServerVersion); - FEndpoint := IniFile.ReadString('Server', 'Endpoint', FEndpoint); - - 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); - + FPort := IniFile.ReadInteger(SECTION_SERVER, 'Port', FPort); + FHost := IniFile.ReadString(SECTION_SERVER, 'Host', FHost); + FServerName := IniFile.ReadString(SECTION_SERVER, 'Name', FServerName); + FServerVersion := IniFile.ReadString(SECTION_SERVER, 'Version', FServerVersion); + FEndpoint := IniFile.ReadString(SECTION_SERVER, 'Endpoint', FEndpoint); + FServerTitle := IniFile.ReadString(SECTION_SERVER, 'Title', FServerTitle); + FServerDescription := IniFile.ReadString(SECTION_SERVER, 'Description', FServerDescription); + FServerWebsiteUrl := IniFile.ReadString(SECTION_SERVER, 'WebsiteUrl', FServerWebsiteUrl); + FInstructions := IniFile.ReadString(SECTION_SERVER, 'Instructions', FInstructions); + FBindAddress := IniFile.ReadString(SECTION_SERVER, 'BindAddress', FBindAddress); + FEndpointInfoPath := IniFile.ReadString(SECTION_SERVER, 'EndpointInfoPath', FEndpointInfoPath); + FMaxRequestBodyBytes := IniFile.ReadInteger(SECTION_SERVER, 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + FMaxJsonDepth := IniFile.ReadInteger(SECTION_SERVER, 'MaxJsonDepth', FMaxJsonDepth); + FMaxConcurrentRequests := IniFile.ReadInteger(SECTION_SERVER, 'MaxConcurrentRequests', FMaxConcurrentRequests); + FMaxConnections := IniFile.ReadInteger(SECTION_SERVER, 'MaxConnections', FMaxConnections); + + FSecurityAllowedOrigins := IniFile.ReadString(SECTION_SECURITY, 'AllowedOrigins', FSecurityAllowedOrigins); + FAllowedHosts := IniFile.ReadString(SECTION_SECURITY, 'AllowedHosts', FAllowedHosts); + FExposeDiagnosticsResources := IniFile.ReadBool(SECTION_SERVER, 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + FRequestStateKey := IniFile.ReadString(SECTION_SECURITY, 'RequestStateKey', FRequestStateKey); + FRequestStateTtlSeconds := IniFile.ReadInteger(SECTION_SECURITY, 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + FBearerTokens := IniFile.ReadString(SECTION_AUTH, 'BearerTokens', FBearerTokens); + FAuthorizationServers := IniFile.ReadString(SECTION_AUTH, 'AuthorizationServers', FAuthorizationServers); + FResourceUri := IniFile.ReadString(SECTION_AUTH, 'ResourceUri', FResourceUri); + FScopesSupported := IniFile.ReadString(SECTION_AUTH, 'ScopesSupported', FScopesSupported); + + FLenientModernPing := IniFile.ReadBool(SECTION_PROTOCOL, 'LenientModernPing', FLenientModernPing); + FDiscoverListsLegacyVersions := IniFile.ReadBool(SECTION_PROTOCOL, 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + FDiscoverTtlMs := IniFile.ReadInteger(SECTION_PROTOCOL, 'DiscoverTtlMs', FDiscoverTtlMs); + + FCorsEnabled := IniFile.ReadBool(SECTION_CORS, 'Enabled', FCorsEnabled); + FCorsAllowedOrigins := IniFile.ReadString(SECTION_CORS, 'AllowedOrigins', FCorsAllowedOrigins); + + FSSLEnabled := IniFile.ReadBool(SECTION_SSL, 'Enabled', FSSLEnabled); + FSSLCertFile := IniFile.ReadString(SECTION_SSL, 'CertFile', FSSLCertFile); + FSSLKeyFile := IniFile.ReadString(SECTION_SSL, 'KeyFile', FSSLKeyFile); + FSSLRootCertFile := IniFile.ReadString(SECTION_SSL, 'RootCertFile', FSSLRootCertFile); + TLogger.Info('Settings loaded from: ' + FSettingsFile); TLogger.Info('Server: ' + Protocol + '://' + FHost + ':' + IntToStr(FPort)); if FSSLEnabled then begin TLogger.Info('SSL Enabled: True'); - if FSSLCertFile <> '' then + const HasSSLCertFile = (FSSLCertFile <> ''); + if HasSSLCertFile then TLogger.Info('SSL Certificate: ' + FSSLCertFile); end; TLogger.Info('CORS Enabled: ' + BoolToStr(FCorsEnabled, True)); @@ -174,21 +370,50 @@ procedure TMCPSettings.SaveToFile; var IniFile: TIniFile; begin + const HasSettingsFile = (FSettingsFile <> ''); + if not HasSettingsFile then + Exit; + IniFile := TIniFile.Create(FSettingsFile); try - IniFile.WriteInteger('Server', 'Port', FPort); - IniFile.WriteString('Server', 'Host', FHost); - IniFile.WriteString('Server', 'Name', FServerName); - IniFile.WriteString('Server', 'Version', FServerVersion); - IniFile.WriteString('Server', 'Endpoint', FEndpoint); - - 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); - IniFile.WriteString('SSL', 'RootCertFile', FSSLRootCertFile); + IniFile.WriteInteger(SECTION_SERVER, 'Port', FPort); + IniFile.WriteString(SECTION_SERVER, 'Host', FHost); + IniFile.WriteString(SECTION_SERVER, 'Name', FServerName); + IniFile.WriteString(SECTION_SERVER, 'Version', FServerVersion); + IniFile.WriteString(SECTION_SERVER, 'Endpoint', FEndpoint); + IniFile.WriteString(SECTION_SERVER, 'Title', FServerTitle); + IniFile.WriteString(SECTION_SERVER, 'Description', FServerDescription); + IniFile.WriteString(SECTION_SERVER, 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString(SECTION_SERVER, 'Instructions', FInstructions); + IniFile.WriteString(SECTION_SERVER, 'BindAddress', FBindAddress); + IniFile.WriteString(SECTION_SERVER, 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger(SECTION_SERVER, 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger(SECTION_SERVER, 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger(SECTION_SERVER, 'MaxConcurrentRequests', FMaxConcurrentRequests); + IniFile.WriteInteger(SECTION_SERVER, 'MaxConnections', FMaxConnections); + IniFile.WriteBool(SECTION_SERVER, 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); + + IniFile.WriteString(SECTION_SECURITY, 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString(SECTION_SECURITY, 'AllowedHosts', FAllowedHosts); + IniFile.WriteString(SECTION_SECURITY, 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger(SECTION_SECURITY, 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + + IniFile.WriteString(SECTION_AUTH, 'BearerTokens', FBearerTokens); + IniFile.WriteString(SECTION_AUTH, 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString(SECTION_AUTH, 'ResourceUri', FResourceUri); + IniFile.WriteString(SECTION_AUTH, 'ScopesSupported', FScopesSupported); + + IniFile.WriteBool(SECTION_PROTOCOL, 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool(SECTION_PROTOCOL, 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger(SECTION_PROTOCOL, 'DiscoverTtlMs', FDiscoverTtlMs); + + IniFile.WriteBool(SECTION_CORS, 'Enabled', FCorsEnabled); + IniFile.WriteString(SECTION_CORS, 'AllowedOrigins', FCorsAllowedOrigins); + + IniFile.WriteBool(SECTION_SSL, 'Enabled', FSSLEnabled); + IniFile.WriteString(SECTION_SSL, 'CertFile', FSSLCertFile); + IniFile.WriteString(SECTION_SSL, 'KeyFile', FSSLKeyFile); + IniFile.WriteString(SECTION_SSL, 'RootCertFile', FSSLRootCertFile); finally IniFile.Free; end; diff --git a/src/Http/MCPServer.Http.ResponseParser.pas b/src/Http/MCPServer.Http.ResponseParser.pas index 213aeaa..d8e3165 100644 --- a/src/Http/MCPServer.Http.ResponseParser.pas +++ b/src/Http/MCPServer.Http.ResponseParser.pas @@ -17,12 +17,16 @@ TJsonResponseParser = class(TInterfacedObject, IResponseParser) implementation + +const + KEY_SUCCESS = 'success'; + function TJsonResponseParser.ParseSuccess(const Response: IHttpResponse): TJSONObject; begin if Response.StatusCode = 204 then begin Result := TJSONObject.Create; - Result.AddPair('success', TJSONBool.Create(True)); + Result.AddPair(KEY_SUCCESS, TJSONBool.Create(True)); Exit; end; @@ -40,14 +44,14 @@ function TJsonResponseParser.ParseSuccess(const Response: IHttpResponse): TJSONO else begin Result := TJSONObject.Create; - Result.AddPair('success', TJSONBool.Create(True)); + Result.AddPair(KEY_SUCCESS, TJSONBool.Create(True)); ParsedValue.Free; end; end else begin Result := TJSONObject.Create; - Result.AddPair('success', TJSONBool.Create(True)); + Result.AddPair(KEY_SUCCESS, TJSONBool.Create(True)); end; end; diff --git a/src/MCPServer.D11.dproj b/src/MCPServer.D11.dproj new file mode 100644 index 0000000..8a32f3e --- /dev/null +++ b/src/MCPServer.D11.dproj @@ -0,0 +1,205 @@ + + + {B7E4C1D2-3A56-4F89-9B0C-D1E2F3A4B5C6} + MCPServer.dpr + True + Debug + 131 + Console + 19.5 + Win32 + MCPServer + None + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + ..\$(Platform)\$(Config)\D11 + ..\$(Platform)\$(Config)\D11 + false + false + false + false + false + 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;.\Prompts;$(DCC_UnitSearchPath) + + + System.Posix;$(DCC_Namespace) + + + vclwinx;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + + + vclwinx;$(DCC_UsePackage) + 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 + PerMonitorV2 + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + PerMonitorV2 + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + false + 0 + 0 + + + PerMonitorV2 + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + PerMonitorV2 + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + MCPServer.dpr + + + + True + True + True + + + 12 + + + + diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 24ddf5b..845e2b3 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -12,35 +12,52 @@ 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.PathBoundary in 'Core\MCPServer.PathBoundary.pas', MCPServer.Settings in 'Core\MCPServer.Settings.pas', + MCPServer.Application in 'Core\MCPServer.Application.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.Host in 'Server\MCPServer.Host.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; ShutdownEvent: TEvent; {$IFDEF MSWINDOWS} @@ -71,72 +88,16 @@ begin end; {$ENDIF} -procedure RunHTTPServer; +procedure RunServer(const UseStdio: Boolean); begin - Settings := TMCPSettings.Create; - - TLogger.Info('Delphi MCP Server v' + Settings.ServerVersion); - TLogger.Info('================================'); - TLogger.Info('Model Context Protocol Server'); - TLogger.Info('Transport: HTTP'); - TLogger.Info('Listening on port ' + Settings.Port.ToString); - - ManagerRegistry := TMCPManagerRegistry.Create; - CoreManager := TMCPCoreManager.Create(Settings); - ToolsManager := TMCPToolsManager.Create; - ResourcesManager := TMCPResourcesManager.Create; - - ManagerRegistry.RegisterManager(CoreManager); - ManagerRegistry.RegisterManager(ToolsManager); - ManagerRegistry.RegisterManager(ResourcesManager); - - Server := TMCPIdHTTPServer.Create(nil); - try - Server.Settings := Settings; - Server.ManagerRegistry := ManagerRegistry; - Server.CoreManager := CoreManager; - - Server.Start; - - TLogger.Info('Server started. Press CTRL+C to stop...'); - - ShutdownEvent.WaitFor(INFINITE); - - TLogger.Info('Shutting down server...'); - Server.Stop; - TLogger.Info('Server stopped successfully'); - finally - Server.Free; - Settings.Free; - end; -end; - -procedure RunStdioServer; -var - StdioTransport: TMCPStdioTransport; -begin - Settings := TMCPSettings.Create; - - TLogger.Info('Delphi MCP Server v' + Settings.ServerVersion); - TLogger.Info('================================'); - TLogger.Info('Model Context Protocol Server'); - TLogger.Info('Transport: STDIO'); - - ManagerRegistry := TMCPManagerRegistry.Create; - CoreManager := TMCPCoreManager.Create(Settings); - ToolsManager := TMCPToolsManager.Create; - ResourcesManager := TMCPResourcesManager.Create; - - ManagerRegistry.RegisterManager(CoreManager); - ManagerRegistry.RegisterManager(ToolsManager); - ManagerRegistry.RegisterManager(ResourcesManager); - - StdioTransport := TMCPStdioTransport.Create(ManagerRegistry, CoreManager); + const Application = TMCPServerApplication.Create(not UseStdio); try - StdioTransport.Run; + if UseStdio then + Application.RunStdio + else + Application.RunHttp(ShutdownEvent); finally - StdioTransport.Free; - Settings.Free; + Application.Free; end; end; @@ -158,37 +119,33 @@ begin end; begin - // Check if running in STDIO mode before any logging if HasStdioFlag then TLogger.UseStdErr := True; - - // Configure logger TLogger.LogToConsole := True; TLogger.MinLogLevel := TLogLevel.Info; - ReportMemoryLeaksOnShutdown := True; + {$IFDEF DEBUG} + ReportMemoryLeaksOnShutdown := not HasStdioFlag; + {$ENDIF} IsMultiThread := True; - - // Create shutdown event ShutdownEvent := TEvent.Create(nil, True, False, ''); try - // Set up signal handlers {$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 - TServerStatusResource.Initialize; - - if HasStdioFlag then - RunStdioServer - else - RunHTTPServer; + + RunServer(HasStdioFlag); except on E: Exception do @@ -196,7 +153,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..45f1b83 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,32 @@ MainSource + + + + + + + + + + + + + + @@ -148,6 +162,15 @@ + + + + + + + + + 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..cc80173 --- /dev/null +++ b/src/Managers/MCPServer.CompletionManager.pas @@ -0,0 +1,222 @@ +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; + +const + CAPABILITY_NAME = 'completions'; + + +{ 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 := CAPABILITY_NAME; +end; + +function TMCPCompletionManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = MCP_METHOD_COMPLETION_COMPLETE; +end; + +procedure TMCPCompletionManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + Capabilities.AddPair(CAPABILITY_NAME, 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 = MCP_METHOD_COMPLETION_COMPLETE then + Result := Complete(Params, EraOf(Context)) + else + raise EMCPError.MethodNotFound(Method); +end; + +function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject; Era: TMCPProtocolEra): IInterface; +var + Prompt: IMCPPrompt; + Template: IMCPResourceTemplate; + Resource: IMCPResource; +begin + var TypeValue := Ref.GetValue(MCP_KEY_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(MCP_KEY_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(MCP_KEY_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(MCP_KEY_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 + begin + Values.Add(Value); + end; + + 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(MCP_KEY_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..3705996 100644 --- a/src/Managers/MCPServer.CoreManager.pas +++ b/src/Managers/MCPServer.CoreManager.pas @@ -6,38 +6,53 @@ 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, + MCPServer.Errors; + { TMCPCoreManager } constructor TMCPCoreManager.Create(ASettings: TMCPSettings); begin inherited Create; FSettings := ASettings; - FSessionID := ''; end; function TMCPCoreManager.GetCapabilityName: string; @@ -45,93 +60,142 @@ 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 - (Method = 'notifications/initialized') or - (Method = 'ping'); + Result := (Method = MCP_METHOD_INITIALIZE) or + (Method = MCP_METHOD_NOTIFICATIONS_INITIALIZED) or + (Method = MCP_METHOD_PING) or + (Method = MCP_METHOD_SERVER_DISCOVER); end; function TMCPCoreManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; begin - if Method = 'initialize' then - Result := Initialize(Params) - else if Method = 'notifications/initialized' then + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPCoreManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = MCP_METHOD_INITIALIZE then + Result := Initialize(Params, Context) + else if Method = MCP_METHOD_NOTIFICATIONS_INITIALIZED then begin TLogger.Info('MCP Initialized notification received'); Result := TValue.Empty; end - else if Method = 'ping' then + else if Method = MCP_METHOD_PING then Result := Ping + else if Method = MCP_METHOD_SERVER_DISCOVER then + Result := Discover(Context) else - raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); + raise EMCPError.MethodNotFound(Method); +end; + +function TMCPCoreManager.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_NAME, FSettings.ServerName); + Result.AddPair(MCP_KEY_VERSION, FSettings.ServerVersion); + const HasServerTitle = (FSettings.ServerTitle <> ''); + if HasServerTitle then + Result.AddPair(MCP_KEY_TITLE, FSettings.ServerTitle); + const HasServerDescription = (FSettings.ServerDescription <> ''); + if HasServerDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, FSettings.ServerDescription); + const HasServerWebsiteUrl = (FSettings.ServerWebsiteUrl <> ''); + if HasServerWebsiteUrl then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPCoreManager.BuildCapabilities(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TMCPCapabilityBuilder.Build(FManagerRegistry, Era); end; -function TMCPCoreManager.Initialize(const Params: TJSONObject): TValue; +function TMCPCoreManager.SupportedVersions: TJSONArray; +begin + Result := TJSONArray.Create; + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + begin + Result.Add(Version); + end; + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + begin + Result.Add(Version); + end; +end; + +procedure TMCPCoreManager.LogClientInfo(const ClientInfo: TJSONValue); +begin + if not (ClientInfo is TJSONObject) then + Exit; + + var ClientName := TJSONObject(ClientInfo).GetValue(MCP_KEY_NAME); + var ClientVersion := TJSONObject(ClientInfo).GetValue(MCP_KEY_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(MCP_KEY_PROTOCOL_VERSION); + if RequestedValue is TJSONString then + Requested := TJSONString(RequestedValue).Value; end; + Negotiated := TMCPProtocolVersion.NegotiateLegacy(Requested); end; - - FSessionID := TGuid.NewGuid.ToString; - - ResultJSON := TJSONObject.Create; + + if Assigned(Params) then + begin + LogClientInfo(Params.GetValue('clientInfo')); + WarnAboutDeprecatedClientCapabilities(Params.GetValue(MCP_KEY_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(MCP_KEY_PROTOCOL_VERSION, Negotiated); + ResultJSON.AddPair(MCP_KEY_CAPABILITIES, BuildCapabilities(TMCPProtocolEra.Legacy)); + ResultJSON.AddPair('serverInfo', BuildServerInfo); + const HasInstructions = (FSettings.Instructions <> ''); + if HasInstructions then + ResultJSON.AddPair(MCP_KEY_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 +203,26 @@ 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(MCP_KEY_RESULT_TYPE, 'complete'); + ResultJSON.AddPair('supportedVersions', SupportedVersions); + ResultJSON.AddPair(MCP_KEY_CAPABILITIES, BuildCapabilities(TMCPProtocolEra.Modern)); + + var Meta := TJSONObject.Create; + ResultJSON.AddPair(MCP_KEY_META, Meta); + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); + + const HasInstructions = (FSettings.Instructions <> ''); + if HasInstructions then + ResultJSON.AddPair(MCP_KEY_INSTRUCTIONS, FSettings.Instructions); + ResultJSON.AddPair(MCP_KEY_TTL_MS, TJSONNumber.Create(FSettings.DiscoverTtlMs)); + ResultJSON.AddPair(MCP_KEY_CACHE_SCOPE, MCP_CACHE_SCOPE_PUBLIC); + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -154,4 +230,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..02b116d --- /dev/null +++ b/src/Managers/MCPServer.PromptsManager.pas @@ -0,0 +1,342 @@ +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; overload; + constructor Create(const SeedFromRegistry: Boolean); overload; + 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; + +const + CAPABILITY_NAME = 'prompts'; + + +{ TMCPPromptsManager } + +constructor TMCPPromptsManager.Create; +begin + Create(True); +end; + +constructor TMCPPromptsManager.Create(const SeedFromRegistry: Boolean); +begin + inherited Create; + FLock := TCriticalSection.Create; + FPrompts := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; + if SeedFromRegistry then + RegisterBuiltInPrompts; +end; + +destructor TMCPPromptsManager.Destroy; +begin + FPrompts.Free; + FOrder.Free; + FLock.Free; + inherited; +end; + +function TMCPPromptsManager.GetCapabilityName: string; +begin + Result := CAPABILITY_NAME; +end; + +function TMCPPromptsManager.HandlesMethod(const Method: string): Boolean; +begin + Result := (Method = MCP_METHOD_PROMPTS_LIST) or (Method = MCP_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(MCP_KEY_LIST_CHANGED, TJSONBool.Create(Announces)); + Capabilities.AddPair(CAPABILITY_NAME, 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 = MCP_METHOD_PROMPTS_LIST then + Result := ListPrompts(Params, EraOf(Context)) + else if Method = MCP_METHOD_PROMPTS_GET then + Result := GetPrompt(Params, EraOf(Context)) + else + raise EMCPError.MethodNotFound(Method); +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 + begin + RegisterPrompt(TMCPRegistry.CreatePrompt(PromptName)); + end; +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(MCP_KEY_CURSOR)) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +function TMCPPromptsManager.CreatePromptJSON(const Prompt: IMCPPrompt): TJSONObject; +var + Metadata: IMCPPromptMetadata; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_NAME, Prompt.Name); + const IsNotName = (Prompt.Title <> Prompt.Name); + if IsNotName then + Result.AddPair(MCP_KEY_TITLE, Prompt.Title); + const HasDescription = (Prompt.Description <> ''); + if HasDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, Prompt.Description); + + var Arguments := Prompt.Arguments; + const HasArguments = (Length(Arguments) > 0); + if HasArguments then + begin + var ArgumentsArray := TJSONArray.Create; + Result.AddPair(MCP_KEY_ARGUMENTS, ArgumentsArray); + for var Arg in Arguments do + begin + var ArgObject := TJSONObject.Create; + ArgumentsArray.AddElement(ArgObject); + ArgObject.AddPair(MCP_KEY_NAME, Arg.Name); + if Arg.Description <> '' then + ArgObject.AddPair(MCP_KEY_DESCRIPTION, Arg.Description); + ArgObject.AddPair('required', TJSONBool.Create(Arg.Required)); + end; + end; + + if Supports(Prompt, IMCPPromptMetadata, Metadata) and Assigned(Metadata.Icons) then + Result.AddPair(MCP_KEY_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(CAPABILITY_NAME, PromptsArray); + FLock.Enter; + try + for var Name in FOrder do + begin + PromptsArray.AddElement(CreatePromptJSON(FPrompts[Name])); + end; + finally + FLock.Leave; + end; + + const IsModern = (Era = TMCPProtocolEra.Modern); + if IsModern then + begin + ResultJSON.AddPair(MCP_KEY_TTL_MS, TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair(MCP_KEY_CACHE_SCOPE, 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(MCP_KEY_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(MCP_KEY_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(MCP_KEY_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..01f0020 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,107 +14,405 @@ 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; + constructor Create; overload; + constructor Create(const SeedFromRegistry: Boolean); overload; 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; + +const + CAPABILITY_NAME = 'resources'; + { TMCPResourcesManager } constructor TMCPResourcesManager.Create; begin - inherited; + Create(True); +end; + +constructor TMCPResourcesManager.Create(const SeedFromRegistry: Boolean); +begin + inherited Create; + FLock := TCriticalSection.Create; FResources := TDictionary.Create; - RegisterBuiltInResources; + FOrder := TList.Create; + FTemplates := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; + if SeedFromRegistry then + begin + RegisterBuiltInResources; + RegisterBuiltInResourceTemplates; + end; end; destructor TMCPResourcesManager.Destroy; begin FResources.Free; + FOrder.Free; + FTemplates.Free; + FLock.Free; inherited; end; function TMCPResourcesManager.GetCapabilityName: string; begin - Result := 'resources'; + Result := CAPABILITY_NAME; end; function TMCPResourcesManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'resources/list') or - (Method = 'resources/read') or - (Method = 'resources/templates/list'); + Result := (Method = MCP_METHOD_RESOURCES_LIST) or + (Method = MCP_METHOD_RESOURCES_READ) or + (Method = MCP_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(MCP_KEY_SUBSCRIBE, TJSONBool.Create(Announces)); + Resources.AddPair(MCP_KEY_LIST_CHANGED, TJSONBool.Create(Announces)); + Capabilities.AddPair(CAPABILITY_NAME, 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 - if Method = 'resources/list' then - Result := ListResources - else if Method = 'resources/read' then - Result := ReadResource(Params) - else if Method = 'resources/templates/list' then - Result := ListResourceTemplates + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPResourcesManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = MCP_METHOD_RESOURCES_LIST then + Result := ListResources(Params, EraOf(Context)) + else if Method = MCP_METHOD_RESOURCES_READ then + Result := ReadResource(Params, EraOf(Context)) + else if Method = MCP_METHOD_RESOURCES_TEMPLATES_LIST then + Result := ListResourceTemplates(Params, EraOf(Context)) else - raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); + raise EMCPError.MethodNotFound(Method); 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; -var - ResourceURI: string; begin - for ResourceURI in TMCPRegistry.GetResourceURIs do + for var ResourceURI in TMCPRegistry.GetResourceURIs do begin RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); end; end; -function TMCPResourcesManager.ListResources: TValue; +procedure TMCPResourcesManager.RegisterBuiltInResourceTemplates; +begin + for var UriTemplate in TMCPRegistry.GetResourceTemplateURIs do + begin + FTemplates.Add(TMCPRegistry.CreateResourceTemplate(UriTemplate)); + end; +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 + FLock.Enter; + try + Result := FResources.TryGetValue(URI, Resource); + finally + FLock.Leave; + end; +end; + +function TMCPResourcesManager.TryGetResourceTemplate(const UriTemplate: string; + out Template: IMCPResourceTemplate): Boolean; +begin + Template := nil; + Result := False; + FLock.Enter; + try + for var Candidate in FTemplates do + begin + if Candidate.UriTemplate = UriTemplate then + begin + Template := Candidate; + Exit(True); + end; + end; + finally + FLock.Leave; + end; +end; + +function TMCPResourcesManager.FindResource(const URI: string): IMCPResource; var - Resource: IMCPResource; - ResourcesArray: TJSONArray; - ResourceObj: TJSONObject; - ResultJSON: TJSONObject; + Templates: TArray; begin - TLogger.Info('MCP ListResources called'); + FLock.Enter; + try + if FResources.TryGetValue(URI, Result) then + Exit; + Templates := FTemplates.ToArray; + finally + FLock.Leave; + end; - ResultJSON := TJSONObject.Create; + var Vars := TMCPTemplateVars.Create; try - ResourcesArray := TJSONArray.Create; - ResultJSON.AddPair('resources', ResourcesArray); - - for Resource in FResources.Values do + for var Template in Templates 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); + if Template.Matches(URI, Vars) then + begin + Result := Template.CreateResource(URI, Vars); + Exit; + end; + end; + finally + Vars.Free; + end; + Result := nil; +end; + +procedure TMCPResourcesManager.CheckCursor(const Params: TJSONObject); +begin + if Assigned(Params) and Assigned(Params.GetValue(MCP_KEY_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(MCP_KEY_TTL_MS, TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair(MCP_KEY_CACHE_SCOPE, FListCacheScope); + end; +end; + +function TMCPResourcesManager.CreateResourceJSON(const Resource: IMCPResource): TJSONObject; +var + Metadata: IMCPResourceMetadata; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_URI, Resource.URI); + Result.AddPair(MCP_KEY_NAME, Resource.Name); + + if Supports(Resource, IMCPResourceMetadata, Metadata) then + begin + if Metadata.Title <> '' then + Result.AddPair(MCP_KEY_TITLE, Metadata.Title); + end; + const HasDescription = (Resource.Description <> ''); + if HasDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, Resource.Description); + const HasMimeType = (Resource.MimeType <> ''); + if HasMimeType then + Result.AddPair(MCP_KEY_MIME_TYPE, 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(MCP_KEY_ANNOTATIONS, TJSONObject(Metadata.Annotations.Clone)); + end; +end; + +function TMCPResourcesManager.CreateResourceTemplateJSON(const Template: IMCPResourceTemplate): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('uriTemplate', Template.UriTemplate); + Result.AddPair(MCP_KEY_NAME, Template.Name); + const HasTitle = (Template.Title <> ''); + if HasTitle then + Result.AddPair(MCP_KEY_TITLE, Template.Title); + const HasDescription = (Template.Description <> ''); + if HasDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, Template.Description); + const HasMimeType = (Template.MimeType <> ''); + if HasMimeType then + Result.AddPair(MCP_KEY_MIME_TYPE, Template.MimeType); +end; + +function TMCPResourcesManager.CreateContentsItem(const Resource: IMCPResource): TJSONObject; +var + Binary: IMCPBinaryResource; +begin + Result := TJSONObject.Create; + try + Result.AddPair(MCP_KEY_URI, Resource.URI); + const HasMimeType = (Resource.MimeType <> ''); + if HasMimeType then + Result.AddPair(MCP_KEY_MIME_TYPE, Resource.MimeType); + + if Supports(Resource, IMCPBinaryResource, Binary) then + Result.AddPair('blob', TMCPContentBlock.EncodeBlob(Binary.ReadBinary)) + else + Result.AddPair(MCP_KEY_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); + + var ResultJSON := TJSONObject.Create; + try + var ResourcesArray := TJSONArray.Create; + ResultJSON.AddPair(CAPABILITY_NAME, ResourcesArray); + 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 +421,59 @@ 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(MCP_KEY_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 + const IsModern = (Era = TMCPProtocolEra.Modern); + if IsModern 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(MCP_KEY_TTL_MS, TJSONNumber.Create(TtlMs)); + ResultJSON.AddPair(MCP_KEY_CACHE_SCOPE, CacheScope); end; - + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -177,19 +482,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 +512,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..41f7d0a --- /dev/null +++ b/src/Managers/MCPServer.SubscriptionsManager.pas @@ -0,0 +1,450 @@ +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; + const CLOSE_GRACE_MS = 2000; + 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; + function NewSubscription(const Context: IMCPRequestContext; const Notifications: TJSONValue): IMCPSubscription; + procedure Add(const Subscription: IMCPSubscription); + procedure Remove(const Subscription: IMCPSubscription); + procedure WaitUntilClosed(const Context: IMCPRequestContext; const Subscription: IMCPSubscription); + 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); + procedure CloseAllAndWait(const Reason: string); + function ActiveCount: Integer; + + property KeepAliveIntervalMs: Integer read FKeepAliveIntervalMs write FKeepAliveIntervalMs; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.Logger; + +const + FILTER_TOOLS = 'toolsListChanged'; + FILTER_PROMPTS = 'promptsListChanged'; + FILTER_RESOURCES = 'resourcesListChanged'; + FILTER_RESOURCE_SUBSCRIPTIONS = 'resourceSubscriptions'; + PARAM_NOTIFICATIONS = 'notifications'; + CLOSE_POLL_MS = 10; + +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)); + const HasResourceSubscriptions = (Length(ResourceSubscriptions) > 0); + if HasResourceSubscriptions 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(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Result.AddPair(MCP_KEY_METHOD, Method); + var Params := TJSONObject.Create; + Result.AddPair(MCP_KEY_PARAMS, Params); + var Meta := TJSONObject.Create; + Params.AddPair(MCP_KEY_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 + CloseAllAndWait('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(MCP_KEY_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(MCP_KEY_META, TJSONObject(Notification.FindValue('params._meta').Clone)); + finally + Notification.Free; + end; +end; + +function TMCPSubscriptionsManager.Listen(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; +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])); + + const Subscription = NewSubscription(Context, Notifications); + Add(Subscription); + try + Acknowledge(Subscription); + TLogger.Info(Format('Subscription %s opened', [Context.RequestId.AsText])); + WaitUntilClosed(Context, Subscription); + finally + Remove(Subscription); + end; + + TLogger.Info(Format('Subscription %s closed', [Context.RequestId.AsText])); + Result := TValue.From(CompletionResult(Subscription)); +end; + +function TMCPSubscriptionsManager.NewSubscription(const Context: IMCPRequestContext; + const Notifications: TJSONValue): IMCPSubscription; +begin + const Id = Context.RequestId.ToJson; + try + const Filter = TMCPSubscriptionFilter.FromJson(Notifications); + Result := TMCPSubscription.Create(Id, Filter, Context.Sink); + finally + Id.Free; + end; +end; + +procedure TMCPSubscriptionsManager.Add(const Subscription: IMCPSubscription); +begin + FLock.Enter; + try + FSubscriptions.Add(Subscription); + finally + FLock.Leave; + end; +end; + +procedure TMCPSubscriptionsManager.Remove(const Subscription: IMCPSubscription); +begin + FLock.Enter; + try + FSubscriptions.Remove(Subscription); + finally + FLock.Leave; + end; +end; + +procedure TMCPSubscriptionsManager.WaitUntilClosed(const Context: IMCPRequestContext; + const Subscription: IMCPSubscription); +var + KeepAlive: IMCPKeepAlive; +begin + 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); + const IsQuietTooLong = (Assigned(KeepAlive) and (SinceKeepAlive >= FKeepAliveIntervalMs)); + if IsQuietTooLong then + begin + SinceKeepAlive := 0; + KeepAlive.KeepAlive; + end; + end; +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(MCP_KEY_PARAMS)).AddPair(MCP_KEY_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; + const HasOpen = (Length(Open) > 0); + if HasOpen then + TLogger.Info(Format('Closing %d subscription(s): %s', [Length(Open), Reason])); + for var Subscription in Open do + begin + Subscription.Close; + end; +end; + +procedure TMCPSubscriptionsManager.CloseAllAndWait(const Reason: string); +begin + const Deadline = TThread.GetTickCount64 + CLOSE_GRACE_MS; + repeat + CloseAll(Reason); + const AllGone = (ActiveCount = 0); + if AllGone then + Break; + Sleep(CLOSE_POLL_MS); + until TThread.GetTickCount64 >= Deadline; + + const StillOpen = ActiveCount; + if StillOpen > 0 then + TLogger.Warning(Format('%d subscription(s) did not close in time', [StillOpen])); +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..49d1fb3 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,247 +14,458 @@ 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); + {$IFDEF DEBUG} + procedure WarnIfStructuredContentMismatchesSchema(const Tool: IMCPTool; const Result: TJSONObject); + {$ENDIF} + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; private - FTools: TDictionary; procedure RegisterTool(const Tool: IMCPTool); procedure RegisterBuiltInTools; public - constructor Create; + constructor Create; overload; + constructor Create(const SeedFromRegistry: Boolean); overload; 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 + CAPABILITY_NAME = 'tools'; + + +const + TOOL_NAME_PATTERN = '^[A-Za-z0-9_.\-]{1,128}$'; + +{$IFDEF DEBUG} +procedure TMCPToolsManager.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.TryValidate(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; + Create(True); +end; + +constructor TMCPToolsManager.Create(const SeedFromRegistry: Boolean); +begin + inherited Create; + FLock := TCriticalSection.Create; FTools := TDictionary.Create; - RegisterBuiltInTools; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; + if SeedFromRegistry then + RegisterBuiltInTools; end; destructor TMCPToolsManager.Destroy; begin FTools.Free; + FOrder.Free; + FLock.Free; inherited; end; function TMCPToolsManager.GetCapabilityName: string; begin - Result := 'tools'; + Result := CAPABILITY_NAME; end; function TMCPToolsManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'tools/list') or (Method = 'tools/call'); + Result := (Method = MCP_METHOD_TOOLS_LIST) or (Method = MCP_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(MCP_KEY_LIST_CHANGED, TJSONBool.Create(Announces)); + Capabilities.AddPair(CAPABILITY_NAME, 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 - if Method = 'tools/list' then - Result := ListTools - else if Method = 'tools/call' then - Result := CallTool(Params) + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPToolsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = MCP_METHOD_TOOLS_LIST then + Result := ListTools(Params, EraOf(Context)) + else if Method = MCP_METHOD_TOOLS_CALL then + Result := CallTool(Params, EraOf(Context)) else - raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); + raise EMCPError.MethodNotFound(Method); +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; + +function TMCPToolsManager.TryGetTool(const Name: string; out Tool: IMCPTool): Boolean; +begin + FLock.Enter; + try + Result := FTools.TryGetValue(Name, Tool); + finally + FLock.Leave; + end; end; -procedure TMCPToolsManager.RegisterBuiltInTools; +function TMCPToolsManager.HasTool(const Name: string): Boolean; var Tool: IMCPTool; - ToolName: string; begin - for ToolName in TMCPRegistry.GetToolNames do - begin - Tool := TMCPRegistry.CreateTool(ToolName); - RegisterTool(Tool); + 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; + NotifyListChanged; end; -function TMCPToolsManager.ExtractToolNameAndArguments(const Params: System.JSON.TJSONObject; out ToolName: string; out Arguments: TJSONObject): Boolean; -var - ArgsValue: TJSONValue; - NameValue: TJSONValue; +procedure TMCPToolsManager.NotifyListChanged; begin - Result := False; - ToolName := ''; - Arguments := nil; - - if not Assigned(Params) then - Exit; - - NameValue := Params.GetValue('name'); - if Assigned(NameValue) then + if Assigned(FChangeNotifier) then + FChangeNotifier.ToolsListChanged; +end; + +procedure TMCPToolsManager.RegisterBuiltInTools; +begin + for var ToolName in TMCPRegistry.GetToolNames do begin - ToolName := NameValue.Value; - Result := ToolName <> ''; + RegisterTool(TMCPRegistry.CreateTool(ToolName)); end; - - ArgsValue := Params.GetValue('arguments'); - if Assigned(ArgsValue) and (ArgsValue is TJSONObject) then - Arguments := ArgsValue as TJSONObject; end; -function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject): TValue; +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(MCP_KEY_CURSOR)) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +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 + begin + Result := ToolResult.ToJson(Era); + Exit; + end; + 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.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 + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_CONTENT, ResultValue.AsType); + 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(MCP_KEY_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 + begin + Result := ErrorResult(E.Message, Era); + Exit; + end; + on E: EArgumentException do + begin + Result := ErrorResult('Invalid arguments: ' + E.Message, Era); + Exit; + end; + on E: EMCPError do + raise; + on E: EMCPRequestCancelled do + raise; + on E: EMCPInputRequired do + raise; + on E: Exception do + begin + Result := ErrorResult('Error executing tool: ' + E.Message, Era); + Exit; + end; + 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); - if Tool.Title <> Tool.Name then - Result.AddPair('title', Tool.Title); - Result.AddPair('description', Tool.Description); + Result.AddPair(MCP_KEY_NAME, Tool.Name); + const IsNotName = (Tool.Title <> Tool.Name); + if IsNotName then + Result.AddPair(MCP_KEY_TITLE, Tool.Title); + Result.AddPair(MCP_KEY_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(MCP_KEY_ANNOTATIONS, TJSONObject(Metadata.Annotations.Clone)); + if Assigned(Metadata.Icons) then + Result.AddPair(MCP_KEY_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; - Result.AddPair('tools', ToolsArray); + var ToolsArray := TJSONArray.Create; + Result.AddPair(CAPABILITY_NAME, ToolsArray); + + FLock.Enter; + try + for var Name in FOrder do + begin + ToolsArray.AddElement(CreateToolJSON(FTools[Name])); + end; + finally + FLock.Leave; + end; - for Tool in FTools.Values do + const IsModern = (Era = TMCPProtocolEra.Modern); + if IsModern then begin - ToolJSON := CreateToolJSON(Tool); - ToolsArray.AddElement(ToolJSON); + Result.AddPair(MCP_KEY_TTL_MS, TJSONNumber.Create(FListTtlMs)); + Result.AddPair(MCP_KEY_CACHE_SCOPE, 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(MCP_KEY_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(MCP_KEY_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..2a4004e --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.Base.pas @@ -0,0 +1,329 @@ +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; + FPendingAnnotations: TJSONObject; + 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 + FPendingAnnotations.Free; + 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(MCP_KEY_CONTENT, Content); + FMessages.AddElement(Message); + if Assigned(FPendingAnnotations) then + begin + Content.AddPair(MCP_KEY_ANNOTATIONS, FPendingAnnotations); + FPendingAnnotations := nil; + end; + Result := Self; +end; + +function TMCPPromptMessages.AddText(const Role, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.Text(Text)); +end; + +function TMCPPromptMessages.AddImage(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddImage(Role, TMCPContentBlock.EncodeBlob(Data), MimeType); +end; + +function TMCPPromptMessages.AddImage(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.Image(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddAudio(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddAudio(Role, TMCPContentBlock.EncodeBlob(Data), MimeType); +end; + +function TMCPPromptMessages.AddAudio(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.Audio(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddResourceLink(const Role, Uri, Name, Description, + MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.ResourceLink(Uri, Name, Description, MimeType)); +end; + +function TMCPPromptMessages.AddEmbeddedText(const Role, Uri, MimeType, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.EmbeddedText(Uri, MimeType, Text)); +end; + +function TMCPPromptMessages.AddEmbeddedBlob(const Role, Uri, MimeType: string; + const Data: TBytes): TMCPPromptMessages; +begin + Result := AddMessage(Role, TMCPContentBlock.EmbeddedBlob(Uri, MimeType, TMCPContentBlock.EncodeBlob(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 + const HasMessage = (FMessages.Count > 0); + if HasMessage then + begin + const LastMessage = TJSONObject(FMessages.Items[FMessages.Count - 1]); + TJSONObject(LastMessage.GetValue(MCP_KEY_CONTENT)).AddPair(MCP_KEY_ANNOTATIONS, Annotations); + end + else + begin + FPendingAnnotations.Free; + FPendingAnnotations := Annotations; + end; + 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..ae650e7 --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.ContentSamples.pas @@ -0,0 +1,202 @@ +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 + ROLE_USER = 'user'; + PROMPT_SIMPLE = 'test_simple_prompt'; + PROMPT_WITH_ARGUMENTS = 'test_prompt_with_arguments'; + PROMPT_WITH_EMBEDDED_RESOURCE = 'test_prompt_with_embedded_resource'; + PROMPT_WITH_IMAGE = 'test_prompt_with_image'; + PROMPT_INPUT_REQUIRED = 'test_input_required_result_prompt'; + KEY_USER_CONTEXT = 'user_context'; + FIELD_CONTEXT = 'context'; + +{ TSimplePrompt } + +constructor TSimplePrompt.Create; +begin + inherited; + FName := PROMPT_SIMPLE; + FDescription := 'A simple prompt with no arguments'; +end; + +function TSimplePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText(ROLE_USER, 'This is a simple prompt for testing.'); + Result := 'Simple prompt'; +end; + +{ TArgumentsPrompt } + +constructor TArgumentsPrompt.Create; +begin + inherited; + FName := 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(ROLE_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 := 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(ROLE_USER, Params.ResourceUri, 'text/plain', 'Embedded resource content for testing.'); + Messages.AddText(ROLE_USER, 'Please process the embedded resource above.'); + Result := 'Prompt with embedded resource'; +end; + +{ TImagePrompt } + +constructor TImagePrompt.Create; +begin + inherited; + FName := 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(ROLE_USER, SAMPLE_PNG_BASE64, 'image/png'); + Messages.AddText(ROLE_USER, 'Please analyze the image above.'); + Result := 'Prompt with image'; +end; + +{ TInputRequiredPrompt } + +constructor TInputRequiredPrompt.Create; +begin + inherited; + FName := PROMPT_INPUT_REQUIRED; + 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); + const UserContextIsEmpty = (UserContext = ''); + if UserContextIsEmpty then + raise EMCPInputRequired.Create(TMCPInputRequests.Create.AddElicitation(KEY_USER_CONTEXT, + 'What context should the prompt use?', TMCPInputRequests.FieldSchema(FIELD_CONTEXT))); + + Messages.AddText(ROLE_USER, Format('Use this context: %s', [UserContext])); + Result := 'Prompt with client-provided context'; +end; + +initialization + TMCPRegistry.RegisterPrompt(PROMPT_SIMPLE, + function: IMCPPrompt + begin + Result := TSimplePrompt.Create; + end); + TMCPRegistry.RegisterPrompt(PROMPT_WITH_ARGUMENTS, + function: IMCPPrompt + begin + Result := TArgumentsPrompt.Create; + end); + TMCPRegistry.RegisterPrompt(PROMPT_WITH_EMBEDDED_RESOURCE, + function: IMCPPrompt + begin + Result := TEmbeddedResourcePrompt.Create; + end); + TMCPRegistry.RegisterPrompt(PROMPT_WITH_IMAGE, + function: IMCPPrompt + begin + Result := TImagePrompt.Create; + end); + TMCPRegistry.RegisterPrompt(PROMPT_INPUT_REQUIRED, + 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..843964f --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas @@ -0,0 +1,123 @@ +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, + System.NetEncoding; + +const + ROLE_USER = 'user'; + PROMPT_NAME = 'summarize_logs'; + + +{ TSummarizeLogsPrompt } + +constructor TSummarizeLogsPrompt.Create; +begin + inherited; + FName := PROMPT_NAME; + 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(ROLE_USER, 'Summarize the server''s recent log entries, calling out anything unusual.'); + ResourceUri := 'logs://recent'; + end + else + begin + Messages.AddText(ROLE_USER, Format( + 'Summarize the server''s recent "%s" log entries, calling out anything unusual.', [Params.Level])); + ResourceUri := Format('logs://%s', [TNetEncoding.URL.Encode(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(ROLE_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 + begin + Result := TMCPCompletion.Create(nil); + Exit; + end; + + 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(PROMPT_NAME, + 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..f4b87e6 --- /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(MCP_KEY_LIST_CHANGED, TJSONBool.Create(False)); + Capabilities.AddPair('tools', Tools); + + var Resources := TJSONObject.Create; + Resources.AddPair(MCP_KEY_SUBSCRIBE, TJSONBool.Create(False)); + Resources.AddPair(MCP_KEY_LIST_CHANGED, 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..0c3d66b --- /dev/null +++ b/src/Protocol/MCPServer.ContentBlocks.pas @@ -0,0 +1,103 @@ +unit MCPServer.ContentBlocks; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +type + TMCPContentBlock = record + class function Text(const Value: string): TJSONObject; static; + class function Image(const Base64Data, MimeType: string): TJSONObject; static; + class function Audio(const Base64Data, MimeType: string): TJSONObject; static; + class function ResourceLink(const Uri, Name: string; const Description: string = ''; + const MimeType: string = ''): TJSONObject; static; + class function EmbeddedText(const Uri, MimeType, Text: string): TJSONObject; static; + class function EmbeddedBlob(const Uri, MimeType, Base64Blob: string): TJSONObject; static; + class function EncodeBlob(const Data: TBytes): string; static; + end; + +implementation + +uses + System.NetEncoding; + +const + BLOCK_TYPE_RESOURCE = 'resource'; + KEY_DATA = 'data'; + + +{ TMCPContentBlock } + +class function TMCPContentBlock.EncodeBlob(const Data: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Data); + finally + Encoding.Free; + end; +end; + +class function TMCPContentBlock.Text(const Value: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, 'text'); + Result.AddPair(MCP_KEY_TEXT, Value); +end; + +class function TMCPContentBlock.Image(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, 'image'); + Result.AddPair(KEY_DATA, Base64Data); + Result.AddPair(MCP_KEY_MIME_TYPE, MimeType); +end; + +class function TMCPContentBlock.Audio(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, 'audio'); + Result.AddPair(KEY_DATA, Base64Data); + Result.AddPair(MCP_KEY_MIME_TYPE, MimeType); +end; + +class function TMCPContentBlock.ResourceLink(const Uri, Name, Description, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, 'resource_link'); + Result.AddPair(MCP_KEY_URI, Uri); + Result.AddPair(MCP_KEY_NAME, Name); + const HasDescription = (Description <> ''); + if HasDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, Description); + const HasMimeType = (MimeType <> ''); + if HasMimeType then + Result.AddPair(MCP_KEY_MIME_TYPE, MimeType); +end; + +class function TMCPContentBlock.EmbeddedText(const Uri, MimeType, Text: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair(MCP_KEY_URI, Uri); + Resource.AddPair(MCP_KEY_MIME_TYPE, MimeType); + Resource.AddPair(MCP_KEY_TEXT, Text); + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, BLOCK_TYPE_RESOURCE); + Result.AddPair(BLOCK_TYPE_RESOURCE, Resource); +end; + +class function TMCPContentBlock.EmbeddedBlob(const Uri, MimeType, Base64Blob: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair(MCP_KEY_URI, Uri); + Resource.AddPair(MCP_KEY_MIME_TYPE, MimeType); + Resource.AddPair('blob', Base64Blob); + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, BLOCK_TYPE_RESOURCE); + Result.AddPair(BLOCK_TYPE_RESOURCE, Resource); +end; + +end. diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas new file mode 100644 index 0000000..4be170f --- /dev/null +++ b/src/Protocol/MCPServer.Errors.pas @@ -0,0 +1,181 @@ +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; + + EMCPConfigurationError = 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 + +const + KEY_REQUIRED_SCOPE = 'requiredScope'; + MESSAGE_RESOURCE_NOT_FOUND = 'Resource not found'; + +{ 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 + begin + SupportedArray.Add(Version); + end; + + 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(MCP_KEY_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(MCP_KEY_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(KEY_REQUIRED_SCOPE, ''); +end; + +class function EMCPError.InsufficientScope(const Scope: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair(KEY_REQUIRED_SCOPE, 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(MCP_KEY_URI, Uri); + const IsModern = (Era = TMCPProtocolEra.Modern); + if IsModern then + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, MESSAGE_RESOURCE_NOT_FOUND, Data) + else + Result := EMCPError.Create(MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY, MESSAGE_RESOURCE_NOT_FOUND, Data); +end; + +end. diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 8e9b4e6..22a4238 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -7,219 +7,924 @@ interface System.JSON, System.Rtti, MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.Mrtr, + MCPServer.Errors, + MCPServer.HttpHeaders, + MCPServer.Registration, 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 ModernContext(const Method: string; const Params: TJSONObject; const RequestId: TMCPRequestId; + const Meta: TJSONObject; const Version: string; const Hints: TMCPTransportHints): IMCPRequestContext; + function LegacyContext(const Method: string; const Params: TJSONObject; const RequestId: TMCPRequestId; + const Meta: TJSONObject; const Hints: TMCPTransportHints): IMCPRequestContext; + function ReadRequestObject(const Message: TJSONValue): TJSONObject; + function ReadRequestId(const Request: TJSONObject): TMCPRequestId; + function ReadMethod(const Request: TJSONObject; Era: TMCPProtocolEra; out IsClientResponse: Boolean): string; + function ReadParams(const Request: TJSONObject; Era: TMCPProtocolEra): TJSONObject; + function RunRequest(const Context: IMCPRequestContext; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProcessResult; + function SuccessResult(const Context: IMCPRequestContext; const Value: TValue): TMCPProcessResult; + function AcceptedResult(Era: TMCPProtocolEra): TMCPProcessResult; + 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 + MESSAGE_NOT_A_JSON_RESULT = '%s answered with a %s instead of a JSON object'; + META_PATH_PREFIX = 'params._meta.'; + MESSAGE_PARAMS_NOT_OBJECT = 'params must be an object'; + MESSAGE_HEADER_MISMATCH = 'Header mismatch: %s header value ''%s'' does not match body value ''%s'''; + MESSAGE_HEADER_MISSING_SUFFIX = ' header is missing'; + MESSAGE_HEADER_INVALID_SUFFIX = ' header value is not a valid header value'; + RESULT_TYPE_COMPLETE = 'complete'; + + LEGACY_ONLY_METHODS: array[0..4] of string = ( + MCP_METHOD_PING, MCP_METHOD_INITIALIZE, MCP_METHOD_LOGGING_SET_LEVEL, MCP_METHOD_RESOURCES_SUBSCRIBE, MCP_METHOD_RESOURCES_UNSUBSCRIBE); + MODERN_ONLY_METHODS: array[0..1] of string = (MCP_METHOD_SERVER_DISCOVER, 'subscriptions/listen'); + INPUT_REQUIRED_METHODS: array[0..2] of string = (MCP_METHOD_TOOLS_CALL, MCP_METHOD_RESOURCES_READ, MCP_METHOD_PROMPTS_GET); + PARAM_INPUT_RESPONSES = 'inputResponses'; + PARAM_REQUEST_STATE = 'requestState'; + { 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; -class function TMCPJsonRpcProcessor.ParseJSONRequest(const RequestBody: string): TJSONObject; -var - ParsedValue: TJSONValue; +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 + begin + Result := Result + [Version]; + end; + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + begin + Result := Result + [Version]; + end; +end; + +function TMCPJsonRpcProcessor.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_NAME, FSettings.ServerName); + Result.AddPair(MCP_KEY_VERSION, FSettings.ServerVersion); + const HasServerTitle = (FSettings.ServerTitle <> ''); + if HasServerTitle then + Result.AddPair(MCP_KEY_TITLE, FSettings.ServerTitle); + const HasServerDescription = (FSettings.ServerDescription <> ''); + if HasServerDescription then + Result.AddPair(MCP_KEY_DESCRIPTION, FSettings.ServerDescription); + const HasServerWebsiteUrl = (FSettings.ServerWebsiteUrl <> ''); + if HasServerWebsiteUrl then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPJsonRpcProcessor.IsLegacyOnlyMethod(const Method: string): Boolean; +begin + Result := TMCPStrings.Contains(Method, LEGACY_ONLY_METHODS); + if Result and (Method = MCP_METHOD_PING) and FSettings.LenientModernPing then + Result := False; +end; + +function TMCPJsonRpcProcessor.IsModernOnlyMethod(const Method: string): Boolean; +begin + Result := TMCPStrings.Contains(Method, MODERN_ONLY_METHODS); +end; + +function TMCPJsonRpcProcessor.IsCacheableMethod(const Method: string): Boolean; begin - ParsedValue := TJSONObject.ParseJSONValue(RequestBody); - if not Assigned(ParsedValue) then - raise Exception.Create('Invalid JSON'); + Result := TMCPStrings.Contains(Method, MCP_CACHEABLE_METHODS); +end; + +function TMCPJsonRpcProcessor.IsInputRequiredMethod(const Method: string): Boolean; +begin + Result := TMCPStrings.Contains(Method, INPUT_REQUIRED_METHODS); +end; - if not (ParsedValue is TJSONObject) then +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 - ParsedValue.Free; - raise Exception.Create('JSON-RPC request must be an object'); + 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 := ParsedValue as TJSONObject; + Result := FStateSealer.Open(TJSONString(Value).Value, Method, TMCPRequestStateSealer.DigestOf(Params), Hints.Principal); end; -class function TMCPJsonRpcProcessor.ExtractRequestID(JSONRequest: TJSONObject): TValue; +function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; +begin + if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader and + TMCPProtocolVersion.IsModern(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(MCP_KEY_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(MCP_KEY_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, + META_PATH_PREFIX + 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, + META_PATH_PREFIX + 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, + META_PATH_PREFIX + MCP_META_LOG_LEVEL + ' must be one of debug, info, notice, warning, error, critical, alert, emergency', + nil, HTTP_STATUS_BAD_REQUEST); +end; + +procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints); var - IdValue: TJSONValue; + Decoded: 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 + if not Hints.HasMethodHeader then + raise EMCPError.HeaderMismatch(MCP_HEADER_METHOD + MESSAGE_HEADER_MISSING_SUFFIX); + const IsNotMethod = (Hints.MethodHeader <> Method); + if IsNotMethod then + raise EMCPError.HeaderMismatch(Format(MESSAGE_HEADER_MISMATCH, + [MCP_HEADER_METHOD, Hints.MethodHeader, Method])); + + var SourceField := ''; + if (Method = MCP_METHOD_TOOLS_CALL) or (Method = MCP_METHOD_PROMPTS_GET) then + SourceField := 'name' + else if Method = MCP_METHOD_RESOURCES_READ then + SourceField := 'uri'; + const SourceFieldIsEmpty = (SourceField = ''); + if SourceFieldIsEmpty then + Exit; + + if not Hints.HasNameHeader then + raise EMCPError.HeaderMismatch(MCP_HEADER_NAME + MESSAGE_HEADER_MISSING_SUFFIX); + if not TMCPHeaderValue.TryDecode(Hints.NameHeader, Decoded) then + raise EMCPError.HeaderMismatch(MCP_HEADER_NAME + MESSAGE_HEADER_INVALID_SUFFIX); + + var BodyValue := ''; + if Assigned(Params) then begin - Result := TValue.Empty; + var Source := Params.GetValue(SourceField); + if IsJsonString(Source) then + BodyValue := TJSONString(Source).Value; + end; + const IsNotBodyValue = (Decoded <> BodyValue); + if IsNotBodyValue then + raise EMCPError.HeaderMismatch(Format(MESSAGE_HEADER_MISMATCH, + [MCP_HEADER_NAME, Decoded, BodyValue])); +end; + +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; + +function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; +begin + const Meta = ExtractMeta(Params); + + var VersionValue: TJSONValue := nil; + if Assigned(Meta) then + VersionValue := Meta.GetValue(MCP_META_PROTOCOL_VERSION); + + const CarriesModernMeta = (VersionValue is TJSONString); + if CarriesModernMeta then + begin + Result := ModernContext(Method, Params, RequestId, Meta, TJSONString(VersionValue).Value, Hints); + Exit; + end; + + Result := LegacyContext(Method, Params, RequestId, Meta, Hints); +end; + +function TMCPJsonRpcProcessor.ModernContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Meta: TJSONObject; const Version: string; + const Hints: TMCPTransportHints): IMCPRequestContext; +begin + if Hints.HasHeaderLayer then + begin + if not Hints.HasProtocolVersionHeader then + raise EMCPError.HeaderMismatch(MCP_HEADER_PROTOCOL_VERSION + MESSAGE_HEADER_MISSING_SUFFIX); + const IsNotVersion = (Hints.ProtocolVersionHeader <> Version); + if IsNotVersion then + raise EMCPError.HeaderMismatch(Format(MESSAGE_HEADER_MISMATCH, + [MCP_HEADER_PROTOCOL_VERSION, Hints.ProtocolVersionHeader, Version])); + end; + + if not TMCPProtocolVersion.IsModern(Version) then + raise EMCPError.UnsupportedProtocolVersion(Version, SupportedModernVersions); + + if Hints.HasHeaderLayer then + ValidateMirroredHeaders(Method, Params, Hints); + + ValidateModernMeta(Meta); + + if IsLegacyOnlyMethod(Method) then + begin + const 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; + Result := NewContext(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, Hints, InputResponses, RequestState); +end; + +function TMCPJsonRpcProcessor.LegacyContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Meta: TJSONObject; const Hints: TMCPTransportHints): IMCPRequestContext; +begin + if Method = MCP_METHOD_INITIALIZE then + begin + var Requested := ''; + if Assigned(Params) then + begin + const RequestedValue = Params.GetValue(MCP_KEY_PROTOCOL_VERSION); + if IsJsonString(RequestedValue) then + Requested := TJSONString(RequestedValue).Value; + end; + const Negotiated = TMCPProtocolVersion.NegotiateLegacy(Requested); + begin + Result := NewContext(TMCPProtocolEra.Legacy, Negotiated, Method, RequestId, Meta, Hints); + Exit; + end; + end; + + if IsModernOnlyMethod(Method) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('%s requires %s%s', [Method, META_PATH_PREFIX, MCP_META_PROTOCOL_VERSION]), nil, HTTP_STATUS_BAD_REQUEST); + + const HasVersionHeader = (Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader); + if HasVersionHeader then + begin + const Header = Hints.ProtocolVersionHeader; + if TMCPProtocolVersion.IsModern(Header) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('MCP-Protocol-Version %s requires %s%s', [Header, META_PATH_PREFIX, MCP_META_PROTOCOL_VERSION]), + nil, HTTP_STATUS_BAD_REQUEST); + + const IsKnownHeader = (TMCPProtocolVersion.IsLegacy(Header) or (Header = MCP_PROTOCOL_VERSION_2025_03_26)); + if not IsKnownHeader then + raise EMCPError.Create(JSONRPC_INVALID_REQUEST, + Format('Unsupported MCP-Protocol-Version header: %s', [Header]), nil, HTTP_STATUS_BAD_REQUEST); + + begin + Result := NewContext(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, Hints); + Exit; + end; + end; + + var Version := ''; + if Assigned(Hints.LegacySession) then + Version := Hints.LegacySession.ProtocolVersion; + const VersionIsEmpty = (Version = ''); + if VersionIsEmpty 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 := Default(TMCPProcessResult); + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := EraFromHeaders(Hints); + Result.IsNotification := True; + + TLogger.Info('Notification received: ' + Method); + + const IsMcpMethodNotificationsCancelled = (Method = MCP_METHOD_NOTIFICATIONS_CANCELLED); + if IsMcpMethodNotificationsCancelled then + begin + HandleCancelled(Params, Hints); Exit; end; - IdValue := JSONRequest.GetValue('id'); - if not Assigned(IdValue) then + 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; + +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); + const CapabilityIsEmpty = (Capability = ''); + if CapabilityIsEmpty 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(MCP_KEY_RESULT_TYPE, RESULT_TYPE_INPUT_REQUIRED); + const HasRequests = (Required.Requests.Count > 0); + if HasRequests 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); + + const Response = TJSONObject.Create; + try + Response.AddPair(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Response.AddPair(MCP_KEY_ID, Context.RequestId.ToJson); + Response.AddPair(MCP_KEY_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); - Result := Manager.ExecuteMethod(MethodName, Params); + const Previous = 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(Previous); + end; end; -class function TMCPJsonRpcProcessor.CreateErrorResponse(const RequestID: TValue; - ErrorCode: Integer; const ErrorMessage: string): string; -var - ErrorObj: TJSONObject; - JSONResponse: TJSONObject; +procedure TMCPJsonRpcProcessor.ApplyModernEnvelope(const ResultObject: TJSONObject; const Method: string); begin - JSONResponse := CreateJSONResponse(RequestID); + if not Assigned(ResultObject.GetValue(MCP_KEY_RESULT_TYPE)) then + ResultObject.AddPair(MCP_KEY_RESULT_TYPE, RESULT_TYPE_COMPLETE); + + var MetaValue := ResultObject.GetValue(MCP_KEY_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(MCP_KEY_META, Meta); + end; + if Assigned(Meta) and not Assigned(Meta.GetValue(MCP_META_SERVER_INFO)) then + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); + + var ResultType := ResultObject.GetValue(MCP_KEY_RESULT_TYPE); + if IsCacheableMethod(Method) and (ResultType is TJSONString) and + (TJSONString(ResultType).Value = RESULT_TYPE_COMPLETE) then + begin + if not Assigned(ResultObject.GetValue(MCP_KEY_TTL_MS)) then + ResultObject.AddPair(MCP_KEY_TTL_MS, TJSONNumber.Create(0)); + if not Assigned(ResultObject.GetValue(MCP_KEY_CACHE_SCOPE)) then + ResultObject.AddPair(MCP_KEY_CACHE_SCOPE, MCP_CACHE_SCOPE_PRIVATE); + end; +end; + +function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: IMCPRequestContext): TJSONValue; +begin + 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 + begin + if Value.IsObject then + raise EMCPError.InternalError(Format(MESSAGE_NOT_A_JSON_RESULT, + [Context.Method, Value.AsObject.ClassName])); + Result := TJSONString.Create(Value.ToString); + end; + Exit; + end; + + var ResultObject: TJSONObject; + if Value.IsType then + ResultObject := Value.AsType + else + begin + if Value.IsObject then + raise EMCPError.InternalError(Format(MESSAGE_NOT_A_JSON_RESULT, + [Context.Method, Value.AsObject.ClassName])); + 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 := ''; + const IsHttpStatusForbidden = (Error.HttpStatus = HTTP_STATUS_FORBIDDEN); + if IsHttpStatusForbidden 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(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Response.AddPair(MCP_KEY_ID, RequestId.ToJson); + + var ErrorObject := TJSONObject.Create; + Response.AddPair(MCP_KEY_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.ProcessRequest(const RequestBody: string; const SessionID: string): string; -var - ErrorCode: Integer; - ExecuteResult: TValue; - JSONRequest: TJSONObject; - JSONResponse: TJSONObject; - MethodName: string; - MethodValue: TJSONValue; - Params: TJSONObject; - ParamsValue: TJSONValue; - RequestID: TValue; +function TMCPJsonRpcProcessor.ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; +begin + if E is EMCPRegistryNotFound then + Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, E.Message) + else + Result := EMCPError.InternalError(E.Message); +end; + +function TMCPJsonRpcProcessor.ReadRequestObject(const Message: TJSONValue): TJSONObject; +begin + 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'); + Result := TJSONObject(Message); +end; + +function TMCPJsonRpcProcessor.ReadRequestId(const Request: TJSONObject): TMCPRequestId; +begin + Result := TMCPRequestId.FromJson(Request.GetValue(MCP_KEY_ID)); + const IsNull = (Result.Kind = TMCPRequestIdKind.Null); + if IsNull then + raise EMCPError.InvalidRequest('id must not be null'); + const IsInvalid = (Result.Kind = TMCPRequestIdKind.Invalid); + if IsInvalid then + begin + Result := TMCPRequestId.FromJson(nil); + raise EMCPError.InvalidRequest('id must be a string or an integer'); + end; +end; + +function TMCPJsonRpcProcessor.ReadMethod(const Request: TJSONObject; Era: TMCPProtocolEra; + out IsClientResponse: Boolean): string; begin + IsClientResponse := False; + const JsonRpc = Request.GetValue(MCP_KEY_JSONRPC); + const IsSupportedVersion = (IsJsonString(JsonRpc) and (TJSONString(JsonRpc).Value = JSONRPC_VERSION)); + if not IsSupportedVersion then + raise EMCPError.InvalidRequest('jsonrpc must be "2.0"'); + + const MethodValue = Request.GetValue(MCP_KEY_METHOD); + if IsJsonString(MethodValue) then + begin + Result := TJSONString(MethodValue).Value; + Exit; + end; + + const IsResponse = (Assigned(Request.GetValue(MCP_KEY_RESULT)) or Assigned(Request.GetValue(MCP_KEY_ERROR))); + if not IsResponse then + raise EMCPError.InvalidRequest('method must be a string'); + const IsModern = (Era = TMCPProtocolEra.Modern); + if IsModern then + raise EMCPError.InvalidRequest('JSON-RPC responses are not accepted'); + + IsClientResponse := True; Result := ''; - JSONRequest := nil; - JSONResponse := nil; +end; - try - try - JSONRequest := ParseJSONRequest(RequestBody); +function TMCPJsonRpcProcessor.ReadParams(const Request: TJSONObject; Era: TMCPProtocolEra): TJSONObject; +begin + Result := nil; + const ParamsValue = Request.GetValue(MCP_KEY_PARAMS); + if not Assigned(ParamsValue) then + Exit; - RequestID := ExtractRequestID(JSONRequest); + if not (ParamsValue is TJSONObject) then + begin + if Era = TMCPProtocolEra.Modern then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, MESSAGE_PARAMS_NOT_OBJECT, nil, HTTP_STATUS_BAD_REQUEST); + raise EMCPError.InvalidParams(MESSAGE_PARAMS_NOT_OBJECT); + end; + Result := TJSONObject(ParamsValue); +end; - MethodValue := JSONRequest.GetValue('method'); - MethodName := ''; - if Assigned(MethodValue) then - MethodName := MethodValue.Value; +function TMCPJsonRpcProcessor.AcceptedResult(Era: TMCPProtocolEra): TMCPProcessResult; +begin + Result := Default(TMCPProcessResult); + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := Era; + Result.IsNotification := True; +end; - // Notifications (requests without id) should not have a response - if RequestID.IsEmpty then - begin - if MethodName = 'notifications/initialized' then - TLogger.Info('MCP Initialized notification received') - else - TLogger.Info('Notification received: ' + MethodName); - Exit; - end; +function TMCPJsonRpcProcessor.RunRequest(const Context: IMCPRequestContext; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProcessResult; +var + ExecuteResult: TValue; +begin + if Assigned(Hints.Tracker) then + Hints.Tracker.Track(Context); + try + try + ExecuteResult := DispatchRequest(Context, Params); + except + on E: EMCPInputRequired do + begin + Result := InputRequiredResult(Context, Params, Hints, E); + Exit; + end; + end; + finally + if Assigned(Hints.Tracker) then + Hints.Tracker.Untrack(Context); + end; - JSONResponse := CreateJSONResponse(RequestID); + if Context.IsCancelled then + begin + if ExecuteResult.IsObject then + ExecuteResult.AsObject.Free; + begin + Result := CancelledResult(Context.Era); + Exit; + end; + end; - ParamsValue := JSONRequest.GetValue('params'); - Params := nil; - if Assigned(ParamsValue) and (ParamsValue is TJSONObject) then - Params := ParamsValue as TJSONObject; + Result := SuccessResult(Context, ExecuteResult); +end; - ExecuteResult := ExecuteMethodCall(FManagerRegistry, MethodName, Params); +function TMCPJsonRpcProcessor.SuccessResult(const Context: IMCPRequestContext; const Value: TValue): TMCPProcessResult; +begin + Result := Default(TMCPProcessResult); + const Response = TJSONObject.Create; + try + Response.AddPair(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Response.AddPair(MCP_KEY_ID, Context.RequestId.ToJson); + const ResultJson = ResultToJson(Value, Context); + if Assigned(ResultJson) then + Response.AddPair(MCP_KEY_RESULT, ResultJson); + Result.Body := Response.ToJSON; + finally + Response.Free; + end; + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Context.Era; +end; - if not ExecuteResult.IsEmpty 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); - end; +function TMCPJsonRpcProcessor.ProcessRequest(const RequestBody: string; const SessionID: string): string; +begin + Result := ProcessRequestEx(RequestBody, TMCPTransportHints.None).Body; +end; - Result := JSONResponse.ToJSON; +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 + RequestId: TMCPRequestId; + Era: TMCPProtocolEra; + Context: IMCPRequestContext; +begin + RequestId := TMCPRequestId.FromJson(nil); + Era := EraFromHeaders(Hints); + Context := nil; + + try + try + const Request = ReadRequestObject(Message); + RequestId := ReadRequestId(Request); + + var IsClientResponse := False; + const Method = ReadMethod(Request, Era, IsClientResponse); + if IsClientResponse then + begin + Result := AcceptedResult(Era); + Exit; + end; + + const Params = ReadParams(Request, Era); + const IsNone = (RequestId.Kind = TMCPRequestIdKind.None); + if IsNone then + begin + Result := ProcessNotification(Method, Params, Hints); + Exit; + end; + + Era := EraFromMessage(Method, Params, Hints); + Context := BuildRequestContext(Method, Params, RequestId, Hints); + Era := Context.Era; + Result := RunRequest(Context, Params, Hints); 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..8923422 --- /dev/null +++ b/src/Protocol/MCPServer.Mrtr.pas @@ -0,0 +1,236 @@ +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 + + +const + KEY_ROOTS = 'roots'; + +{ TMCPInputRequests } + +class function TMCPInputRequests.FieldSchema(const Field: string; const FieldType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, 'object'); + var Properties := TJSONObject.Create; + Result.AddPair('properties', Properties); + var Schema := TJSONObject.Create; + Schema.AddPair(MCP_KEY_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(MCP_KEY_METHOD, Method); + Request.AddPair(MCP_KEY_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(MCP_KEY_CONTENT, Content); + Content.AddPair(MCP_KEY_TYPE, 'text'); + Content.AddPair(MCP_KEY_TEXT, UserText); + const HasSystemPrompt = (SystemPrompt <> ''); + if HasSystemPrompt 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 + begin + Result := Result + [TJSONObject(Pair.JsonValue).GetValue(MCP_KEY_METHOD)]; + end; +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 := KEY_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(MCP_KEY_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(MCP_KEY_CONTENT); + if not (Content is TJSONObject) then + Exit; + var Text := TJSONObject(Content).GetValue(MCP_KEY_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(KEY_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..3eded03 --- /dev/null +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -0,0 +1,452 @@ +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; + FProgressLock: TObject; + FProgressSent: Boolean; + FLastProgress: Double; + FLastProgressTick: UInt64; + function TryClaimProgress(const Progress: Double; const Completes: Boolean): Boolean; + 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 function SetCurrent(const Value: IMCPRequestContext): 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; + FProgressLock := TObject.Create; +end; + +destructor TMCPRequestContext.Destroy; +begin + FMeta.Free; + FInputResponses.Free; + FRequestState.Free; + FProgressLock.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.TryClaimProgress(const Progress: Double; const Completes: Boolean): Boolean; +begin + const Tick = TThread.GetTickCount64; + TMonitor.Enter(FProgressLock); + try + if FProgressSent then + begin + const Stale = (Progress <= FLastProgress); + const TooSoon = ((Tick - FLastProgressTick < PROGRESS_MIN_INTERVAL_MS) and not Completes); + if Stale or TooSoon then + Exit(False); + end; + FProgressSent := True; + FLastProgress := Progress; + FLastProgressTick := Tick; + Result := True; + finally + TMonitor.Exit(FProgressLock); + end; +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 + begin + Result := Frac(TJSONNumber(Token).AsDouble) = 0; + Exit; + end; + Result := Token is TJSONString; +end; + +procedure TMCPRequestContext.ReportProgress(const Progress, Total: Double; const Message: string); +begin + if not Assigned(FSink) or not HasProgressToken or IsCancelled then + Exit; + + const Completes = ((Total >= 0) and (Progress >= Total)); + if not TryClaimProgress(Progress, Completes) then + Exit; + + var Notification := TJSONObject.Create; + try + Notification.AddPair(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Notification.AddPair(MCP_KEY_METHOD, MCP_METHOD_NOTIFICATIONS_PROGRESS); + var Params := TJSONObject.Create; + Notification.AddPair(MCP_KEY_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)); + const HasMessage = (Message <> ''); + if HasMessage 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); +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(MCP_KEY_JSONRPC, JSONRPC_VERSION); + Notification.AddPair(MCP_KEY_METHOD, MCP_METHOD_NOTIFICATIONS_MESSAGE); + var Params := TJSONObject.Create; + Notification.AddPair(MCP_KEY_PARAMS, Params); + Params.AddPair('level', Level); + const HasLogger = (Logger <> ''); + if HasLogger 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 function TMCPRequestContext.SetCurrent(const Value: IMCPRequestContext): IMCPRequestContext; +begin + Result := IMCPRequestContext(CurrentContextPointer); + 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..ad33b06 --- /dev/null +++ b/src/Protocol/MCPServer.RequestState.pas @@ -0,0 +1,307 @@ +unit MCPServer.RequestState; + +interface + +uses + System.SysUtils, + System.JSON; + +type + EMCPRequestStateKey = class(Exception) + end; + + 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 NewRandomKey: TBytes; static; + class function QuotedName(const Value: string): string; static; + 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 +{$IFDEF MSWINDOWS} + Winapi.Windows, +{$ENDIF} + System.Classes, + System.Hash, + System.DateUtils, + System.NetEncoding, + System.Generics.Collections, + System.Generics.Defaults, + MCPServer.Types, + MCPServer.Errors, + MCPServer.Logger; + +const + MESSAGE_INTEGRITY_FAILED = 'requestState failed integrity verification'; + + +const + KEY_BYTES = 32; + URANDOM_DEVICE = '/dev/urandom'; + 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'); + +{$IFDEF MSWINDOWS} +const + BCRYPT_USE_SYSTEM_PREFERRED_RNG = $00000002; + STATUS_SUCCESS = 0; + +function BCryptGenRandom(Algorithm: Pointer; Buffer: PByte; BufferLength: ULONG; + Flags: ULONG): Integer; stdcall; external 'bcrypt.dll' name 'BCryptGenRandom'; +{$ENDIF} + +{ TMCPRequestStateSealer } + +class function TMCPRequestStateSealer.NewRandomKey: TBytes; +var + Generated: Boolean; +begin + SetLength(Result, KEY_BYTES); +{$IFDEF MSWINDOWS} + Generated := BCryptGenRandom(nil, PByte(Result), KEY_BYTES, BCRYPT_USE_SYSTEM_PREFERRED_RNG) = STATUS_SUCCESS; +{$ELSE} + const Device = TFileStream.Create(URANDOM_DEVICE, fmOpenRead or fmShareDenyNone); + try + Generated := Device.Read(Result[0], KEY_BYTES) = KEY_BYTES; + finally + Device.Free; + end; +{$ENDIF} + if not Generated then + raise EMCPRequestStateKey.Create('The operating system did not provide a random key for requestState'); +end; + +class function TMCPRequestStateSealer.QuotedName(const Value: string): string; +begin + const Quoted = TJSONString.Create(Value); + try + Result := Quoted.ToJSON; + finally + Quoted.Free; + end; +end; + +constructor TMCPRequestStateSealer.Create(const Key: string; TtlSeconds: Integer); +begin + inherited Create; + FTtlSeconds := TtlSeconds; + const HasKey = (Key.Trim <> ''); + if HasKey then + FKey := TEncoding.UTF8.GetBytes(Key) + else + begin + FKey := NewRandomKey; + 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; + const TextIsEmpty = (Text = ''); + if TextIsEmpty 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 + begin + Standard := Standard + '='; + end; + 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 + begin + Names.Add(Pair.JsonString.Value); + end; + 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(','); + const Member = TJSONObject(Value).GetValue(Names[I]); + Parts.Append(QuotedName(Names[I])); + Parts.Append(':'); + Parts.Append(CanonicalJson(Member)); + 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(MESSAGE_INTEGRITY_FAILED); + + const Parsed = TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(PayloadBytes)); + const IsPayloadObject = (Parsed is TJSONObject); + if not IsPayloadObject then + begin + Parsed.Free; + raise EMCPError.InvalidParams(MESSAGE_INTEGRITY_FAILED); + end; + + const Payload = TJSONObject(Parsed); + 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..e392323 100644 --- a/src/Protocol/MCPServer.Schema.Generator.pas +++ b/src/Protocol/MCPServer.Schema.Generator.pas @@ -11,13 +11,42 @@ interface type TMCPSchemaGenerator = class private - class function GetJsonTypeFromRttiType(RttiType: TRttiType): string; - class function GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; - class function IsRequiredProperty(Prop: TRttiProperty): Boolean; + const MAX_NESTING_DEPTH = 8; + class var FContext: TRttiContext; + class function GetJsonName(const Member: TRttiNamedObject): string; + class function IsRequired(const Member: TRttiNamedObject): Boolean; + class function IsGuid(const RttiType: TRttiType): Boolean; + class function IsSchemaField(const RttiField: TRttiField): Boolean; + class function HasSchemaFields(const RttiType: TRttiType): Boolean; + class function IsOpaqueRecord(const RttiType: TRttiType): Boolean; class function CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; + class function ListItemType(RttiType: TRttiType): TRttiType; + class function TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function SimpleSchema(const JsonType: string): TJSONObject; + class function GuidSchema: TJSONObject; + class function ItemsSchema(const Site: string; const ElementType: TRttiType; Depth: Integer): TJSONObject; + class procedure DescribeFloat(RttiType: TRttiType; const Schema: TJSONObject); + class procedure DescribeSet(RttiType: TRttiType; const Schema: TJSONObject); + class function ClassSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function RecordSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function ObjectSchema(RttiType: TRttiType; Depth: Integer; const IsRoot: Boolean): TJSONObject; + class procedure DescribeProperties(RttiType: TRttiType; Depth: Integer; + const Properties: TJSONObject; const RequiredArray: TJSONArray); + class procedure DescribeFields(RttiType: TRttiType; Depth: Integer; + const Properties: TJSONObject; const RequiredArray: TJSONArray); + class function NumberValue(const Value: Double): TJSONNumber; + class procedure ApplyAttributes(const Member: TRttiNamedObject; const MemberSchema: TJSONObject); + class procedure GuardMemberHasType(const Site: string; const RttiType: TRttiType); + class procedure GuardParameterHasSchema(const Method: TRttiMethod; const Param: TRttiParameter); + class procedure GuardParameterRecordHasFields(const Method: TRttiMethod; const Param: TRttiParameter); public + class constructor Create; + class destructor Destroy; class function GenerateSchema(Cls: TClass): TJSONObject; class function GenerateSchemaFromInstance(Instance: TObject): TJSONObject; + class function GenerateSchemaFromType(const RttiType: TRttiType): TJSONObject; + class function GenerateSchemaFromMethod(const Method: TRttiMethod): TJSONObject; + class function GenerateSchemaFromMethodResult(const Method: TRttiMethod): TJSONObject; end; implementation @@ -26,147 +55,538 @@ implementation System.Generics.Collections, MCPServer.Types; +const + SCHEMA_KEY_ADDITIONAL_PROPERTIES = 'additionalProperties'; + SCHEMA_TYPE_STRING = 'string'; + SCHEMA_TYPE_ARRAY = 'array'; + SCHEMA_TYPE_OBJECT = 'object'; + SCHEMA_TYPE_INTEGER = 'integer'; + SCHEMA_TYPE_NUMBER = 'number'; + SCHEMA_TYPE_BOOLEAN = 'boolean'; + SCHEMA_KEY_FORMAT = 'format'; + SCHEMA_KEY_ENUM = 'enum'; + SCHEMA_KEY_ITEMS = 'items'; + SCHEMA_KEY_PROPERTIES = 'properties'; + SCHEMA_KEY_REQUIRED = 'required'; + SCHEMA_KEY_RESULT = 'result'; + SCHEMA_FORMAT_UUID = 'uuid'; + + DEPTH_ABOVE_ROOT = -1; + + UNDESCRIBABLE_KINDS = [tkUnknown, tkPointer, tkProcedure, tkMethod, tkClassRef, + tkInterface, tkVariant]; + + RECORD_KINDS = [tkRecord, tkMRecord]; + + { 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; +class constructor TMCPSchemaGenerator.Create; begin - Result := TJSONObject.Create; - Result.AddPair('type', 'object'); + FContext := TRttiContext.Create; +end; - Properties := TJSONObject.Create; - Result.AddPair('properties', Properties); - RequiredArray := TJSONArray.Create; +class destructor TMCPSchemaGenerator.Destroy; +begin + FContext.Free; +end; - RttiContext := TRttiContext.Create; - try - RttiType := RttiContext.GetType(Cls); +class function TMCPSchemaGenerator.GenerateSchema(Cls: TClass): TJSONObject; +begin + Result := ObjectSchema(FContext.GetType(Cls), 0, True); +end; - for RttiProp in RttiType.GetProperties do - begin - if RttiProp.IsReadable and RttiProp.IsWritable then - begin - JsonName := GetPropertyJsonName(RttiProp, RttiType); +class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; +begin + Result := GenerateSchema(Instance.ClassType); +end; - PropSchema := TJSONObject.Create; - Properties.AddPair(JsonName, PropSchema); +class function TMCPSchemaGenerator.GenerateSchemaFromType(const RttiType: TRttiType): TJSONObject; +begin + if not Assigned(RttiType) then + Exit(nil); - JsonType := GetJsonTypeFromRttiType(RttiProp.PropertyType); - PropSchema.AddPair('type', JsonType); + const DescribesItsOwnMembers = (RttiType.TypeKind = tkClass) or (RttiType.TypeKind in RECORD_KINDS); + if DescribesItsOwnMembers then + Exit(TypeSchema(RttiType, DEPTH_ABOVE_ROOT)); - if JsonType = 'array' then - PropSchema.AddPair('items', TJSONObject.Create); + Result := TypeSchema(RttiType, 0); +end; - EnumArray := nil; +class function TMCPSchemaGenerator.GenerateSchemaFromMethod(const Method: TRttiMethod): TJSONObject; +begin + Result := TJSONObject.Create; + try + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_OBJECT); - for Attr in RttiProp.GetAttributes do - 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; - end; + const Properties = TJSONObject.Create; + Result.AddPair(SCHEMA_KEY_PROPERTIES, Properties); - if not Assigned(EnumArray) then - EnumArray := CreateEnumValuesArray(RttiProp.PropertyType); + const RequiredArray = TJSONArray.Create; + try + for var Param in Method.GetParameters do + begin + GuardParameterHasSchema(Method, Param); - if Assigned(EnumArray) then - PropSchema.AddPair('enum', EnumArray); + const WireName = GetJsonName(Param); + const ParamSchema = GenerateSchemaFromType(Param.ParamType); + Properties.AddPair(WireName, ParamSchema); + ApplyAttributes(Param, ParamSchema); - if IsRequiredProperty(RttiProp) then - RequiredArray.Add(JsonName); + if IsRequired(Param) then + RequiredArray.Add(WireName); end; + except + RequiredArray.Free; + raise; end; - if RequiredArray.Count > 0 then - Result.AddPair('required', RequiredArray) + const HasRequiredArray = (RequiredArray.Count > 0); + if HasRequiredArray then + Result.AddPair(SCHEMA_KEY_REQUIRED, RequiredArray) else RequiredArray.Free; - finally - RttiContext.Free; + + Result.AddPair(SCHEMA_KEY_ADDITIONAL_PROPERTIES, TJSONBool.Create(False)); + except + Result.Free; + raise; end; end; -class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; +class function TMCPSchemaGenerator.GenerateSchemaFromMethodResult(const Method: TRttiMethod): TJSONObject; begin - Result := GenerateSchema(Instance.ClassType); + const ReturnType = Method.ReturnType; + if not Assigned(ReturnType) or (ReturnType.TypeKind in UNDESCRIBABLE_KINDS) then + Exit(nil); + + if IsOpaqueRecord(ReturnType) then + Exit(nil); + + Result := TJSONObject.Create; + try + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_OBJECT); + + const Properties = TJSONObject.Create; + Result.AddPair(SCHEMA_KEY_PROPERTIES, Properties); + Properties.AddPair(SCHEMA_KEY_RESULT, GenerateSchemaFromType(ReturnType)); + + const RequiredArray = TJSONArray.Create; + Result.AddPair(SCHEMA_KEY_REQUIRED, RequiredArray); + RequiredArray.Add(SCHEMA_KEY_RESULT); + + Result.AddPair(SCHEMA_KEY_ADDITIONAL_PROPERTIES, TJSONBool.Create(False)); + except + Result.Free; + raise; + end; end; -class function TMCPSchemaGenerator.GetJsonTypeFromRttiType(RttiType: TRttiType): string; +class procedure TMCPSchemaGenerator.GuardParameterHasSchema(const Method: TRttiMethod; + const Param: TRttiParameter); 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'; - else - Result := 'string'; - end; + if not Assigned(Param.ParamType) then + raise EArgumentException.CreateFmt('Parameter "%s" of %s is untyped, so it has no schema', + [Param.Name, Method.Name]); + + const AnswersThroughTheArgument = (([pfVar, pfOut] * Param.Flags) <> []); + if AnswersThroughTheArgument then + raise EArgumentException.CreateFmt( + 'Parameter "%s" of %s is a var or out parameter, so it has no schema: a tool answers with its result', + [Param.Name, Method.Name]); + + const HasNoJsonShape = (Param.ParamType.TypeKind in UNDESCRIBABLE_KINDS); + if HasNoJsonShape then + raise EArgumentException.CreateFmt( + 'Parameter "%s" of %s is of type %s, which has no JSON schema', + [Param.Name, Method.Name, Param.ParamType.Name]); + + GuardParameterRecordHasFields(Method, Param); end; -class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; +class procedure TMCPSchemaGenerator.GuardParameterRecordHasFields(const Method: TRttiMethod; + const Param: TRttiParameter); begin - Result := LowerCase(Prop.Name); + if not IsOpaqueRecord(Param.ParamType) then + Exit; + + raise EArgumentException.CreateFmt( + 'Parameter "%s" of %s is record %s, which publishes no field RTTI, so it has no schema. ' + + 'Declare it in a unit whose field RTTI covers its public fields, for example ' + + '{$RTTI EXPLICIT FIELDS([vcPublic])}.', + [Param.Name, Method.Name, Param.ParamType.Name]); end; -class function TMCPSchemaGenerator.IsRequiredProperty(Prop: TRttiProperty): Boolean; -var - Attr: TCustomAttribute; +class procedure TMCPSchemaGenerator.GuardMemberHasType(const Site: string; const RttiType: TRttiType); begin - for Attr in Prop.GetAttributes do - begin + if not Assigned(RttiType) then + raise EArgumentException.CreateFmt('%s has no type RTTI, so it has no schema', [Site]); +end; + +class function TMCPSchemaGenerator.GetJsonName(const Member: TRttiNamedObject): string; +begin + for var Attr in Member.GetAttributes do + if Attr is SchemaNameAttribute then + begin + Result := SchemaNameAttribute(Attr).Name; + Exit; + end; + Result := LowerCase(Member.Name); +end; + +class function TMCPSchemaGenerator.IsRequired(const Member: TRttiNamedObject): Boolean; +begin + for var Attr in Member.GetAttributes do if Attr is OptionalAttribute then Exit(False); - end; Result := True; end; +class function TMCPSchemaGenerator.IsGuid(const RttiType: TRttiType): Boolean; +begin + Result := (RttiType.Handle = TypeInfo(TGUID)); +end; + +class function TMCPSchemaGenerator.IsSchemaField(const RttiField: TRttiField): Boolean; +begin + Result := (RttiField.Visibility in SCHEMA_FIELD_VISIBILITIES); +end; + +class function TMCPSchemaGenerator.HasSchemaFields(const RttiType: TRttiType): Boolean; +begin + for var RttiField in RttiType.GetFields do + if IsSchemaField(RttiField) then + Exit(True); + Result := False; +end; + +class function TMCPSchemaGenerator.IsOpaqueRecord(const RttiType: TRttiType): Boolean; +begin + Result := ((RttiType.TypeKind in RECORD_KINDS) and not IsGuid(RttiType) and + not HasSchemaFields(RttiType)); +end; + class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; -var - EnumType: TRttiEnumerationType; - Ordinal: Integer; begin Result := nil; + if not (RttiType is TRttiEnumerationType) or (RttiType.Handle = TypeInfo(Boolean)) then + Exit; - if not (RttiType is TRttiEnumerationType) then + var EnumType := TRttiEnumerationType(RttiType); + Result := TJSONArray.Create; + for var Ordinal := EnumType.MinValue to EnumType.MaxValue do + begin + Result.Add(GetEnumName(RttiType.Handle, Ordinal)); + end; +end; + +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; + +class procedure TMCPSchemaGenerator.DescribeFloat(RttiType: TRttiType; const Schema: TJSONObject); +begin + if RttiType.Handle = TypeInfo(TDateTime) then + begin + Schema.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + Schema.AddPair(SCHEMA_KEY_FORMAT, 'date-time'); + end + else if RttiType.Handle = TypeInfo(TDate) then + begin + Schema.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + Schema.AddPair(SCHEMA_KEY_FORMAT, 'date'); + end + else if RttiType.Handle = TypeInfo(TTime) then + begin + Schema.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + Schema.AddPair(SCHEMA_KEY_FORMAT, 'time'); + end + else + begin + Schema.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_NUMBER); + end; +end; + +class procedure TMCPSchemaGenerator.DescribeSet(RttiType: TRttiType; const Schema: TJSONObject); +begin + Schema.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_ARRAY); + + const Items = TJSONObject.Create; + Schema.AddPair(SCHEMA_KEY_ITEMS, Items); + Items.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + + const ElementType = TRttiSetType(RttiType).ElementType; + const Names = CreateEnumValuesArray(ElementType); + if Assigned(Names) then + Items.AddPair(SCHEMA_KEY_ENUM, Names); +end; - if RttiType.Handle = TypeInfo(Boolean) then +class function TMCPSchemaGenerator.SimpleSchema(const JsonType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(MCP_KEY_TYPE, JsonType); +end; + +class function TMCPSchemaGenerator.GuidSchema: TJSONObject; +begin + Result := SimpleSchema(SCHEMA_TYPE_STRING); + Result.AddPair(SCHEMA_KEY_FORMAT, SCHEMA_FORMAT_UUID); +end; + +class function TMCPSchemaGenerator.ItemsSchema(const Site: string; const ElementType: TRttiType; + Depth: Integer): TJSONObject; +begin + GuardMemberHasType(Site, ElementType); + + Result := TypeSchema(ElementType, Depth + 1); +end; + +class function TMCPSchemaGenerator.ClassSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; +begin + const Metaclass = TRttiInstanceType(RttiType).MetaclassType; + if Metaclass.InheritsFrom(TJSONArray) then + Exit(SimpleSchema(SCHEMA_TYPE_ARRAY)); + if Metaclass.InheritsFrom(TJSONValue) then + Exit(SimpleSchema(SCHEMA_TYPE_OBJECT)); + + const ItemType = ListItemType(RttiType); + if Assigned(ItemType) then + begin + Result := SimpleSchema(SCHEMA_TYPE_ARRAY); + try + Result.AddPair(SCHEMA_KEY_ITEMS, TypeSchema(ItemType, Depth + 1)); + except + Result.Free; + raise; + end; Exit; + end; - EnumType := TRttiEnumerationType(RttiType); + const FitsAnotherLevel = (Depth < MAX_NESTING_DEPTH); + if not FitsAnotherLevel then + Exit(SimpleSchema(SCHEMA_TYPE_OBJECT)); - Result := TJSONArray.Create; - for Ordinal := EnumType.MinValue to EnumType.MaxValue do - Result.Add(GetEnumName(RttiType.Handle, Ordinal)); + Result := ObjectSchema(RttiType, Depth + 1, False); +end; + +class function TMCPSchemaGenerator.RecordSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; +begin + if IsGuid(RttiType) then + Exit(GuidSchema); + + if not HasSchemaFields(RttiType) then + Exit(SimpleSchema(SCHEMA_TYPE_STRING)); + + const FitsAnotherLevel = (Depth < MAX_NESTING_DEPTH); + if not FitsAnotherLevel then + Exit(SimpleSchema(SCHEMA_TYPE_OBJECT)); + + Result := ObjectSchema(RttiType, Depth + 1, False); +end; + +class function TMCPSchemaGenerator.TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; +begin + if RttiType.TypeKind = tkClass then + Exit(ClassSchema(RttiType, Depth)); + + if RttiType.TypeKind in RECORD_KINDS then + Exit(RecordSchema(RttiType, Depth)); + + Result := TJSONObject.Create; + try + case RttiType.TypeKind of + tkInteger, tkInt64: + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_INTEGER); + + tkFloat: + DescribeFloat(RttiType, Result); + + tkString, tkLString, tkWString, tkUString, tkChar, tkWChar: + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + + tkEnumeration: + if RttiType.Handle = TypeInfo(Boolean) then + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_BOOLEAN) + else + begin + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + Result.AddPair(SCHEMA_KEY_ENUM, CreateEnumValuesArray(RttiType)); + end; + + tkSet: + DescribeSet(RttiType, Result); + + tkDynArray: + begin + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_ARRAY); + const ElementType = TRttiDynamicArrayType(RttiType).ElementType; + const ElementSite = Format('Element of %s', [RttiType.Name]); + Result.AddPair(SCHEMA_KEY_ITEMS, ItemsSchema(ElementSite, ElementType, Depth)); + end; + + tkArray: + begin + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_ARRAY); + const ElementType = TRttiArrayType(RttiType).ElementType; + const ElementSite = Format('Element of %s', [RttiType.Name]); + Result.AddPair(SCHEMA_KEY_ITEMS, ItemsSchema(ElementSite, ElementType, Depth)); + end; + else + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_STRING); + end; + except + Result.Free; + raise; + end; +end; + +class function TMCPSchemaGenerator.NumberValue(const Value: Double): TJSONNumber; +begin + if Frac(Value) = 0 then + Result := TJSONNumber.Create(Trunc(Value)) + else + Result := TJSONNumber.Create(Value); +end; + +class procedure TMCPSchemaGenerator.ApplyAttributes(const Member: TRttiNamedObject; + const MemberSchema: TJSONObject); +begin + for var Attr in Member.GetAttributes do + begin + if Attr is SchemaDescriptionAttribute then + MemberSchema.AddPair(MCP_KEY_DESCRIPTION, SchemaDescriptionAttribute(Attr).Description) + else if Attr is SchemaTitleAttribute then + MemberSchema.AddPair(MCP_KEY_TITLE, SchemaTitleAttribute(Attr).Title) + else if Attr is SchemaFormatAttribute then + begin + MemberSchema.RemovePair(SCHEMA_KEY_FORMAT).Free; + MemberSchema.AddPair(SCHEMA_KEY_FORMAT, SchemaFormatAttribute(Attr).Format); + end + else if Attr is SchemaMinimumAttribute then + MemberSchema.AddPair('minimum', NumberValue(SchemaMinimumAttribute(Attr).Minimum)) + else if Attr is SchemaMaximumAttribute then + MemberSchema.AddPair('maximum', NumberValue(SchemaMaximumAttribute(Attr).Maximum)) + else if Attr is SchemaEnumAttribute then + begin + MemberSchema.RemovePair(SCHEMA_KEY_ENUM).Free; + var EnumArray := TJSONArray.Create; + for var Value in SchemaEnumAttribute(Attr).Values do + begin + EnumArray.Add(Value); + end; + MemberSchema.AddPair(SCHEMA_KEY_ENUM, EnumArray); + end + else if Attr is SchemaMinLengthAttribute then + MemberSchema.AddPair('minLength', TJSONNumber.Create(SchemaMinLengthAttribute(Attr).MinLength)) + else if Attr is SchemaMaxLengthAttribute then + MemberSchema.AddPair('maxLength', TJSONNumber.Create(SchemaMaxLengthAttribute(Attr).MaxLength)) + else if Attr is SchemaPatternAttribute then + MemberSchema.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', + [Member.Name, SchemaDefaultAttribute(Attr).Json]); + MemberSchema.AddPair('default', DefaultValue); + end; + end; +end; + +class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Integer; + const IsRoot: Boolean): TJSONObject; +begin + Result := TJSONObject.Create; + try + if IsRoot then + for var Attr in RttiType.GetAttributes do + if Attr is SchemaDialectAttribute then + Result.AddPair('$schema', SchemaDialectAttribute(Attr).Uri); + + Result.AddPair(MCP_KEY_TYPE, SCHEMA_TYPE_OBJECT); + const Properties = TJSONObject.Create; + Result.AddPair(SCHEMA_KEY_PROPERTIES, Properties); + const RequiredArray = TJSONArray.Create; + try + const DescribesItsFields = (RttiType.TypeKind in RECORD_KINDS); + if DescribesItsFields then + DescribeFields(RttiType, Depth, Properties, RequiredArray) + else + DescribeProperties(RttiType, Depth, Properties, RequiredArray); + except + RequiredArray.Free; + raise; + end; + + const HasRequiredArray = (RequiredArray.Count > 0); + if HasRequiredArray then + Result.AddPair(SCHEMA_KEY_REQUIRED, RequiredArray) + else + RequiredArray.Free; + + var ExplicitAdditionalProperties := False; + for var Attr in RttiType.GetAttributes do + if Attr is SchemaAdditionalPropertiesAttribute then + begin + Result.AddPair(SCHEMA_KEY_ADDITIONAL_PROPERTIES, TJSONBool.Create(SchemaAdditionalPropertiesAttribute(Attr).Allowed)); + ExplicitAdditionalProperties := True; + end; + + if not ExplicitAdditionalProperties and (Properties.Count = 0) then + Result.AddPair(SCHEMA_KEY_ADDITIONAL_PROPERTIES, TJSONBool.Create(False)); + except + Result.Free; + raise; + end; +end; + +class procedure TMCPSchemaGenerator.DescribeProperties(RttiType: TRttiType; Depth: Integer; + const Properties: TJSONObject; const RequiredArray: TJSONArray); +begin + for var RttiProp in RttiType.GetProperties do + begin + if not (RttiProp.IsReadable and RttiProp.IsWritable) then + Continue; + + GuardMemberHasType(Format('Property %s.%s', [RttiType.Name, RttiProp.Name]), + RttiProp.PropertyType); + + const JsonName = GetJsonName(RttiProp); + const PropSchema = TypeSchema(RttiProp.PropertyType, Depth); + Properties.AddPair(JsonName, PropSchema); + ApplyAttributes(RttiProp, PropSchema); + + if IsRequired(RttiProp) then + RequiredArray.Add(JsonName); + end; +end; + +class procedure TMCPSchemaGenerator.DescribeFields(RttiType: TRttiType; Depth: Integer; + const Properties: TJSONObject; const RequiredArray: TJSONArray); +begin + for var RttiField in RttiType.GetFields do + begin + if not IsSchemaField(RttiField) then + Continue; + + GuardMemberHasType(Format('Field %s.%s', [RttiType.Name, RttiField.Name]), + RttiField.FieldType); + + const JsonName = GetJsonName(RttiField); + const FieldSchema = TypeSchema(RttiField.FieldType, Depth); + Properties.AddPair(JsonName, FieldSchema); + ApplyAttributes(RttiField, FieldSchema); + + if IsRequired(RttiField) then + RequiredArray.Add(JsonName); + end; end; -end. \ No newline at end of file +end. diff --git a/src/Protocol/MCPServer.Schema.Validator.pas b/src/Protocol/MCPServer.Schema.Validator.pas new file mode 100644 index 0000000..f79013d --- /dev/null +++ b/src/Protocol/MCPServer.Schema.Validator.pas @@ -0,0 +1,408 @@ +unit MCPServer.Schema.Validator; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON; + +type + TMCPSchemaValidator = class + public + const MAX_DEPTH = 32; + + class function TryValidate(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 TryResolveRef(const RootSchema: TJSONObject; const Ref: string; + out Resolved: TJSONObject): Boolean; + class function MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; + class function ValidateConstAndEnum(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Errors: TStrings): Boolean; + class function ValidateString(const Schema: TJSONObject; const Text: string; + const Path: string; Errors: TStrings): Boolean; + class function ValidateNumber(const Schema: TJSONObject; const Value: Double; + const Path: string; Errors: TStrings): Boolean; + class function ValidateObject(const Schema: TJSONObject; const Instance: TJSONObject; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; + class function ValidateArray(const Schema: TJSONObject; const Instance: TJSONArray; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; + class function TryCheckType(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, + System.RegularExpressionsCore, + MCPServer.Types; + +const + SCHEMA_KEY_REQUIRED = 'required'; + SCHEMA_KEY_PROPERTIES = 'properties'; + SCHEMA_KEY_ITEMS = 'items'; + SCHEMA_KEY_ADDITIONAL_PROPERTIES = 'additionalProperties'; + + +{ 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.TryCheckType(const Schema: TJSONObject; const Instance: TJSONValue; + out ErrorMessage: string): Boolean; +begin + Result := True; + ErrorMessage := ''; + var TypeValue := Schema.GetValue(MCP_KEY_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 + begin + Result := not Assigned(A) and not Assigned(B); + Exit; + end; + if (A is TJSONNull) or (B is TJSONNull) then + begin + Result := (A is TJSONNull) and (B is TJSONNull); + Exit; + end; + if (A is TJSONBool) or (B is TJSONBool) then + begin + Result := (A is TJSONBool) and (B is TJSONBool) and (TJSONBool(A).AsBoolean = TJSONBool(B).AsBoolean); + Exit; + end; + if (A is TJSONNumber) or (B is TJSONNumber) then + begin + Result := (A is TJSONNumber) and (B is TJSONNumber) and (TJSONNumber(A).AsDouble = TJSONNumber(B).AsDouble); + Exit; + end; + if (A is TJSONString) or (B is TJSONString) then + begin + Result := (A is TJSONString) and (B is TJSONString) and (TJSONString(A).Value = TJSONString(B).Value); + Exit; + end; + Result := A.ToJSON = B.ToJSON; +end; + +class function TMCPSchemaValidator.TryResolveRef(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.ValidateConstAndEnum(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Errors: TStrings): Boolean; +begin + Result := True; + const ConstValue = Schema.GetValue('const'); + const MatchesConst = (not Assigned(ConstValue) or JsonEquals(ConstValue, Instance)); + if not MatchesConst then + begin + AddError(Errors, Path, 'does not match const'); + Result := False; + end; + + const EnumValue = Schema.GetValue('enum'); + if not (EnumValue is TJSONArray) then + Exit; + + var Found := False; + for var Item in TJSONArray(EnumValue) do + begin + if JsonEquals(Item, Instance) then + begin + Found := True; + Break; + end; + end; + if not Found then + begin + AddError(Errors, Path, 'not one of the allowed values'); + Result := False; + end; +end; + +class function TMCPSchemaValidator.ValidateString(const Schema: TJSONObject; const Text: string; + const Path: string; Errors: TStrings): Boolean; +begin + Result := True; + const MinLengthValue = Schema.GetValue('minLength'); + const IsTooShort = ((MinLengthValue is TJSONNumber) and (Length(Text) < TJSONNumber(MinLengthValue).AsInt)); + if IsTooShort then + begin + AddError(Errors, Path, 'shorter than minLength'); + Result := False; + end; + + const MaxLengthValue = Schema.GetValue('maxLength'); + const IsTooLong = ((MaxLengthValue is TJSONNumber) and (Length(Text) > TJSONNumber(MaxLengthValue).AsInt)); + if IsTooLong then + begin + AddError(Errors, Path, 'longer than maxLength'); + Result := False; + end; + + const PatternValue = Schema.GetValue('pattern'); + if not IsJsonString(PatternValue) then + Exit; + + var Matches: Boolean; + try + Matches := TRegEx.IsMatch(Text, TJSONString(PatternValue).Value); + except + on E: ERegularExpressionError do + begin + AddError(Errors, Path, 'has an unusable pattern'); + Exit(False); + end; + end; + if not Matches then + begin + AddError(Errors, Path, 'does not match pattern'); + Result := False; + end; +end; + +class function TMCPSchemaValidator.ValidateNumber(const Schema: TJSONObject; const Value: Double; + const Path: string; Errors: TStrings): Boolean; +begin + Result := True; + const MinimumValue = Schema.GetValue('minimum'); + const IsBelowMinimum = ((MinimumValue is TJSONNumber) and (Value < TJSONNumber(MinimumValue).AsDouble)); + if IsBelowMinimum then + begin + AddError(Errors, Path, 'less than minimum'); + Result := False; + end; + + const MaximumValue = Schema.GetValue('maximum'); + const IsAboveMaximum = ((MaximumValue is TJSONNumber) and (Value > TJSONNumber(MaximumValue).AsDouble)); + if IsAboveMaximum then + begin + AddError(Errors, Path, 'greater than maximum'); + Result := False; + end; +end; + +class function TMCPSchemaValidator.ValidateObject(const Schema: TJSONObject; const Instance: TJSONObject; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; +begin + Result := True; + const RequiredValue = Schema.GetValue(SCHEMA_KEY_REQUIRED); + if RequiredValue is TJSONArray then + begin + for var Item in TJSONArray(RequiredValue) do + begin + const IsMissing = (IsJsonString(Item) and not Assigned(Instance.GetValue(TJSONString(Item).Value))); + if IsMissing then + begin + AddError(Errors, Path, Format('missing required property "%s"', [TJSONString(Item).Value])); + Result := False; + end; + end; + end; + + var PropertySchemas: TJSONObject := nil; + const PropertiesValue = Schema.GetValue(SCHEMA_KEY_PROPERTIES); + if PropertiesValue is TJSONObject then + PropertySchemas := TJSONObject(PropertiesValue); + + if Assigned(PropertySchemas) then + begin + for var Pair in Instance do + begin + const PropertySchema = PropertySchemas.GetValue(Pair.JsonString.Value); + if not (PropertySchema is TJSONObject) then + Continue; + const MemberPath = Format('%s.%s', [Path, Pair.JsonString.Value]); + if not ValidateNode(TJSONObject(PropertySchema), Pair.JsonValue, MemberPath, Depth + 1, RootSchema, Errors) then + Result := False; + end; + end; + + const AdditionalValue = Schema.GetValue(SCHEMA_KEY_ADDITIONAL_PROPERTIES); + const ForbidsExtras = ((AdditionalValue is TJSONBool) and not TJSONBool(AdditionalValue).AsBoolean); + if not ForbidsExtras then + Exit; + + for var Pair in Instance do + begin + const IsKnown = (Assigned(PropertySchemas) and Assigned(PropertySchemas.GetValue(Pair.JsonString.Value))); + if not IsKnown then + begin + AddError(Errors, Path, Format('unexpected property "%s"', [Pair.JsonString.Value])); + Result := False; + end; + end; +end; + +class function TMCPSchemaValidator.ValidateArray(const Schema: TJSONObject; const Instance: TJSONArray; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; +begin + Result := True; + const ItemsValue = Schema.GetValue(SCHEMA_KEY_ITEMS); + if not (ItemsValue is TJSONObject) then + Exit; + + for var Index := 0 to Instance.Count - 1 do + begin + const ItemPath = Format('%s[%d]', [Path, Index]); + if not ValidateNode(TJSONObject(ItemsValue), Instance.Items[Index], ItemPath, Depth + 1, RootSchema, Errors) then + Result := False; + end; +end; + +class function TMCPSchemaValidator.ValidateNode(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; +begin + if Depth > MAX_DEPTH then + begin + AddError(Errors, Path, 'schema nested too deeply'); + Exit(False); + end; + + var ResolvedSchema := Schema; + const RefValue = Schema.GetValue('$ref'); + if IsJsonString(RefValue) then + begin + if not TryResolveRef(RootSchema, TJSONString(RefValue).Value, ResolvedSchema) then + begin + AddError(Errors, Path, Format('unsupported $ref "%s"', [TJSONString(RefValue).Value])); + Exit(False); + end; + end; + + Result := ValidateConstAndEnum(ResolvedSchema, Instance, Path, Errors); + + var TypeError: string; + if not TryCheckType(ResolvedSchema, Instance, TypeError) then + begin + AddError(Errors, Path, TypeError); + Exit(False); + end; + + if IsJsonString(Instance) then + begin + if not ValidateString(ResolvedSchema, TJSONString(Instance).Value, Path, Errors) then + Result := False; + end + else if Instance is TJSONNumber then + begin + if not ValidateNumber(ResolvedSchema, TJSONNumber(Instance).AsDouble, Path, Errors) then + Result := False; + end + else if Instance is TJSONObject then + begin + if not ValidateObject(ResolvedSchema, TJSONObject(Instance), Path, Depth, RootSchema, Errors) then + Result := False; + end + else if Instance is TJSONArray then + begin + if not ValidateArray(ResolvedSchema, TJSONArray(Instance), Path, Depth, RootSchema, Errors) then + Result := False; + end; +end; + +class function TMCPSchemaValidator.TryValidate(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..8c6dda1 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -18,35 +18,75 @@ 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 ConvertJsonToInteger(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; + class function ConvertJsonToFloat(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; + class function ConvertJsonToClass(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; + class function ConvertJsonToRecord(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; + class function ConvertJsonToGuid(const JsonValue: TJSONValue): TValue; + class procedure FillRecordFields(const Json: TJSONObject; const RttiType: TRttiType; + const Data: Pointer); + class procedure FreeRecordObjects(const Value: TValue; const RttiType: TRttiType); 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 ConvertRecordToJson(const Value: TValue; const RttiType: TRttiType): TJSONValue; + class function ConvertGuidToJson(const Value: TValue): TJSONValue; + class function TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; class function CreateInstanceFromType(const RttiType: TRttiType): TObject; + class function IsGuid(const RttiType: TRttiType): Boolean; + class function IsWireField(const RttiField: TRttiField): Boolean; + class function HasWireFields(const RttiType: TRttiType): Boolean; + class procedure GuardKnownKeys(const Json: TJSONObject; const KnownNorms: TStringList); + class procedure GuardRecordKeys(const Json: TJSONObject; const RttiType: TRttiType); + class procedure GuardFieldHasType(const RttiType: TRttiType; const RttiField: TRttiField); - // 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 IsRequiredMember(const Member: TRttiNamedObject): Boolean; + + class procedure CollectCreatedObjects(const Value: TValue; const RttiType: TRttiType; + const Owned: TList); + class procedure CollectFromArray(const Value: TValue; const ElementType: TRttiType; + const Owned: TList); + class procedure CollectFromRecord(const Value: TValue; const RttiType: TRttiType; + const Owned: TList); public class constructor Create; class destructor Destroy; + class function GetWireName(const Member: TRttiNamedObject): string; + class function Deserialize(const Json: TJSONObject): T; class procedure Serialize(Obj: TObject; Json: TJSONObject); + class function JsonToValue(const JsonValue: TJSONValue; const RttiType: TRttiType; + const Owned: TList): TValue; + class function ValueToJson(const Value: TValue; const RttiType: TRttiType): TJSONValue; + class function SerializeToString(Obj: TObject): string; end; implementation +uses + System.Math, + System.DateUtils, + MCPServer.Types; + +const + MESSAGE_EXPECTED_INTEGER = 'expected an integer'; + MESSAGE_EXPECTED_OBJECT = 'expected an object'; + MESSAGE_EXPECTED_UUID = 'expected a UUID string'; + + OWNERSHIP_BEARING_KINDS = [tkClass, tkDynArray, tkRecord, tkMRecord]; + + { TMCPSerializer } class constructor TMCPSerializer.Create; @@ -93,9 +133,7 @@ class function TMCPSerializer.GetJsonValueCaseInsensitive(const Json: TJSONObjec class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: TJSONObject); var JsonValue: TJSONValue; - KeyName: string; KnownNorms: TStringList; - Pair: TJSONPair; PropValue: TValue; RttiProp: TRttiProperty; RttiType: TRttiType; @@ -106,16 +144,9 @@ 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 - KeyName := Pair.JsonString.Value; - if KnownNorms.IndexOf(NormalizeKey(KeyName)) < 0 then - raise EArgumentException.CreateFmt( - 'Unknown parameter "%s". Valid parameters: %s.', - [KeyName, String.Join(', ', KnownNorms.ToStringArray)]); - end; + GuardKnownKeys(Json, KnownNorms); finally KnownNorms.Free; end; @@ -125,16 +156,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 IsRequiredMember(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 +181,77 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: end; end; +class function TMCPSerializer.IsRequiredMember(const Member: TRttiNamedObject): Boolean; +begin + for var Attr in Member.GetAttributes do + if Attr is OptionalAttribute then + Exit(False); + Result := True; +end; + +class function TMCPSerializer.GetWireName(const Member: TRttiNamedObject): string; +begin + for var Attr in Member.GetAttributes do + if Attr is SchemaNameAttribute then + begin + Result := SchemaNameAttribute(Attr).Name; + Exit; + end; + Result := LowerCase(Member.Name); +end; + +class function TMCPSerializer.IsGuid(const RttiType: TRttiType): Boolean; +begin + Result := (RttiType.Handle = TypeInfo(TGUID)); +end; + +class function TMCPSerializer.IsWireField(const RttiField: TRttiField): Boolean; +begin + Result := (RttiField.Visibility in SCHEMA_FIELD_VISIBILITIES); +end; + +class function TMCPSerializer.HasWireFields(const RttiType: TRttiType): Boolean; +begin + for var RttiField in RttiType.GetFields do + if IsWireField(RttiField) then + Exit(True); + Result := False; +end; + +class procedure TMCPSerializer.GuardKnownKeys(const Json: TJSONObject; const KnownNorms: TStringList); +begin + for var Pair in Json do + begin + const KeyName = Pair.JsonString.Value; + if KnownNorms.IndexOf(NormalizeKey(KeyName)) < 0 then + raise EArgumentException.CreateFmt( + 'Unknown parameter "%s". Valid parameters: %s.', + [KeyName, String.Join(', ', KnownNorms.ToStringArray)]); + end; +end; + +class procedure TMCPSerializer.GuardRecordKeys(const Json: TJSONObject; const RttiType: TRttiType); +begin + const KnownNorms = TStringList.Create; + try + for var RttiField in RttiType.GetFields do + if IsWireField(RttiField) then + KnownNorms.Add(NormalizeKey(GetWireName(RttiField))); + + GuardKnownKeys(Json, KnownNorms); + finally + KnownNorms.Free; + end; +end; + +class procedure TMCPSerializer.GuardFieldHasType(const RttiType: TRttiType; + const RttiField: TRttiField); +begin + if not Assigned(RttiField.FieldType) then + raise EArgumentException.CreateFmt('Field %s.%s has no type RTTI, so it has no JSON value', + [RttiType.Name, RttiField.Name]); +end; + class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); var JsonValue: TJSONValue; @@ -161,18 +267,85 @@ 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; end; +class procedure TMCPSerializer.CollectCreatedObjects(const Value: TValue; const RttiType: TRttiType; + const Owned: TList); +begin + if not Assigned(Owned) or not Assigned(RttiType) or Value.IsEmpty then + Exit; + + case RttiType.TypeKind of + tkClass: + if Value.IsObject and (Value.AsObject <> nil) then + Owned.Add(Value.AsObject); + + tkDynArray: + CollectFromArray(Value, TRttiDynamicArrayType(RttiType).ElementType, Owned); + + tkRecord, tkMRecord: + CollectFromRecord(Value, RttiType, Owned); + end; +end; + +class procedure TMCPSerializer.CollectFromArray(const Value: TValue; const ElementType: TRttiType; + const Owned: TList); +begin + const CarriesOwnership = Assigned(ElementType) and (ElementType.TypeKind in OWNERSHIP_BEARING_KINDS); + if not CarriesOwnership then + Exit; + + for var Index := 0 to Value.GetArrayLength - 1 do + begin + CollectCreatedObjects(Value.GetArrayElement(Index), ElementType, Owned); + end; +end; + +class procedure TMCPSerializer.CollectFromRecord(const Value: TValue; const RttiType: TRttiType; + const Owned: TList); +begin + if IsGuid(RttiType) then + Exit; + + const Data = Value.GetReferenceToRawData; + for var RttiField in RttiType.GetFields do + begin + const HoldsAValue = (IsWireField(RttiField) and Assigned(RttiField.FieldType)); + if HoldsAValue then + CollectCreatedObjects(RttiField.GetValue(Data), RttiField.FieldType, Owned); + end; +end; + +class function TMCPSerializer.JsonToValue(const JsonValue: TJSONValue; const RttiType: TRttiType; + const Owned: TList): TValue; +begin + Result := TValue.Empty; + if not Assigned(RttiType) then + Exit; + + Result := ConvertJsonToValue(JsonValue, RttiType); + CollectCreatedObjects(Result, RttiType, Owned); +end; + +class function TMCPSerializer.ValueToJson(const Value: TValue; const RttiType: TRttiType): TJSONValue; +begin + Result := nil; + if not Assigned(RttiType) then + Exit; + + Result := ConvertValueToJson(Value, RttiType); +end; + class function TMCPSerializer.SerializeToString(Obj: TObject): string; var Json: TJSONObject; @@ -186,75 +359,206 @@ class function TMCPSerializer.SerializeToString(Obj: TObject): string; end; end; +class function TMCPSerializer.ConvertJsonToInteger(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; +begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create(MESSAGE_EXPECTED_INTEGER); + + const Number = TJSONNumber(JsonValue); + const IsWhole = (Frac(Number.AsDouble) = 0); + if not IsWhole then + raise EArgumentException.Create(MESSAGE_EXPECTED_INTEGER); + + if RttiType.TypeKind = tkInt64 then + Exit(Number.AsInt64); + + const Ordinal = TRttiOrdinalType(RttiType); + const InRange = ((Number.AsInt64 >= Ordinal.MinValue) and (Number.AsInt64 <= Ordinal.MaxValue)); + if not InRange then + raise EArgumentException.CreateFmt('%d is outside the range of %s', [Number.AsInt64, RttiType.Name]); + Result := TValue.FromOrdinal(RttiType.Handle, Number.AsInt64); +end; + +class function TMCPSerializer.ConvertJsonToFloat(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; +begin + const IsDateTime = (RttiType.Handle = TypeInfo(TDateTime)); + if not IsDateTime then + begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected a number'); + begin + Result := TJSONNumber(JsonValue).AsDouble; + Exit; + end; + end; + + if not IsJsonString(JsonValue) then + raise EArgumentException.Create('expected a date-time string'); + try + Result := TValue.From(ISO8601ToDate(JsonValue.Value, False)); + except + on E: EConvertError do + raise EArgumentException.Create('expected an ISO 8601 date-time'); + on E: EDateTimeException do + raise EArgumentException.Create('expected an ISO 8601 date-time'); + end; +end; + +class function TMCPSerializer.ConvertJsonToClass(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; +begin + Result := TValue.Empty; + if JsonValue is TJSONArray then + begin + Result := DeserializeArray(RttiType, TJSONArray(JsonValue)); + Exit; + end; + if not (JsonValue is TJSONObject) then + raise EArgumentException.Create(MESSAGE_EXPECTED_OBJECT); + + const NestedInstance = CreateInstanceFromType(RttiType); + if not Assigned(NestedInstance) then + Exit; + + try + DeserializeObject(NestedInstance, TJSONObject(JsonValue)); + except + NestedInstance.Free; + raise; + end; + Result := NestedInstance; +end; + class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; -var - 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: + Result := ConvertJsonToInteger(JsonValue, RttiType); - 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 - else -{$IF COMPILERVERSION <= 28} - Result := StrToFloatDef(JsonValue.Value, 0, TFormatSettings.Create('en-US')); -{$ELSE} - Result := StrToFloatDef(JsonValue.Value, 0, FormatSettings.Invariant); -{$ENDIF} + Result := ConvertJsonToFloat(JsonValue, RttiType); tkString, tkLString, tkWString, tkUString: - Result := JsonValue.Value; - + begin + if not IsJsonString(JsonValue) 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 - begin - NestedInstance := CreateInstanceFromType(RttiType); - if Assigned(NestedInstance) then - begin - DeserializeObject(NestedInstance, JsonValue as TJSONObject); - Result := NestedInstance; - end; - end - else if JsonValue is TJSONArray then - Result := DeserializeArray(RttiType, JsonValue as TJSONArray); - + Result := ConvertJsonToClass(JsonValue, RttiType); + + tkRecord, tkMRecord: + Result := ConvertJsonToRecord(JsonValue, RttiType); + tkDynArray: - if JsonValue is TJSONArray then - Result := DeserializeArray(RttiType, JsonValue as TJSONArray); + begin + if not (JsonValue is TJSONArray) then + raise EArgumentException.Create('expected an array'); + Result := DeserializeArray(RttiType, TJSONArray(JsonValue)); + end; + else + Result := TValue.Empty; + end; +end; + +class function TMCPSerializer.ConvertJsonToRecord(const JsonValue: TJSONValue; + const RttiType: TRttiType): TValue; +begin + if IsGuid(RttiType) then + Exit(ConvertJsonToGuid(JsonValue)); + + if not HasWireFields(RttiType) then + Exit(TValue.Empty); + + if not (JsonValue is TJSONObject) then + raise EArgumentException.Create(MESSAGE_EXPECTED_OBJECT); + + const Json = TJSONObject(JsonValue); + GuardRecordKeys(Json, RttiType); + + TValue.Make(nil, RttiType.Handle, Result); + try + FillRecordFields(Json, RttiType, Result.GetReferenceToRawData); + except + FreeRecordObjects(Result, RttiType); + raise; + end; +end; + +class function TMCPSerializer.ConvertJsonToGuid(const JsonValue: TJSONValue): TValue; +begin + if not IsJsonString(JsonValue) then + raise EArgumentException.Create(MESSAGE_EXPECTED_UUID); + + const Text = JsonValue.Value.Trim; + const IsBraced = Text.StartsWith('{'); + var Braced := Text; + if not IsBraced then + Braced := Format('{%s}', [Text]); + + try + Result := TValue.From(StringToGUID(Braced)); + except + on E: EConvertError do + raise EArgumentException.Create(MESSAGE_EXPECTED_UUID); + end; +end; + +class procedure TMCPSerializer.FillRecordFields(const Json: TJSONObject; const RttiType: TRttiType; + const Data: Pointer); +begin + for var RttiField in RttiType.GetFields do + begin + if not IsWireField(RttiField) then + Continue; + + GuardFieldHasType(RttiType, RttiField); + + const WireName = GetWireName(RttiField); + const Member = GetJsonValueCaseInsensitive(Json, WireName); + + const IsAbsent = (not Assigned(Member) or (Member is TJSONNull)); + if IsAbsent then + begin + if IsRequiredMember(RttiField) then + raise EArgumentException.CreateFmt('Missing required parameter "%s"', [WireName]); + Continue; + end; + + var FieldValue: TValue; + try + FieldValue := ConvertJsonToValue(Member, RttiField.FieldType); + except + on E: EArgumentException do + raise EArgumentException.CreateFmt('Parameter "%s": %s', [WireName, E.Message]); + end; + + if not FieldValue.IsEmpty then + RttiField.SetValue(Data, FieldValue); + end; +end; + +class procedure TMCPSerializer.FreeRecordObjects(const Value: TValue; const RttiType: TRttiType); +begin + const Held = TObjectList.Create(True); + try + CollectFromRecord(Value, RttiType, Held); + finally + Held.Free; end; end; @@ -298,7 +602,9 @@ class function TMCPSerializer.GetEnumValueNames(const EnumType: TRttiEnumeration SetLength(Names, EnumType.MaxValue - EnumType.MinValue + 1); for Ordinal := EnumType.MinValue to EnumType.MaxValue do + begin Names[Ordinal - EnumType.MinValue] := GetEnumName(EnumType.Handle, Ordinal); + end; Result := String.Join(', ', Names); end; @@ -309,12 +615,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 +632,70 @@ 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} + const Names = TJSONArray.Create; + const ElementType = TRttiEnumerationType(TRttiSetType(RttiType).ElementType); + const Bytes = PByte(Value.GetReferenceToRawData); + const FirstBit = ElementType.MinValue and not 7; + for var Ordinal := ElementType.MinValue to ElementType.MaxValue do + begin + const BitIndex = Ordinal - FirstBit; + const ByteIndex = BitIndex div 8; + const IsMember = ((ByteIndex < Value.DataSize) and ((Bytes[ByteIndex] and (1 shl (BitIndex mod 8))) <> 0)); + if IsMember then + Names.Add(GetEnumName(ElementType.Handle, Ordinal)); + end; + 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 +707,110 @@ 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; + + tkRecord, tkMRecord: + Result := ConvertRecordToJson(Value, RttiType); + end; +end; + +class function TMCPSerializer.ConvertRecordToJson(const Value: TValue; + const RttiType: TRttiType): TJSONValue; +begin + if IsGuid(RttiType) then + Exit(ConvertGuidToJson(Value)); + + if not HasWireFields(RttiType) then + Exit(nil); + + const Json = TJSONObject.Create; + try + const Data = Value.GetReferenceToRawData; + for var RttiField in RttiType.GetFields do + begin + if not IsWireField(RttiField) then + Continue; + + GuardFieldHasType(RttiType, RttiField); + + const Member = ConvertValueToJson(RttiField.GetValue(Data), RttiField.FieldType); + if Assigned(Member) then + Json.AddPair(GetWireName(RttiField), Member); + end; + except + Json.Free; + raise; end; + + Result := Json; +end; + +class function TMCPSerializer.ConvertGuidToJson(const Value: TValue): TJSONValue; +begin + const Braced = GUIDToString(Value.AsType); + const Bare = Braced.Trim(['{', '}']); + Result := TJSONString.Create(LowerCase(Bare)); +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 +829,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 +850,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 +877,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..91dc69a 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -5,12 +5,154 @@ interface uses System.SysUtils, System.JSON, - System.Rtti; + System.Rtti, + System.TypInfo, + 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_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_METHOD_INITIALIZE = 'initialize'; + MCP_METHOD_NOTIFICATIONS_INITIALIZED = 'notifications/initialized'; + MCP_METHOD_PING = 'ping'; + MCP_METHOD_SERVER_DISCOVER = 'server/discover'; + MCP_METHOD_LOGGING_SET_LEVEL = 'logging/setLevel'; + MCP_METHOD_TOOLS_LIST = 'tools/list'; + MCP_METHOD_TOOLS_CALL = 'tools/call'; + MCP_METHOD_PROMPTS_LIST = 'prompts/list'; + MCP_METHOD_PROMPTS_GET = 'prompts/get'; + MCP_METHOD_RESOURCES_LIST = 'resources/list'; + MCP_METHOD_RESOURCES_READ = 'resources/read'; + MCP_METHOD_RESOURCES_TEMPLATES_LIST = 'resources/templates/list'; + MCP_METHOD_RESOURCES_SUBSCRIBE = 'resources/subscribe'; + MCP_METHOD_RESOURCES_UNSUBSCRIBE = 'resources/unsubscribe'; + MCP_METHOD_COMPLETION_COMPLETE = 'completion/complete'; + + JSONRPC_VERSION = '2.0'; + MEDIA_TYPE_JSON = 'application/json'; + MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; + CHARSET_UTF8 = 'utf-8'; + + MCP_HEADER_SESSION_ID = 'Mcp-Session-Id'; + MCP_HEADER_PROTOCOL_VERSION = 'MCP-Protocol-Version'; + MCP_HEADER_METHOD = 'Mcp-Method'; + MCP_HEADER_NAME = 'Mcp-Name'; + + MCP_KEY_JSONRPC = 'jsonrpc'; + MCP_KEY_ID = 'id'; + MCP_KEY_METHOD = 'method'; + MCP_KEY_PARAMS = 'params'; + MCP_KEY_RESULT = 'result'; + MCP_KEY_ERROR = 'error'; + MCP_KEY_META = '_meta'; + MCP_KEY_INPUT_RESPONSES = 'inputResponses'; + MCP_KEY_REQUEST_STATE = 'requestState'; + MCP_KEY_RESULT_TYPE = 'resultType'; + MCP_KEY_TTL_MS = 'ttlMs'; + MCP_KEY_CACHE_SCOPE = 'cacheScope'; + MCP_KEY_NAME = 'name'; + MCP_KEY_TITLE = 'title'; + MCP_KEY_DESCRIPTION = 'description'; + MCP_KEY_URI = 'uri'; + MCP_KEY_MIME_TYPE = 'mimeType'; + MCP_KEY_TYPE = 'type'; + MCP_KEY_TEXT = 'text'; + MCP_KEY_CONTENT = 'content'; + MCP_KEY_CURSOR = 'cursor'; + MCP_KEY_ARGUMENTS = 'arguments'; + MCP_KEY_ANNOTATIONS = 'annotations'; + MCP_ANNOTATION_READ_ONLY_HINT = 'readOnlyHint'; + MCP_ANNOTATION_OPEN_WORLD_HINT = 'openWorldHint'; + MCP_KEY_ICONS = 'icons'; + MCP_KEY_CAPABILITIES = 'capabilities'; + MCP_KEY_PROTOCOL_VERSION = 'protocolVersion'; + MCP_KEY_INSTRUCTIONS = 'instructions'; + MCP_KEY_VERSION = 'version'; + MCP_KEY_LIST_CHANGED = 'listChanged'; + MCP_KEY_SUBSCRIBE = 'subscribe'; + + MCP_CACHEABLE_METHODS: array[0..5] of string = ( + MCP_METHOD_SERVER_DISCOVER, + MCP_METHOD_TOOLS_LIST, + MCP_METHOD_PROMPTS_LIST, + MCP_METHOD_RESOURCES_LIST, + MCP_METHOD_RESOURCES_TEMPLATES_LIST, + MCP_METHOD_RESOURCES_READ + ); + MCP_LOG_LEVELS: array[0..7] of string = ( + 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); + + SCHEMA_FIELD_VISIBILITIES = [mvPublic, mvPublished]; + type + TMCPProtocolVersion = record + class function IsLegacy(const Version: string): Boolean; static; + class function IsModern(const Version: string): Boolean; static; + class function NegotiateLegacy(const Requested: string): string; static; + end; + + TMCPLogLevel = record + class function Rank(const Level: string): Integer; static; + class function IsKnown(const Level: string): Boolean; static; + end; + + TMCPStrings = record + class function Contains(const Value: string; const Values: array of string): Boolean; static; + end; + + TMCPConstantTime = record + class function SameBytes(const A, B: TBytes): Boolean; static; + end; + OptionalAttribute = class(TCustomAttribute) end; @@ -22,6 +164,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 +208,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 +517,191 @@ 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 TMCPStrings.Contains(const Value: string; const Values: array of string): Boolean; +begin + for var Item in Values do + begin + if Item = Value then + Exit(True); + end; + Result := False; +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; + +class function TMCPProtocolVersion.IsLegacy(const Version: string): Boolean; +begin + for var Known in MCP_LEGACY_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +class function TMCPProtocolVersion.IsModern(const Version: string): Boolean; +begin + for var Known in MCP_MODERN_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +class function TMCPProtocolVersion.NegotiateLegacy(const Requested: string): string; +begin + if TMCPProtocolVersion.IsLegacy(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 +710,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); @@ -129,7 +751,9 @@ constructor SchemaEnumAttribute.Create(const AValues: array of string); inherited Create; SetLength(FValues, Length(AValues)); for I := 0 to High(AValues) do + begin FValues[I] := AValues[I]; + end; end; constructor SchemaEnumAttribute.Create(const AValue1: string); @@ -166,6 +790,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..aa85e72 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,58 @@ 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; + + TMCPCompiledTemplate = record + Pattern: string; + VariableNames: TArray; + 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): TMCPCompiledTemplate; 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 +128,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 +159,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 +229,158 @@ 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): TMCPCompiledTemplate; +var + Names: TList; + Position: Integer; + CloseBrace: Integer; + Expr, VarName, LiteralRun: string; +begin + Names := TList.Create; + try + Result.Pattern := ''; + 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.Pattern := Result.Pattern + Format('(?<%s>.+)', [VarName]); + end + else + begin + VarName := Expr; + Result.Pattern := Result.Pattern + Format('(?<%s>[^/]+)', [VarName]); + end; + const VarNameIsEmpty = (VarName = ''); + if VarNameIsEmpty 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]); + + if Names.IndexOf(VarName) >= 0 then + raise EArgumentException.CreateFmt('URI template %s uses the variable %s more than once', + [UriTemplate, VarName]); + Names.Add(VarName); + Position := CloseBrace + 1; + end + else + begin + var LiteralStart := Position; + while (Position <= Length(UriTemplate)) and (UriTemplate[Position] <> '{') do + begin + Inc(Position); + end; + LiteralRun := Copy(UriTemplate, LiteralStart, Position - LiteralStart); + Result.Pattern := Result.Pattern + TRegEx.Escape(LiteralRun); + end; + end; + Result.Pattern := Format('^%s$', [Result.Pattern]); + Result.VariableNames := Names.ToArray; + finally + Names.Free; + end; +end; + +procedure TMCPResourceTemplateBase.EnsureCompiled; +begin + FCompileLock.Enter; + try + if not FCompiled then + begin + const Compiled = CompilePattern(FUriTemplate); + FPattern := Compiled.Pattern; + FVariableNames := Compiled.VariableNames; + 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 + begin + Vars.AddOrSetValue(VarName, PercentDecode(Match.Groups[VarName].Value)); + end; +end; + +end. diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index cb5f02f..0a4c715 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,15 @@ implementation System.Math, MCPServer.Registration; +const + MIME_TYPE_JSON = 'application/json'; + LEVEL_INFO = 'INFO'; + CATEGORY_SYSTEM = 'SYSTEM'; + URI_RECENT = 'logs://recent'; + URI_TEMPLATE_BY_LEVEL = 'logs://{level}'; + TEMPLATE_VARIABLE_LEVEL = 'level'; + MAX_RECENT_LOG_ENTRIES = 100; + { TLogEntries } constructor TLogEntries.Create; @@ -102,7 +128,9 @@ destructor TLogBuffer.Destroy; Entry: TLogEntry; begin for Entry in FLogs do + begin Entry.Free; + end; FLogs.Free; inherited; end; @@ -143,10 +171,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 +191,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]; @@ -193,50 +220,136 @@ function TLogBuffer.GetLogs(AMaxCount: NativeInt; const ALevel: string): TObject constructor TLogsRecentResource.Create; begin inherited; - FURI := 'logs://recent'; + FURI := URI_RECENT; FName := 'Recent Logs'; FDescription := 'Recent log entries from all categories'; - FMimeType := 'application/json'; + FMimeType := MIME_TYPE_JSON; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; end; function TLogsRecentResource.GetResourceData: TLogEntries; -var - Logs: TObjectList; begin - Result := TLogEntries.Create; - - // Add access log entry - TLogBuffer.Instance.AddLog('INFO', 'Resource accessed: logs://recent', 'ACCESS'); - - Logs := TLogBuffer.Instance.GetLogs(100); + const Logs = TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES); + try + const Entries = TLogEntries.Create; + try + Entries.Entries.AddRange(Logs); + Entries.TotalCount := Logs.Count; + Entries.FilteredCount := Logs.Count; + Logs.OwnsObjects := False; + except + Entries.Entries.OwnsObjects := False; + Entries.Free; + raise; + end; + Result := Entries; + 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 := MIME_TYPE_JSON; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; +end; + +function TLogsByLevelResource.GetResourceData: TLogEntries; +begin + const Logs = TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES, FLevel); try - Result.Entries.AddRange(Logs.ToArray); - Result.TotalCount := Logs.Count; - Result.FilteredCount := Logs.Count; + const Entries = TLogEntries.Create; + try + Entries.Entries.AddRange(Logs); + Entries.TotalCount := Logs.Count; + Entries.FilteredCount := Logs.Count; + Logs.OwnsObjects := False; + except + Entries.Entries.OwnsObjects := False; + Entries.Free; + raise; + end; + Result := Entries; finally Logs.Free; end; end; +{ TLogsByLevelTemplate } + +constructor TLogsByLevelTemplate.Create; +begin + inherited; + FUriTemplate := URI_TEMPLATE_BY_LEVEL; + FName := 'Recent logs by level'; + FDescription := 'Recent log entries at the given level, e.g. logs://INFO'; + FMimeType := MIME_TYPE_JSON; +end; + +function TLogsByLevelTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TLogsByLevelResource.CreateForLevel(URI, Vars[TEMPLATE_VARIABLE_LEVEL]); +end; + +function TLogsByLevelTemplate.Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; +begin + if ArgumentName <> TEMPLATE_VARIABLE_LEVEL then + begin + Result := TMCPCompletion.Create(nil); + Exit; + end; + + 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(LEVEL_INFO, 'MCP Server started', CATEGORY_SYSTEM); + TLogBuffer.Instance.AddLog(LEVEL_INFO, 'Resources manager initialized', CATEGORY_SYSTEM); + TLogBuffer.Instance.AddLog(LEVEL_INFO, 'Tools manager initialized', CATEGORY_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', + TLogBuffer.Instance.AddLog(LEVEL_INFO, 'Server listening on port 8080', 'SERVER'); + + TMCPRegistry.RegisterResource(URI_RECENT, function: IMCPResource begin Result := TLogsRecentResource.Create; end ); - + + TMCPRegistry.RegisterResourceTemplate(URI_TEMPLATE_BY_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..daa8f87 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,18 @@ TProjectReadmeResource = class(TMCPResourceBase) constructor Create; override; end; - implementation uses MCPServer.Registration; +const + FENCE = '```'; + FENCE_BASH = '```bash'; + URI_INFO = 'project://info'; + URI_README = 'project://readme'; + PROJECT_RESOURCE_TTL_MS = 3600000; + { TProjectInfo } constructor TProjectInfo.Create; @@ -84,10 +90,12 @@ destructor TProjectInfo.Destroy; constructor TProjectInfoResource.Create; begin inherited; - FURI := 'project://info'; + FURI := URI_INFO; 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 +106,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'; @@ -113,10 +122,12 @@ function TProjectInfoResource.GetResourceData: TProjectInfo; constructor TProjectReadmeResource.Create; begin inherited; - FURI := 'project://readme'; + FURI := URI_README; 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; @@ -135,37 +146,36 @@ function TProjectReadmeResource.GetResourceData: TTextContent; '- CORS support for cross-origin requests' + sLineBreak + '' + sLineBreak + '## Building' + sLineBreak + -'```bash' + sLineBreak + +FENCE_BASH + sLineBreak + 'build.bat' + sLineBreak + -'```' + sLineBreak + +FENCE + sLineBreak + '' + sLineBreak + '## Running' + sLineBreak + -'```bash' + sLineBreak + +FENCE_BASH + sLineBreak + 'Win32\Debug\MCPServer.exe' + sLineBreak + -'```' + sLineBreak + +FENCE + sLineBreak + '' + sLineBreak + '## Testing' + sLineBreak + -'```bash' + sLineBreak + +FENCE_BASH + sLineBreak + 'npx @wong2/mcp-cli --url http://localhost:8080/mcp' + sLineBreak + -'```' + sLineBreak + +FENCE + sLineBreak + ''''; end; - initialization - TMCPRegistry.RegisterResource('project://info', + TMCPRegistry.RegisterResource(URI_INFO, function: IMCPResource begin Result := TProjectInfoResource.Create; end ); - - TMCPRegistry.RegisterResource('project://readme', + + TMCPRegistry.RegisterResource(URI_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..377941c --- /dev/null +++ b/src/Resources/MCPServer.Resource.Samples.pas @@ -0,0 +1,171 @@ +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 + MIME_TYPE_JSON = 'application/json'; + URI_STATIC_BINARY = 'test://static-binary'; + TEMPLATE_DATA_TITLE = 'Template data'; + URI_TEMPLATE_DATA = 'test://template/{id}/data'; + 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 := URI_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_TITLE; + FDescription := 'Data keyed by the id captured from the template'; + FMimeType := MIME_TYPE_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 := URI_TEMPLATE_DATA; + FName := TEMPLATE_DATA_TITLE; + FDescription := 'Data keyed by an id path segment'; + FMimeType := MIME_TYPE_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(URI_STATIC_BINARY, + function: IMCPResource + begin + Result := TStaticBinaryResource.Create; + end); + TMCPRegistry.RegisterResourceTemplate(URI_TEMPLATE_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..230606f 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,24 @@ 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 + const PreviousUri = StatusURI; FNamePrefix := Prefix; RegisterServerStatusResource; + const UriChanged = (PreviousUri <> StatusURI); + if UriChanged then + TMCPRegistry.UnregisterResource(PreviousUri); 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 +94,32 @@ 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); + const IsCurrent = (Previous = Current); + if IsCurrent 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 +135,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 +145,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.Host.pas b/src/Server/MCPServer.Host.pas new file mode 100644 index 0000000..e7785af --- /dev/null +++ b/src/Server/MCPServer.Host.pas @@ -0,0 +1,277 @@ +unit MCPServer.Host; + +interface + +uses + System.Classes, + MCPServer.Types, + MCPServer.Settings, + MCPServer.Authorization, + MCPServer.Tool.Base, + MCPServer.Resource.Base, + MCPServer.Prompt.Base, + MCPServer.ToolsManager, + MCPServer.ResourcesManager, + MCPServer.PromptsManager, + MCPServer.SubscriptionsManager, + MCPServer.IdHTTPServer; + +type + TMCPServerHost = class + strict private + FSettings: TMCPSettings; + FOwnsSettings: Boolean; + FManagerRegistry: IMCPManagerRegistry; + FCoreManager: IMCPCapabilityManager; + FToolsManager: TMCPToolsManager; + FResourcesManager: TMCPResourcesManager; + FPromptsManager: TMCPPromptsManager; + FSubscriptionsManager: TMCPSubscriptionsManager; + FServer: TMCPIdHTTPServer; + FAuthorizer: IMCPAuthorizer; + FSeedFromGlobalRegistry: Boolean; + FActive: Boolean; + procedure BuildManagers; + procedure HideDiagnosticsResources; + procedure EnsureManagers; + function GetManagerRegistry: IMCPManagerRegistry; + function GetCoreManager: IMCPCapabilityManager; + procedure SetSeedFromGlobalRegistry(const Value: Boolean); + public + constructor Create; overload; + constructor Create(const SettingsFile: string); overload; + constructor Create(const Settings: TMCPSettings); overload; + destructor Destroy; override; + + procedure AddTool(const Tool: IMCPTool); + procedure RemoveTool(const Name: string); + function HasTool(const Name: string): Boolean; + procedure AddResource(const Resource: IMCPResource); + procedure AddPrompt(const Prompt: IMCPPrompt); + + procedure StartHttp; + procedure Stop; + function BoundPort: Word; + + procedure RunStdio; + procedure RunStdioWith(const Input, Output: TStream); + + property Settings: TMCPSettings read FSettings; + property Authorizer: IMCPAuthorizer read FAuthorizer write FAuthorizer; + property Active: Boolean read FActive; + property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; + property CoreManager: IMCPCapabilityManager read GetCoreManager; + property SeedFromGlobalRegistry: Boolean read FSeedFromGlobalRegistry write SetSeedFromGlobalRegistry; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors, + MCPServer.ManagerRegistry, + MCPServer.CoreManager, + MCPServer.CompletionManager, + MCPServer.StdioTransport; + +const + URI_LOGS_RECENT = 'logs://recent'; + URI_SERVER_STATUS = 'server://status'; + URI_TEMPLATE_LOGS_BY_LEVEL = 'logs://{level}'; + +{ TMCPServerHost } + +constructor TMCPServerHost.Create; +begin + Create(''); +end; + +constructor TMCPServerHost.Create(const SettingsFile: string); +begin + inherited Create; + + const ReadsAFile = (SettingsFile <> ''); + if ReadsAFile then + FSettings := TMCPSettings.Create(SettingsFile, False) + else + FSettings := TMCPSettings.CreateDefaults; + + FOwnsSettings := True; + FSeedFromGlobalRegistry := False; +end; + +constructor TMCPServerHost.Create(const Settings: TMCPSettings); +begin + inherited Create; + + if not Assigned(Settings) then + raise EArgumentNilException.Create('A host built on settings needs a settings instance'); + + FSettings := Settings; + FOwnsSettings := False; + FSeedFromGlobalRegistry := False; +end; + +destructor TMCPServerHost.Destroy; +begin + Stop; + FServer.Free; + FCoreManager := nil; + FManagerRegistry := nil; + if FOwnsSettings then + FSettings.Free; + inherited; +end; + +procedure TMCPServerHost.BuildManagers; +begin + FManagerRegistry := TMCPManagerRegistry.Create; + FCoreManager := TMCPCoreManager.Create(FSettings); + FToolsManager := TMCPToolsManager.Create(FSeedFromGlobalRegistry); + FResourcesManager := TMCPResourcesManager.Create(FSeedFromGlobalRegistry); + FPromptsManager := TMCPPromptsManager.Create(FSeedFromGlobalRegistry); + FSubscriptionsManager := TMCPSubscriptionsManager.Create; + + if not FSettings.ExposeDiagnosticsResources then + HideDiagnosticsResources; + + 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); +end; + +procedure TMCPServerHost.HideDiagnosticsResources; +begin + FResourcesManager.RemoveResource(URI_LOGS_RECENT); + FResourcesManager.RemoveResource(URI_SERVER_STATUS); + FResourcesManager.RemoveResourceTemplate(URI_TEMPLATE_LOGS_BY_LEVEL); +end; + +procedure TMCPServerHost.EnsureManagers; +begin + if not Assigned(FManagerRegistry) then + BuildManagers; +end; + +function TMCPServerHost.GetManagerRegistry: IMCPManagerRegistry; +begin + EnsureManagers; + Result := FManagerRegistry; +end; + +function TMCPServerHost.GetCoreManager: IMCPCapabilityManager; +begin + EnsureManagers; + Result := FCoreManager; +end; + +procedure TMCPServerHost.SetSeedFromGlobalRegistry(const Value: Boolean); +begin + if Value = FSeedFromGlobalRegistry then + Exit; + + if Assigned(FManagerRegistry) then + raise EMCPConfigurationError.Create('SeedFromGlobalRegistry must be set before the host builds its managers'); + + FSeedFromGlobalRegistry := Value; +end; + +procedure TMCPServerHost.AddTool(const Tool: IMCPTool); +begin + EnsureManagers; + FToolsManager.AddTool(Tool); +end; + +procedure TMCPServerHost.RemoveTool(const Name: string); +begin + EnsureManagers; + FToolsManager.RemoveTool(Name); +end; + +function TMCPServerHost.HasTool(const Name: string): Boolean; +begin + EnsureManagers; + Result := FToolsManager.HasTool(Name); +end; + +procedure TMCPServerHost.AddResource(const Resource: IMCPResource); +begin + EnsureManagers; + FResourcesManager.AddResource(Resource); +end; + +procedure TMCPServerHost.AddPrompt(const Prompt: IMCPPrompt); +begin + EnsureManagers; + FPromptsManager.AddPrompt(Prompt); +end; + +procedure TMCPServerHost.StartHttp; +begin + if FActive then + Exit; + + EnsureManagers; + + if not Assigned(FServer) then + FServer := TMCPIdHTTPServer.Create(nil); + + FServer.Settings := FSettings; + FServer.ManagerRegistry := FManagerRegistry; + FServer.CoreManager := FCoreManager; + FServer.Authorizer := FAuthorizer; + FServer.Start; + FActive := True; +end; + +procedure TMCPServerHost.Stop; +begin + if not FActive then + Exit; + + FActive := False; + FServer.Stop; +end; + +function TMCPServerHost.BoundPort: Word; +begin + if Assigned(FServer) then + Result := FServer.BoundPort + else + Result := Word(FSettings.Port); +end; + +procedure TMCPServerHost.RunStdio; +begin + EnsureManagers; + + const Transport = TMCPStdioTransport.Create(FManagerRegistry, FCoreManager); + try + Transport.Settings := FSettings; + Transport.Run; + finally + Transport.Free; + end; +end; + +procedure TMCPServerHost.RunStdioWith(const Input, Output: TStream); +begin + EnsureManagers; + + const Transport = TMCPStdioTransport.Create(FManagerRegistry, FCoreManager); + try + Transport.Settings := FSettings; + Transport.RunWith(Input, Output); + finally + Transport.Free; + end; +end; + +end. diff --git a/src/Server/MCPServer.HttpHeaders.pas b/src/Server/MCPServer.HttpHeaders.pas new file mode 100644 index 0000000..1072ecf --- /dev/null +++ b/src/Server/MCPServer.HttpHeaders.pas @@ -0,0 +1,307 @@ +unit MCPServer.HttpHeaders; + +interface + +uses + System.SysUtils; + +type + TMCPHeaderValue = record + const SENTINEL_PREFIX = '=?base64?'; + const SENTINEL_SUFFIX = '?='; + + class function Encode(const Value: string): string; static; + 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; + + TMCPOriginParts = record + Scheme: string; + Host: string; + Port: string; + class function Parse(const Origin: string): TMCPOriginParts; static; + function DefaultPort: string; + 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; + +const + SCHEME_HTTP = 'http'; + SCHEME_HTTPS = 'https'; + AUTHORITY_FORMAT = 'http://%s'; + + +{ TMCPHeaderValue } + +class function TMCPHeaderValue.Encode(const Value: string): string; +begin + if IsHeaderSafe(Value) and not IsSentinel(Value) then + Exit(Value); + + const Bytes = TEncoding.UTF8.GetBytes(Value); + Result := SENTINEL_PREFIX + TNetEncoding.Base64String.EncodeBytesToString(Bytes) + SENTINEL_SUFFIX; +end; + +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 } + +{ TMCPOriginParts } + +class function TMCPOriginParts.Parse(const Origin: string): TMCPOriginParts; +begin + Result := Default(TMCPOriginParts); + var Rest := Origin.Trim; + var SchemeEnd := Rest.IndexOf('://'); + if SchemeEnd < 0 then + Exit; + Result.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; + Result.Host := Rest.Substring(0, BracketEnd + 1).ToLower; + PortStart := Rest.IndexOf(':', BracketEnd); + end + else + begin + PortStart := Rest.IndexOf(':'); + if PortStart >= 0 then + Result.Host := Rest.Substring(0, PortStart).ToLower + else + Result.Host := Rest.ToLower; + end; + + if PortStart >= 0 then + Result.Port := Rest.Substring(PortStart + 1); +end; + +function TMCPOriginParts.DefaultPort: string; +begin + if Scheme = SCHEME_HTTPS then + Result := '443' + else if Scheme = SCHEME_HTTP then + Result := '80' + else + Result := ''; +end; + +class function TMCPOriginPolicy.IsLoopback(const Origin: string): Boolean; +begin + const Parts = TMCPOriginParts.Parse(Origin); + const IsHttp = ((Parts.Scheme = SCHEME_HTTP) or (Parts.Scheme = SCHEME_HTTPS)); + const IsLocal = ((Parts.Host = 'localhost') or (Parts.Host = '127.0.0.1') or (Parts.Host = '[::1]')); + Result := IsHttp and IsLocal; +end; + +class function TMCPOriginPolicy.Matches(const Origin, Pattern: string): Boolean; +begin + if Pattern.Trim = ALLOW_ALL then + Exit(True); + + var Wanted := TMCPOriginParts.Parse(Origin); + var Allowed := TMCPOriginParts.Parse(Pattern); + const IsParsed = ((Wanted.Scheme <> '') and (Allowed.Scheme <> '')); + if not IsParsed then + Exit(False); + + const PortIsEmpty = (Wanted.Port = ''); + if PortIsEmpty then + Wanted.Port := Wanted.DefaultPort; + if Allowed.Port = '' then + Allowed.Port := Allowed.DefaultPort; + + const SameHost = ((Wanted.Scheme = Allowed.Scheme) and (Wanted.Host = Allowed.Host)); + const SamePort = ((Allowed.Port = '*') or (Wanted.Port = Allowed.Port)); + Result := SameHost and SamePort; +end; + +class function TMCPOriginPolicy.IsAllowed(const Origin: string; const AllowList: TArray): Boolean; +begin + var Value := Origin.Trim; + const ValueIsEmpty = (Value = ''); + if ValueIsEmpty 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; +begin + if Pattern.Trim = TMCPOriginPolicy.ALLOW_ALL then + Exit(True); + + const Wanted = TMCPOriginParts.Parse(Format(AUTHORITY_FORMAT, [HostHeader.Trim])); + const Allowed = TMCPOriginParts.Parse(Format(AUTHORITY_FORMAT, [Pattern.Trim])); + const SameHost = ((Wanted.Host <> '') and (Allowed.Host <> '') and (Wanted.Host = Allowed.Host)); + if not SameHost then + Exit(False); + Result := (Allowed.Port = '') or (Allowed.Port = '*') or (Allowed.Port = Wanted.Port); +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..59d5aea --- /dev/null +++ b/src/Server/MCPServer.HttpStream.pas @@ -0,0 +1,200 @@ +unit MCPServer.HttpStream; + +interface + +uses + System.SysUtils, + System.SyncObjs, + IdContext, + IdCustomHTTPServer, + MCPServer.Types; + +type + TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequestTracker, IMCPKeepAlive) + strict private + FConnection: TIdContext; + FResponseInfo: TIdHTTPResponseInfo; + FLock: TCriticalSection; + FOpened: Boolean; + FBroken: Boolean; + FClosed: 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 Closed: Boolean read FClosed; + 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; + +{ 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 + const CanWrite = not FBroken and not FClosed; + if not CanWrite 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 + const CanWrite = FOpened and not FBroken and not FClosed; + if not CanWrite 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 + const CanWrite = FOpened and not FBroken and not FClosed; + if not CanWrite then + Exit; + FClosed := True; + 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..22c6413 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, @@ -16,8 +14,11 @@ interface IdHTTPServer, IdContext, IdCustomHTTPServer, + IdHeaderList, IdGlobal, IdGlobalProtocols, + IdSocketHandle, + IdStack, {$IFDEF USE_TAURUS_TLS} TaurusTLS, {$ELSE} @@ -26,9 +27,16 @@ interface IdServerIOHandler, MCPServer.Types, MCPServer.Settings, + MCPServer.Authorization, + MCPServer.RequestContext, MCPServer.JsonRpcProcessor; type + TMCPDiscardedBody = class(TMemoryStream) + public + function Write(const Buffer; Count: Longint): Longint; override; + end; + TMCPIdHTTPServer = class(TComponent) private FHTTPServer: TIdHTTPServer; @@ -43,66 +51,117 @@ 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 AddDualStackBindings(const IPv4Address, IPv6Address: string); + function ClaimEphemeralPort(const IP: string): Word; 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 TryAuthenticate(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; + function IsListedHeader(const List, Name: string): Boolean; + procedure HandleCreatePostStream(Context: TIdContext; Headers: TIdHeaderList; var VPostStream: TStream); + function MaxBodyBytes: Integer; + function MaxJsonDepth: Integer; + function IsBodyWithinLimits(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Body: string): Boolean; + function ReadBody(RequestInfo: TIdHTTPRequestInfo): string; + procedure SendOutcome(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Outcome: TMCPProcessResult; const AcceptsEventStream: Boolean); public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Start; procedure Stop; + function BoundAddresses: TArray; + function BoundPort: Word; 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; + HOST_LOCALHOST = 'localhost'; + DEFAULT_ENDPOINT = '/mcp'; + HEADER_ALLOW_ORIGIN = 'Access-Control-Allow-Origin'; + MESSAGE_NO_CERTIFICATE = 'SSL certificate file not found: %s'; + MESSAGE_NO_KEY = 'SSL key file not found: %s'; 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; + + SUBSCRIPTION_CLOSE_GRACE_MS = 1000; + SUBSCRIPTION_CLOSE_POLL_MS = 10; - // CORS Max Age (24 hours in seconds) CORS_MAX_AGE = 86400; + CORS_ALLOW_METHODS = 'POST, OPTIONS'; + CORS_ALLOW_HEADERS = 'Accept, Content-Type, Authorization, ' + MCP_HEADER_PROTOCOL_VERSION + ', ' + + MCP_HEADER_METHOD + ', ' + MCP_HEADER_NAME + ', ' + MCP_HEADER_SESSION_ID + ', Last-Event-ID'; + CORS_EXPOSE_HEADERS = MCP_HEADER_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'; + + + LOOPBACK_IPV4 = '127.0.0.1'; + LOOPBACK_IPV6 = '::1'; + ANY_IPV4 = '0.0.0.0'; + ANY_IPV6 = '::'; - // 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; +{ TMCPDiscardedBody } - // SSE Message Format - SSE_EVENT_PREFIX = 'event: '; - SSE_DATA_PREFIX = 'data: '; - SSE_ID_PREFIX = 'id: '; - SSE_MESSAGE_TERMINATOR = #10#10; +function TMCPDiscardedBody.Write(const Buffer; Count: Longint): Longint; +begin + Result := Count; +end; { TMCPIdHTTPServer } @@ -111,7 +170,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 +177,8 @@ constructor TMCPIdHTTPServer.Create(Owner: TComponent); FHTTPServer.OnCommandGet := HandleHTTPRequest; FHTTPServer.OnCommandOther := HandleHTTPRequest; FHTTPServer.OnQuerySSLPort := HandleQuerySSLPort; + FHTTPServer.OnParseAuthentication := HandleParseAuthentication; + FHTTPServer.OnCreatePostStream := HandleCreatePostStream; FSSLHandler := nil; end; @@ -139,420 +199,660 @@ procedure TMCPIdHTTPServer.Start; Exit; if not Assigned(FManagerRegistry) then - raise Exception.Create('Manager registry not assigned'); + raise EMCPConfigurationError.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)); + if (FPort = 0) and (FHTTPServer.Bindings.Count > 0) then + FPort := FHTTPServer.Bindings[0].Port; + + TLogger.Info('MCP Server listening on ' + string.Join(', ', BoundAddresses)); +end; + +procedure TMCPIdHTTPServer.CloseSubscriptions; +var + Hub: IMCPSubscriptionHub; +begin + if not Assigned(FManagerRegistry) or + not Supports(FManagerRegistry.GetManagerForMethod(MCP_METHOD_SUBSCRIPTIONS_LISTEN), IMCPSubscriptionHub, Hub) then + Exit; + + 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; procedure TMCPIdHTTPServer.Stop; begin if not FActive then Exit; - + + CloseSubscriptions; FHTTPServer.Active := False; FActive := False; TLogger.Info('MCP Server stopped'); end; -procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; - RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); -var - RequestPath: string; +function TMCPIdHTTPServer.BoundAddresses: TArray; begin - TServerStatusResource.ConnectionOpened; - try - TServerStatusResource.IncrementRequestCount; - - if not VerifyAndSetCORSHeaders(RequestInfo, ResponseInfo) then - Exit; // CORS blocked the request - - RequestPath := RequestInfo.Document; - - // 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) + Result := nil; + for var I := 0 to FHTTPServer.Bindings.Count - 1 do + begin + var Binding := FHTTPServer.Bindings[I]; + const IsId_IPv6 = (Binding.IPVersion = Id_IPv6); + if IsId_IPv6 then + Result := Result + [Format('[%s]:%d', [Binding.IP, Binding.Port])] else - begin - ResponseInfo.ResponseNo := HTTP_METHOD_NOT_ALLOWED; - ResponseInfo.ResponseText := 'Method Not Allowed'; - end; - finally - TServerStatusResource.ConnectionClosed; + Result := Result + [Format('%s:%d', [Binding.IP, Binding.Port])]; end; end; -function TMCPIdHTTPServer.VerifyAndSetCORSHeaders(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo): Boolean; -var - AllowedOrigin: string; - CurrentOrigin: string; - Found: Boolean; - Origin: string; - OriginsList: TStringList; +function TMCPIdHTTPServer.BoundPort: Word; begin - Result := True; - - if not Assigned(FSettings) or not FSettings.CorsEnabled then - Exit; + if FHTTPServer.Bindings.Count > 0 then + Result := Word(FHTTPServer.Bindings[0].Port) + else + Result := FPort; +end; - Origin := RequestInfo.RawHeaders.Values['Origin']; - AllowedOrigin := '*'; +procedure TMCPIdHTTPServer.AddBinding(const IP: string; IPVersion: TIdIPVersion); +begin + var Binding := FHTTPServer.Bindings.Add; + Binding.IP := IP; + Binding.Port := FPort; + Binding.IPVersion := IPVersion; +end; - if (FSettings.CorsAllowedOrigins <> '*') and (Origin <> '') then - 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; +function TMCPIdHTTPServer.ClaimEphemeralPort(const IP: string): Word; +begin + const Probe = TIdSocketHandle.Create(nil); + try + Probe.IPVersion := Id_IPv4; + Probe.IP := IP; + Probe.Port := 0; + Probe.AllocateSocket; + Probe.Bind; + Result := Word(Probe.Port); + Probe.CloseSocket; + finally + Probe.Free; 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.AddDualStackBindings(const IPv4Address, IPv6Address: string); begin - ResponseInfo.ResponseNo := HTTP_OK; - ResponseInfo.ResponseText := 'OK'; + const BindsBothFamilies = GStack.SupportsIPv6; + const SystemPicksThePort = (FPort = 0); + if BindsBothFamilies and SystemPicksThePort then + FPort := ClaimEphemeralPort(IPv4Address); + + AddBinding(IPv4Address, Id_IPv4); + if BindsBothFamilies then + AddBinding(IPv6Address, Id_IPv6); end; -procedure TMCPIdHTTPServer.HandleGetRequest(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); -var - AcceptHeader: string; - SessionID: string; +procedure TMCPIdHTTPServer.ConfigureBindings; begin - AcceptHeader := RequestInfo.RawHeaders.Values['Accept']; - - 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'; + FHTTPServer.Bindings.Clear; - 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 := 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 + const HasAddress = (Address <> ''); + if HasAddress 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, HOST_LOCALHOST) or (Host = LOOPBACK_IPV4) or (Host = LOOPBACK_IPV6) then + begin + AddDualStackBindings(LOOPBACK_IPV4, LOOPBACK_IPV6); + end + else + begin + TLogger.Info('Host ' + Host + ' is not loopback; listening on every network interface (set BindAddress to narrow this)'); + AddDualStackBindings(ANY_IPV4, ANY_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); + TLogger.Error(Format(MESSAGE_NO_CERTIFICATE, [FSettings.SSLCertFile])); + raise EMCPConfigurationError.CreateFmt(MESSAGE_NO_CERTIFICATE, [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); + TLogger.Error(Format(MESSAGE_NO_KEY, [FSettings.SSLKeyFile])); + raise EMCPConfigurationError.CreateFmt(MESSAGE_NO_KEY, [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); - if FSettings.SSLRootCertFile <> '' then + const HasSSLRootCertFile = (FSettings.SSLRootCertFile <> ''); + if HasSSLRootCertFile then 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 +function TMCPIdHTTPServer.IsListedHeader(const List, Name: string): Boolean; +begin + for var Listed in List.Split([',']) do begin - Obj := JSONRequest as TJSONObject; - MethodValue := Obj.GetValue('method'); - IdValue := Obj.GetValue('id'); - ResultValue := Obj.GetValue('result'); - ErrorValue := Obj.GetValue('error'); - - if Assigned(MethodValue) and not Assigned(IdValue) then + if SameText(Listed.Trim, Name) then Exit(True); + end; + Result := False; +end; - if Assigned(ResultValue) or Assigned(ErrorValue) then - Exit(True); +function TMCPIdHTTPServer.MaxBodyBytes: Integer; +begin + Result := TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES; + if Assigned(FSettings) then + Result := FSettings.MaxRequestBodyBytes; +end; - Result := False; - end - else if JSONRequest is TJSONArray then - begin - Arr := JSONRequest as TJSONArray; - Result := True; - for I := 0 to Arr.Count - 1 do +procedure TMCPIdHTTPServer.HandleCreatePostStream(Context: TIdContext; Headers: TIdHeaderList; + var VPostStream: TStream); +begin + const Declared = StrToInt64Def(Headers.Values['Content-Length'], 0); + const TooLarge = (Declared > MaxBodyBytes); + if TooLarge then + VPostStream := TMCPDiscardedBody.Create; +end; + +procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; + RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + TServerStatusResource.ConnectionOpened; + try + TServerStatusResource.IncrementRequestCount; + + ApplyCorsHeaders(RequestInfo, ResponseInfo); + + if not ValidateHost(RequestInfo, ResponseInfo) or not ValidateOrigin(RequestInfo, ResponseInfo) then + Exit; + + var Endpoint := DEFAULT_ENDPOINT; + 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; + + const IsNotEndpoint = (RequestInfo.Document <> Endpoint); + if IsNotEndpoint 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 TryAuthenticate(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; + const ListIsEmpty = (List.Trim = ''); + if ListIsEmpty 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[HEADER_ALLOW_ORIGIN] := TMCPOriginPolicy.ALLOW_ALL else + ResponseInfo.CustomHeaders.Values[HEADER_ALLOW_ORIGIN] := Origin; + + var AllowHeaders := CORS_ALLOW_HEADERS; + for var Requested in HeaderValue(RequestInfo, 'Access-Control-Request-Headers').Split([',']) do begin - ResponseInfo.ContentText := ''; + const Name = Requested.Trim; + const IsNew = ((Name <> '') and not IsListedHeader(AllowHeaders, Name)); + if IsNew then + AllowHeaders := Format('%s, %s', [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.HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); -var - ResponseBody: string; - ResponseJSON: TJSONObject; - ResultObj: TJSONObject; - SessionValue: TJSONValue; +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 + begin + Versions.Add(Version); + end; + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + begin + Versions.Add(Version); + end; + SendJson(ResponseInfo, HTTP_STATUS_OK, Info.ToJSON); + finally + Info.Free; + end; +end; + +function TMCPIdHTTPServer.IsProtectedResourceMetadataPath(const Document: string): Boolean; +begin + var Endpoint := DEFAULT_ENDPOINT; + 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; + const HasResult = (Result <> ''); + if HasResult 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.TryAuthenticate(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + out Principal: TMCPPrincipal): Boolean; +begin + Principal := TMCPPrincipal.None; + Result := False; + + const Header = HeaderValue(RequestInfo, HEADER_AUTHORIZATION); + const IsMissing = (Header = ''); + if IsMissing then + begin + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, TMCPAuthChallenge.None, 'Authorization required'); + Exit; + end; + + const IsBearer = (Header.StartsWith(BEARER_PREFIX, True) and (Header.Length > BEARER_PREFIX.Length)); + if not IsBearer then + begin + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, + TMCPAuthChallenge.InvalidRequest('Only the Bearer scheme is supported'), 'Malformed Authorization header'); + Exit; + end; + + const Token = Header.Substring(BEARER_PREFIX.Length).Trim; + const Outcome = FAuthorizer.Authorize(Token, RequestInfo.Command, RequestInfo.Document); + Principal := Outcome.Principal; + case Outcome.Decision of + TMCPAuthDecision.Allow: + Result := True; + TMCPAuthDecision.Unauthorized: + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Outcome.Challenge, 'Unauthorized'); + TMCPAuthDecision.Forbidden: + SendChallenge(ResponseInfo, HTTP_FORBIDDEN, Outcome.Challenge, 'Forbidden'); + TMCPAuthDecision.BadRequest: + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, Outcome.Challenge, 'Malformed authorization request'); + else + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Outcome.Challenge, 'Unauthorized'); + end; +end; + +function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; +begin + Result := TMCPTransportHints.ForHttp( + HeaderPresent(RequestInfo, MCP_HEADER_PROTOCOL_VERSION), HeaderValue(RequestInfo, MCP_HEADER_PROTOCOL_VERSION)); + Result.HasMethodHeader := HeaderPresent(RequestInfo, MCP_HEADER_METHOD); + Result.MethodHeader := HeaderValue(RequestInfo, MCP_HEADER_METHOD); + Result.HasNameHeader := HeaderPresent(RequestInfo, MCP_HEADER_NAME); + Result.NameHeader := HeaderValue(RequestInfo, MCP_HEADER_NAME); + Result.RemoteAddress := RequestInfo.RemoteIP; +end; + +procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); begin - TLogger.Info('Handling POST request with JSON response'); + var SessionId := HeaderValue(RequestInfo, MCP_HEADER_SESSION_ID); + if (SessionId <> '') and TMCPHeaderValue.IsHeaderSafe(SessionId) and not SessionId.Contains(' ') then + ResponseInfo.CustomHeaders.Values[MCP_HEADER_SESSION_ID] := SessionId; +end; - ResponseBody := FJsonRpcProcessor.ProcessRequest(RequestBody, SessionID); +procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; + ResponseInfo: TIdHTTPResponseInfo; const Principal: TMCPPrincipal); +begin + const RequestBody = ReadBody(RequestInfo); + TLogger.Debug('Request: ' + TLogger.RedactJson(RequestBody)); + if not IsBodyWithinLimits(RequestInfo, ResponseInfo, RequestBody) then + Exit; - if ResponseBody = '' then + const 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 - ResponseInfo.ResponseNo := HTTP_NO_CONTENT; + Stream := TMCPHttpResponseStream.Create(Context, ResponseInfo); + StreamRef := Stream; + Hints.Sink := Stream; + Hints.Tracker := Stream; + end; + + var Outcome: TMCPProcessResult; + const Message = TJSONObject.ParseJSONValue(RequestBody); + try + Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, Hints); + finally + Message.Free; + end; + + const IsStreamed = (Assigned(Stream) and Stream.Opened); + if IsStreamed then + begin + TLogger.Debug('Response (streamed): ' + TLogger.RedactJson(Outcome.Body)); + Stream.Finish(Outcome.Body); Exit; end; - ResponseInfo.ContentType := 'application/json'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; + SendOutcome(RequestInfo, ResponseInfo, Outcome, AcceptsEventStream); +end; + +function TMCPIdHTTPServer.MaxJsonDepth: Integer; +begin + Result := TMCPSettings.DEFAULT_MAX_JSON_DEPTH; + if Assigned(FSettings) then + Result := FSettings.MaxJsonDepth; +end; - if (SessionID = '') and (Pos('"sessionId"', ResponseBody) > 0) then +function TMCPIdHTTPServer.ReadBody(RequestInfo: TIdHTTPRequestInfo): string; +begin + Result := ''; + const HasBody = (Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > 0)); + if not HasBody then + Exit; + + RequestInfo.PostStream.Position := 0; + Result := ReadStringFromStream(RequestInfo.PostStream, -1, IndyTextEncoding_UTF8); +end; + +function TMCPIdHTTPServer.IsBodyWithinLimits(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Body: string): Boolean; +begin + const Limit = MaxBodyBytes; + const IsTooLarge = Assigned(RequestInfo.PostStream) and + ((RequestInfo.PostStream is TMCPDiscardedBody) or (RequestInfo.PostStream.Size > Limit)); + if IsTooLarge 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_PAYLOAD_TOO_LARGE, JSONRPC_INVALID_REQUEST, + Format('Request body exceeds %d bytes', [Limit])); + Exit(False); + end; + + const Depth = MaxJsonDepth; + const IsTooDeep = (TMCPJsonLimits.NestingDepth(Body) > Depth); + if IsTooDeep then + begin + SendJsonRpcError(ResponseInfo, HTTP_STATUS_BAD_REQUEST, JSONRPC_PARSE_ERROR, + Format('JSON nesting exceeds %d levels', [Depth])); + Exit(False); + end; + Result := True; +end; + +procedure TMCPIdHTTPServer.SendOutcome(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Outcome: TMCPProcessResult; const AcceptsEventStream: Boolean); +begin + if Outcome.Era = TMCPProtocolEra.Legacy then + EchoLegacySessionId(RequestInfo, ResponseInfo); + const HasRequiredScope = (Outcome.RequiredScope <> ''); + if HasRequiredScope then + ResponseInfo.CustomHeaders.Values[HEADER_WWW_AUTHENTICATE] := + TMCPBearerChallenge.Build(ResourceMetadataUrl, TMCPAuthChallenge.InsufficientScope(Outcome.RequiredScope)); + + const IsEmpty = (Outcome.Body = ''); + if IsEmpty then + begin + SendEmpty(ResponseInfo, Outcome.HttpStatus); + Exit; + end; + + TLogger.Debug('Response: ' + TLogger.RedactJson(Outcome.Body)); + + const AsEventStream = ((Outcome.HttpStatus = HTTP_STATUS_OK) and AcceptsEventStream); + if AsEventStream 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; +end; - ResponseInfo.ContentStream := TStringStream.Create(ResponseBody, TEncoding.UTF8); +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; - ResponseInfo.ResponseNo := HTTP_OK; +end; - TLogger.Info('Response: ' + ResponseBody); +procedure TMCPIdHTTPServer.SendSse(ResponseInfo: TIdHTTPResponseInfo; const Body: string); +begin + ResponseInfo.ResponseNo := HTTP_STATUS_OK; + ResponseInfo.ContentType := MEDIA_TYPE_EVENT_STREAM; + ResponseInfo.CharSet := CHARSET_UTF8; + 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(MCP_KEY_JSONRPC, '2.0'); + var Error := TJSONObject.Create; + Response.AddPair(MCP_KEY_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..3c217ea --- /dev/null +++ b/src/Server/MCPServer.StdioChannel.pas @@ -0,0 +1,247 @@ +unit MCPServer.StdioChannel; + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + MCPServer.Types; + +type + TMCPLineStatus = ( + Ok, + TooLong, + InvalidUtf8 + ); + + TMCPLine = record + Status: TMCPLineStatus; + Text: string; + end; + + TMCPLineReader = class + strict private + const READ_CHUNK_BYTES = 64 * 1024; + const CARRIAGE_RETURN = 13; + strict private + FStream: TStream; + FMaxLineBytes: Integer; + FPending: TBytes; + FPendingLength: Integer; + FAtStart: Boolean; + FEndOfStream: Boolean; + function Fill: Boolean; + function DecodeLine(const Start, Count: Integer): TMCPLine; + function RoundTrips(const Line: string; const Start, Count: Integer): Boolean; + public + constructor Create(Stream: TStream; MaxLineBytes: Integer); + function TryReadLine(out Line: TMCPLine): 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.RoundTrips(const Line: string; const Start, Count: Integer): Boolean; +begin + const Encoded = TEncoding.UTF8.GetBytes(Line); + const SameLength = (Length(Encoded) = Count); + if not SameLength then + Exit(False); + if Count = 0 then + Exit(True); + Result := CompareMem(@Encoded[0], @FPending[Start], Count); +end; + +function TMCPLineReader.DecodeLine(const Start, Count: Integer): TMCPLine; +begin + Result := Default(TMCPLine); + var Length := Count; + const EndsWithCarriageReturn = ((Length > 0) and (FPending[Start + Length - 1] = CARRIAGE_RETURN)); + if EndsWithCarriageReturn then + Dec(Length); + + const IsTooLong = (Length > FMaxLineBytes); + if IsTooLong then + begin + Result.Status := TMCPLineStatus.TooLong; + Exit; + end; + + try + Result.Text := TEncoding.UTF8.GetString(FPending, Start, Length); + except + Result.Text := ''; + Result.Status := TMCPLineStatus.InvalidUtf8; + Exit; + end; + + const IsValidUtf8 = RoundTrips(Result.Text, Start, Length); + if not IsValidUtf8 then + begin + Result.Text := ''; + Result.Status := TMCPLineStatus.InvalidUtf8; + end; +end; + +function TMCPLineReader.TryReadLine(out Line: TMCPLine): Boolean; +begin + Line := Default(TMCPLine); + var ScanFrom := 0; + + while True do + begin + for var I := ScanFrom to FPendingLength - 1 do + if FPending[I] = 10 then + begin + Line := DecodeLine(0, I); + 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); + Line := DecodeLine(0, FPendingLength); + 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..168e31c 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -5,25 +5,247 @@ 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; + const QUEUE_PUSH_TIMEOUT_MS = 1000; + 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; + FStartedWorkers: 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; + +const + REASON_STDIN_CLOSED = 'stdin closed'; + + +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; + const HasReason = (Reason <> ''); + if HasReason 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 + begin + Context.Cancel; + end; + 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 +254,297 @@ 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; - if InputLine.Trim = '' then - Continue; +function TMCPStdioTransport.Hints: TMCPTransportHints; +begin + Result := TMCPTransportHints.ForStdio(FLegacySession, FWriter, FTrackerIntf); +end; - TLogger.Info('Received: ' + InputLine); +function TMCPStdioTransport.WorkerCount: Integer; +begin + Result := Settings.MaxConcurrentRequests; + if Result < 1 then + Result := 1; +end; - Response := FJsonRpcProcessor.ProcessRequest(InputLine, ''); +procedure TMCPStdioTransport.SendResponse(const Body: string); +begin + if Body = '' then + Exit; + FWriter.Send(Body); + TLogger.Debug('Sent: ' + TLogger.RedactJson(Body)); +end; - if Response <> '' then +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; + +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(MCP_KEY_ID)); + var MethodValue := Request.GetValue(MCP_KEY_METHOD); + var Method := ''; + if MethodValue is TJSONString then + Method := TJSONString(MethodValue).Value; + + if RequestId.IsPresent and (Method <> '') and (Method <> MCP_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; + try + if Method = MCP_METHOD_SUBSCRIPTIONS_LISTEN then + begin + StartListener(Message); + Queued := True; + Exit; + end; + const Accepted = (FQueue.PushItem(Message) = TWaitResult.wrSignaled); + if not Accepted then + begin + FTracker.Release(RequestId); + SendError(RequestId, JSONRPC_INTERNAL_ERROR, 'Server is shutting down'); + Exit; + end; + Queued := True; + Exit; + except + on E: Exception do + begin + FTracker.Release(RequestId); + SendError(RequestId, JSONRPC_INTERNAL_ERROR, Format('Request could not be started: %s', [E.Message])); + Exit; + end; + end; 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; + +procedure TMCPStdioTransport.ProcessQueued(const Message: TJSONValue); +begin + var RequestId := TMCPRequestId.FromJson(TJSONObject(Message).GetValue(MCP_KEY_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; - // 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.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(REASON_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 + FStartedWorkers := WorkerCount; + FQueue := TThreadedQueue.Create(QUEUE_DEPTH, QUEUE_PUSH_TIMEOUT_MS, INFINITE); + FWorkersDone := TCountdownEvent.Create(FStartedWorkers); + for var WorkerNumber := 1 to FStartedWorkers do + begin + TMCPStdioWorker.Create(Self); + end; + TLogger.Info(Format('STDIO transport started: %d worker thread(s), logging to stderr', [FStartedWorkers])); +end; + +procedure TMCPStdioTransport.DrainAndStop; +begin + for var WorkerNumber := 1 to FStartedWorkers do + begin + FQueue.PushItem(nil); + end; + + const Drained = (FWorkersDone.WaitFor(Cardinal(FShutdownDrainMs)) = TWaitResult.wrSignaled); + if not Drained then + begin + FTracker.CancelAll(REASON_STDIN_CLOSED); + FWorkersDone.WaitFor(SHUTDOWN_CANCEL_GRACE_MS); + end; + CloseSubscriptions; + + const AllStopped = (FWorkersDone.IsSet and (AtomicCmpExchange(FListeners, 0, 0) = 0)); + if AllStopped 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: TMCPLine; +begin + var Reader := TMCPLineReader.Create(InputStream, Settings.MaxRequestBodyBytes); + try + while Reader.TryReadLine(Line) do + begin + try + case Line.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.Text.Trim = '' then + Continue; + TLogger.Debug('Received: ' + TLogger.RedactJson(Line.Text)); + DispatchLine(TJSONObject.ParseJSONValue(Line.Text)); end; - Flush(Output); + except + on E: Exception do + TLogger.Error('Error reading stdio request: ' + E.Message); end; end; + finally + Reader.Free; + end; +end; + +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; - TLogger.Info('STDIO transport stopped - EOF reached'); +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..23ebc58 100644 --- a/src/Tools/MCPServer.Tool.Base.pas +++ b/src/Tools/MCPServer.Tool.Base.pas @@ -5,9 +5,15 @@ interface uses System.SysUtils, System.Rtti, - System.JSON; + System.JSON, + MCPServer.Types; type + TMCPToolAnnotationWriter = record + public + class procedure ReadOnly(var Annotations: TJSONObject; const OpenWorld: Boolean); static; + end; + IMCPTool = interface ['{F1E2D3C4-B5A6-4798-8901-234567890ABC}'] function GetName: string; @@ -24,66 +30,100 @@ 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; + procedure MarkReadOnly(const OpenWorld: Boolean = False); 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; + procedure MarkReadOnly(const OpenWorld: Boolean = False); + 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; + procedure MarkReadOnly(const OpenWorld: Boolean = False); + 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; + +{ TMCPToolAnnotationWriter } + +class procedure TMCPToolAnnotationWriter.ReadOnly(var Annotations: TJSONObject; const OpenWorld: Boolean); +begin + const HasAnnotations = Assigned(Annotations); + if not HasAnnotations then + Annotations := TJSONObject.Create; + Annotations.RemovePair(MCP_ANNOTATION_READ_ONLY_HINT).Free; + Annotations.RemovePair(MCP_ANNOTATION_OPEN_WORLD_HINT).Free; + Annotations.AddPair(MCP_ANNOTATION_READ_ONLY_HINT, TJSONBool.Create(True)); + Annotations.AddPair(MCP_ANNOTATION_OPEN_WORLD_HINT, TJSONBool.Create(OpenWorld)); +end; { TMCPToolBase } @@ -92,6 +132,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 +154,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -120,6 +167,34 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := BuildSchema; end; +procedure TMCPToolBase.MarkReadOnly(const OpenWorld: Boolean); +begin + TMCPToolAnnotationWriter.ReadOnly(FAnnotations, OpenWorld); +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.TryValidate(Schema, Arguments, Errors) then + raise EArgumentException.Create(string.Join('; ', Errors)); + finally + Schema.Free; + end; + Result := DoExecute(Arguments); +end; + { TMCPToolBase } constructor TMCPToolBase.Create; @@ -127,6 +202,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 +224,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -155,13 +237,38 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(T); end; +procedure TMCPToolBase.MarkReadOnly(const OpenWorld: Boolean); +begin + TMCPToolAnnotationWriter.ReadOnly(FAnnotations, OpenWorld); +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 +279,6 @@ function TMCPToolBase.GetParamsClass: TClass; Result := T; end; - { TMCPToolBase } constructor TMCPToolBase.Create; @@ -180,22 +286,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 +331,7 @@ function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; function TMCPToolBase.GetDescription: string; begin - result := FDescription; + Result := FDescription; end; function TMCPToolBase.GetInputSchema: TJSONObject; @@ -229,4 +357,19 @@ function TMCPToolBase.GetOutputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(R); end; -end. \ No newline at end of file +procedure TMCPToolBase.MarkReadOnly(const OpenWorld: Boolean); +begin + TMCPToolAnnotationWriter.ReadOnly(FAnnotations, OpenWorld); +end; + +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..57e73f3 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; @@ -40,12 +40,16 @@ implementation uses MCPServer.Registration; +const + TOOL_NAME = 'calculate'; + + { TCalculateTool } constructor TCalculateTool.Create; begin inherited; - FName := 'calculate'; + FName := TOOL_NAME; FDescription := 'Perform basic arithmetic calculations'; end; @@ -74,14 +78,14 @@ 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 ]); end; initialization - TMCPRegistry.RegisterTool('calculate', + TMCPRegistry.RegisterTool(TOOL_NAME, function: IMCPTool begin Result := TCalculateTool.Create; diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas new file mode 100644 index 0000000..5fcc6e9 --- /dev/null +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -0,0 +1,350 @@ +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; + +const + TOOL_SIMPLE_TEXT = 'test_simple_text'; + TOOL_IMAGE_CONTENT = 'test_image_content'; + TOOL_AUDIO_CONTENT = 'test_audio_content'; + TOOL_EMBEDDED_RESOURCE = 'test_embedded_resource'; + TOOL_MULTIPLE_CONTENT_TYPES = 'test_multiple_content_types'; + TOOL_ERROR_HANDLING = 'test_error_handling'; + TOOL_WITH_PROGRESS = 'test_tool_with_progress'; + TOOL_LOGGING = 'test_logging_tool'; + TOOL_JSON_SCHEMA = 'json_schema_2020_12_tool'; + MIME_TYPE_PNG = 'image/png'; + MIME_TYPE_TEXT = 'text/plain'; + + +{ TSimpleTextTool } + +constructor TSimpleTextTool.Create; +begin + inherited; + FName := TOOL_SIMPLE_TEXT; + FDescription := 'Returns a plain text result'; + MarkReadOnly; +end; + +function TSimpleTextTool.ExecuteWithParams(const Params: TNoParams): string; +begin + Result := 'This is a simple text response'; +end; + +{ TImageContentTool } + +constructor TImageContentTool.Create; +begin + inherited; + FName := TOOL_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, MIME_TYPE_PNG); +end; + +{ TAudioContentTool } + +constructor TAudioContentTool.Create; +begin + inherited; + FName := TOOL_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 := TOOL_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, MIME_TYPE_TEXT, SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TMultipleContentTypesTool } + +constructor TMultipleContentTypesTool.Create; +begin + inherited; + FName := TOOL_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, MIME_TYPE_PNG) + .AddEmbeddedText(SAMPLE_TEXT_RESOURCE_URI, MIME_TYPE_TEXT, SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TErrorHandlingTool } + +constructor TErrorHandlingTool.Create; +begin + inherited; + FName := TOOL_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 := 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 := TOOL_JSON_SCHEMA; + 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 := TOOL_LOGGING; + 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]), TOOL_LOGGING); + end; + Result := TMCPToolResult.Text('Logged a message at every level'); +end; + +initialization + TMCPRegistry.RegisterTool(TOOL_SIMPLE_TEXT, + function: IMCPTool + begin + Result := TSimpleTextTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_IMAGE_CONTENT, + function: IMCPTool + begin + Result := TImageContentTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_AUDIO_CONTENT, + function: IMCPTool + begin + Result := TAudioContentTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_EMBEDDED_RESOURCE, + function: IMCPTool + begin + Result := TEmbeddedResourceTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_MULTIPLE_CONTENT_TYPES, + function: IMCPTool + begin + Result := TMultipleContentTypesTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_WITH_PROGRESS, + function: IMCPTool + begin + Result := TProgressTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_ERROR_HANDLING, + function: IMCPTool + begin + Result := TErrorHandlingTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_LOGGING, + function: IMCPTool + begin + Result := TLoggingTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_JSON_SCHEMA, + function: IMCPTool + begin + Result := TJsonSchema202012Tool.Create; + end); + +end. diff --git a/src/Tools/MCPServer.Tool.Echo.pas b/src/Tools/MCPServer.Tool.Echo.pas index 6f8be73..823b38d 100644 --- a/src/Tools/MCPServer.Tool.Echo.pas +++ b/src/Tools/MCPServer.Tool.Echo.pas @@ -29,12 +29,16 @@ implementation uses MCPServer.Registration; +const + TOOL_NAME = 'echo'; + + { TEchoTool } constructor TEchoTool.Create; begin inherited; - FName := 'echo'; + FName := TOOL_NAME; FDescription := 'Echo a message back to the user'; end; @@ -44,7 +48,7 @@ function TEchoTool.ExecuteWithParams(const Params: TEchoParams): string; end; initialization - TMCPRegistry.RegisterTool('echo', + TMCPRegistry.RegisterTool(TOOL_NAME, function: IMCPTool begin Result := TEchoTool.Create; diff --git a/src/Tools/MCPServer.Tool.GetTime.pas b/src/Tools/MCPServer.Tool.GetTime.pas index b951424..8db0374 100644 --- a/src/Tools/MCPServer.Tool.GetTime.pas +++ b/src/Tools/MCPServer.Tool.GetTime.pas @@ -24,12 +24,16 @@ implementation uses MCPServer.Registration; +const + TOOL_NAME = 'get_time'; + + { TGetTimeTool } constructor TGetTimeTool.Create; begin inherited; - FName := 'get_time'; + FName := TOOL_NAME; FDescription := 'Get the current server time in ISO format'; end; @@ -39,7 +43,7 @@ function TGetTimeTool.ExecuteWithParams(const Params: TGetTimeParams): string; end; initialization - TMCPRegistry.RegisterTool('get_time', + TMCPRegistry.RegisterTool(TOOL_NAME, function: IMCPTool begin Result := TGetTimeTool.Create; diff --git a/src/Tools/MCPServer.Tool.InputRequiredSamples.pas b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas new file mode 100644 index 0000000..203d3c3 --- /dev/null +++ b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas @@ -0,0 +1,500 @@ +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 + ASK_STEP_ONE = 'Step 1: What is your name?'; + ASK_STEP_TWO = 'Step 2: What is your favorite color?'; + TOOL_ELICITATION = 'test_input_required_result_elicitation'; + TOOL_SAMPLING = 'test_input_required_result_sampling'; + TOOL_LIST_ROOTS = 'test_input_required_result_list_roots'; + TOOL_REQUEST_STATE = 'test_input_required_result_request_state'; + TOOL_MULTIPLE_INPUTS = 'test_input_required_result_multiple_inputs'; + TOOL_MULTI_ROUND = 'test_input_required_result_multi_round'; + TOOL_TAMPERED_STATE = 'test_input_required_result_tampered_state'; + TOOL_CAPABILITIES = 'test_input_required_result_capabilities'; + TOOL_MISSING_CAPABILITY = 'test_missing_capability'; + TOOL_STREAMING_ELICITATION = 'test_streaming_elicitation'; + ASK_CONFIRM = 'Please confirm'; + SCHEMA_TYPE_BOOLEAN = 'boolean'; + VALUE_TRUE = 'true'; + 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(MCP_KEY_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 := TOOL_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); + const NameIsEmpty = (Name = ''); + if NameIsEmpty 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 := TOOL_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); + const AnswerIsEmpty = (Answer = ''); + if AnswerIsEmpty 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 := TOOL_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 := TOOL_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) = VALUE_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, ASK_CONFIRM, TMCPInputRequests.FieldSchema(FIELD_OK, SCHEMA_TYPE_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 := TOOL_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 := TOOL_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, ASK_STEP_ONE, 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); + const NameIsEmpty = (Name = ''); + if NameIsEmpty then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP1, ASK_STEP_ONE, 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, ASK_STEP_TWO, TMCPInputRequests.FieldSchema(FIELD_COLOR)), State); + end; + + var Color := ''; + if Context.TryGetInputResponse(KEY_STEP2, Response) then + Color := TMCPInputResponse.ElicitationField(Response, FIELD_COLOR); + const ColorIsEmpty = (Color = ''); + if ColorIsEmpty then + begin + var State := TInputSample.NewState(2); + State.AddPair(STATE_NAME, Context.RequestState.GetValue(STATE_NAME, '')); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP2, ASK_STEP_TWO, 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 := TOOL_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) = VALUE_TRUE); + if not Confirmed or not Assigned(Context.RequestState) then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, ASK_CONFIRM, TMCPInputRequests.FieldSchema(FIELD_OK, SCHEMA_TYPE_BOOLEAN)), TInputSample.NewState(1)); + + Result := TMCPToolResult.Text('state-ok: the requestState verified'); +end; + +{ TCapabilityAwareInputTool } + +constructor TCapabilityAwareInputTool.Create; +begin + inherited; + FName := TOOL_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; + + const HasRequests = (Requests.Count > 0); + if HasRequests then + begin + var Pending := Requests; + Requests := nil; + raise EMCPInputRequired.Create(Pending); + end; + finally + Requests.Free; + end; + + const AnswersIsEmpty = (Length(Answers) = 0); + if AnswersIsEmpty 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 := TOOL_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 := TOOL_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', TOOL_STREAMING_ELICITATION); + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) and + (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = VALUE_TRUE); + if not Confirmed then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, ASK_CONFIRM, TMCPInputRequests.FieldSchema(FIELD_OK, SCHEMA_TYPE_BOOLEAN))); + + Result := TMCPToolResult.Text('Confirmed'); +end; + +initialization + TMCPRegistry.RegisterTool(TOOL_ELICITATION, + function: IMCPTool + begin + Result := TElicitationInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_SAMPLING, + function: IMCPTool + begin + Result := TSamplingInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_LIST_ROOTS, + function: IMCPTool + begin + Result := TListRootsInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_REQUEST_STATE, + function: IMCPTool + begin + Result := TRequestStateInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_MULTIPLE_INPUTS, + function: IMCPTool + begin + Result := TMultipleInputsTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_MULTI_ROUND, + function: IMCPTool + begin + Result := TMultiRoundInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_TAMPERED_STATE, + function: IMCPTool + begin + Result := TTamperedStateInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_CAPABILITIES, + function: IMCPTool + begin + Result := TCapabilityAwareInputTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_MISSING_CAPABILITY, + function: IMCPTool + begin + Result := TMissingCapabilityTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_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..7c75f24 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; @@ -35,14 +35,19 @@ TListFilesTool = class(TMCPToolBase) implementation uses - MCPServer.Registration; + MCPServer.Registration, + MCPServer.PathBoundary; + +const + TOOL_NAME = 'list_files'; + { TListFilesTool } constructor TListFilesTool.Create; begin inherited; - FName := 'list_files'; + FName := TOOL_NAME; FDescription := 'List files in a directory'; end; @@ -62,12 +67,13 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin NormalizedPath := TPath.GetFullPath(Params.Path); AllowedBasePath := TPath.GetFullPath(GetCurrentDir); - if not NormalizedPath.StartsWith(AllowedBasePath, True) then + const IsAllowed = TPathBoundary.IsWithin(NormalizedPath, AllowedBasePath); + if not IsAllowed then begin Result := 'Error: Access denied - path outside allowed directory'; Exit; end; - + if TDirectory.Exists(NormalizedPath) then begin FileArray := TDirectory.GetFiles(NormalizedPath); @@ -83,7 +89,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; @@ -96,7 +102,7 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin end; initialization - TMCPRegistry.RegisterTool('list_files', + TMCPRegistry.RegisterTool(TOOL_NAME, function: IMCPTool begin Result := TListFilesTool.Create; diff --git a/src/Tools/MCPServer.Tool.Method.pas b/src/Tools/MCPServer.Tool.Method.pas new file mode 100644 index 0000000..499e5d2 --- /dev/null +++ b/src/Tools/MCPServer.Tool.Method.pas @@ -0,0 +1,290 @@ +unit MCPServer.Tool.Method; + +interface + +uses + System.Rtti, + System.JSON, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Tool.Base; + +type + TMCPMethodTool = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) + protected + FContext: TRttiContext; + FInstance: TValue; + FMethod: TRttiMethod; + FName: string; + FTitle: string; + FDescription: string; + FAnnotations: TJSONObject; + FIcons: TJSONArray; + FInputSchema: TJSONObject; + + function MarshalArgument(const Param: TRttiParameter; const Arguments: TJSONObject; + const Owned: TList): TValue; virtual; + function ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; virtual; + procedure ReleaseResult(const Value: TValue; const ResultType: TRttiType); virtual; + procedure ReleaseArguments(const Owned: TList); virtual; + + procedure ValidateArguments(const Arguments: TJSONObject); + function MarshalArguments(const Arguments: TJSONObject; + const Owned: TList): TArray; + function InvokeToJson(const Arguments: TJSONObject): TJSONValue; + public + constructor Create(const Instance: TValue; const Method: TRttiMethod; + const Name, Description: string); + destructor Destroy; override; + + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetInputSchema: TJSONObject; + function GetOutputSchema: TJSONObject; virtual; + function Execute(const Arguments: TJSONObject): TValue; + + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; + + procedure MarkReadOnly(const OpenWorld: Boolean = False); + end; + +implementation + +uses + System.SysUtils, + System.TypInfo, + MCPServer.Schema.Generator, + MCPServer.Schema.Validator, + MCPServer.Serializer; + +const + RESULT_KEY_OK = 'ok'; + +function ParameterWireName(const Param: TRttiParameter): string; +begin + for var Attr in Param.GetAttributes do + if Attr is SchemaNameAttribute then + Exit(SchemaNameAttribute(Attr).Name); + + Result := LowerCase(Param.Name); +end; + +function IsObjectElementArray(const RttiType: TRttiType): Boolean; +begin + if RttiType.TypeKind <> tkDynArray then + Exit(False); + + const ElementType = TRttiDynamicArrayType(RttiType).ElementType; + Result := Assigned(ElementType) and (ElementType.TypeKind = tkClass); +end; + +{ TMCPMethodTool } + +constructor TMCPMethodTool.Create(const Instance: TValue; const Method: TRttiMethod; + const Name, Description: string); +begin + inherited Create; + + if not Assigned(Method) then + raise EArgumentNilException.Create('A method tool needs a method'); + + FContext := TRttiContext.Create; + FContext.GetType(TypeInfo(TObject)); + + FInstance := Instance; + FMethod := Method; + FName := Name; + FDescription := Description; + FInputSchema := TMCPSchemaGenerator.GenerateSchemaFromMethod(Method); +end; + +destructor TMCPMethodTool.Destroy; +begin + FInputSchema.Free; + FAnnotations.Free; + FIcons.Free; + FContext.Free; + inherited; +end; + +function TMCPMethodTool.GetName: string; +begin + Result := FName; +end; + +function TMCPMethodTool.GetTitle: string; +begin + if FTitle <> '' then + Result := FTitle + else + Result := FName; +end; + +function TMCPMethodTool.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPMethodTool.GetInputSchema: TJSONObject; +begin + Result := TJSONObject(FInputSchema.Clone); +end; + +function TMCPMethodTool.GetOutputSchema: TJSONObject; +begin + Result := TMCPSchemaGenerator.GenerateSchemaFromMethodResult(FMethod); +end; + +function TMCPMethodTool.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPMethodTool.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +procedure TMCPMethodTool.MarkReadOnly(const OpenWorld: Boolean); +begin + TMCPToolAnnotationWriter.ReadOnly(FAnnotations, OpenWorld); +end; + +procedure TMCPMethodTool.ValidateArguments(const Arguments: TJSONObject); +begin + var OwnedArguments: TJSONObject := nil; + var Effective := Arguments; + if not Assigned(Effective) then + begin + OwnedArguments := TJSONObject.Create; + Effective := OwnedArguments; + end; + + try + var Errors: TArray; + if not TMCPSchemaValidator.TryValidate(FInputSchema, Effective, Errors) then + raise EArgumentException.Create(string.Join('; ', Errors)); + finally + OwnedArguments.Free; + end; +end; + +function TMCPMethodTool.MarshalArgument(const Param: TRttiParameter; const Arguments: TJSONObject; + const Owned: TList): TValue; +begin + const WireName = ParameterWireName(Param); + + var JsonValue: TJSONValue := nil; + if Assigned(Arguments) then + JsonValue := Arguments.GetValue(WireName); + + const IsAbsent = not Assigned(JsonValue) or (JsonValue is TJSONNull); + if IsAbsent then + begin + TValue.Make(nil, Param.ParamType.Handle, Result); + Exit; + end; + + try + Result := TMCPSerializer.JsonToValue(JsonValue, Param.ParamType, Owned); + except + on E: EArgumentException do + raise EArgumentException.CreateFmt('Parameter "%s": %s', [WireName, E.Message]); + end; +end; + +function TMCPMethodTool.MarshalArguments(const Arguments: TJSONObject; + const Owned: TList): TArray; +begin + const Parameters = FMethod.GetParameters; + SetLength(Result, Length(Parameters)); + for var Index := 0 to High(Parameters) do + Result[Index] := MarshalArgument(Parameters[Index], Arguments, Owned); +end; + +function TMCPMethodTool.ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; +begin + Result := TJSONObject.Create; + try + if not Assigned(ResultType) then + begin + TJSONObject(Result).AddPair(RESULT_KEY_OK, TJSONBool.Create(True)); + Exit; + end; + + var Converted := TMCPSerializer.ValueToJson(Value, ResultType); + if not Assigned(Converted) then + Converted := TJSONNull.Create; + TJSONObject(Result).AddPair(MCP_KEY_RESULT, Converted); + except + Result.Free; + raise; + end; +end; + +procedure TMCPMethodTool.ReleaseResult(const Value: TValue; const ResultType: TRttiType); +begin + if not Assigned(ResultType) or Value.IsEmpty then + Exit; + + if ResultType.TypeKind = tkClass then + begin + if Value.IsObject then + Value.AsObject.Free; + Exit; + end; + + if not IsObjectElementArray(ResultType) then + Exit; + + for var Index := 0 to Value.GetArrayLength - 1 do + begin + const Element = Value.GetArrayElement(Index); + if Element.IsObject then + Element.AsObject.Free; + end; +end; + +procedure TMCPMethodTool.ReleaseArguments(const Owned: TList); +begin + for var Item in Owned do + begin + Item.Free; + end; +end; + +function TMCPMethodTool.InvokeToJson(const Arguments: TJSONObject): TJSONValue; +begin + const Owned = TList.Create; + try + var Args := MarshalArguments(Arguments, Owned); + const ReturnType = FMethod.ReturnType; + var ReturnValue := FMethod.Invoke(FInstance, Args); + try + Result := ResultToJson(ReturnValue, ReturnType); + finally + ReleaseResult(ReturnValue, ReturnType); + end; + finally + ReleaseArguments(Owned); + Owned.Free; + end; +end; + +function TMCPMethodTool.Execute(const Arguments: TJSONObject): TValue; +begin + ValidateArguments(Arguments); + + const Json = InvokeToJson(Arguments); + if not (Json is TJSONObject) then + begin + Json.Free; + raise EInvalidOpException.CreateFmt('%s.ResultToJson must return a TJSONObject', [ClassName]); + end; + + Result := TValue.From(TJSONObject(Json)); +end; + +end. diff --git a/src/Tools/MCPServer.Tool.Result.pas b/src/Tools/MCPServer.Tool.Result.pas new file mode 100644 index 0000000..d2775c6 --- /dev/null +++ b/src/Tools/MCPServer.Tool.Result.pas @@ -0,0 +1,203 @@ +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; + FPendingAnnotations: TJSONObject; + FStructuredContent: TJSONValue; + FMeta: TJSONObject; + FIsError: Boolean; + procedure AddBlock(const Block: TJSONObject); + 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 + FPendingAnnotations.Free; + FContent.Free; + FStructuredContent.Free; + FMeta.Free; + inherited; +end; + +function TMCPToolResult.AddText(const Text: string): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.Text(Text)); + Result := Self; +end; + +function TMCPToolResult.AddImage(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddImage(TMCPContentBlock.EncodeBlob(Data), MimeType); +end; + +function TMCPToolResult.AddImage(const Base64Data, MimeType: string): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.Image(Base64Data, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddAudio(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddAudio(TMCPContentBlock.EncodeBlob(Data), MimeType); +end; + +function TMCPToolResult.AddAudio(const Base64Data, MimeType: string): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.Audio(Base64Data, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddResourceLink(const Uri, Name, Description, MimeType: string): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.ResourceLink(Uri, Name, Description, MimeType)); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.EmbeddedText(Uri, MimeType, Text)); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; +begin + AddBlock(TMCPContentBlock.EmbeddedBlob(Uri, MimeType, TMCPContentBlock.EncodeBlob(Data))); + Result := Self; +end; + +procedure TMCPToolResult.AddBlock(const Block: TJSONObject); +begin + FContent.AddElement(Block); + if Assigned(FPendingAnnotations) then + begin + Block.AddPair(MCP_KEY_ANNOTATIONS, FPendingAnnotations); + FPendingAnnotations := nil; + end; +end; + +function TMCPToolResult.WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; +begin + const HasBlock = (FContent.Count > 0); + if HasBlock then + TJSONObject(FContent.Items[FContent.Count - 1]).AddPair(MCP_KEY_ANNOTATIONS, Annotations) + else + begin + FPendingAnnotations.Free; + FPendingAnnotations := Annotations; + end; + 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(MCP_KEY_TYPE, 'text'); + Block.AddPair(MCP_KEY_TEXT, FStructuredContent.ToJSON); + Result.AddElement(Block); + end; +end; + +function TMCPToolResult.ToJson(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TJSONObject.Create; + try + Result.AddPair(MCP_KEY_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(MCP_KEY_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..2020574 --- /dev/null +++ b/src/Tools/MCPServer.Tool.SubscriptionSamples.pas @@ -0,0 +1,184 @@ +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 + TOOL_TRIGGER_TOOL_CHANGE = 'test_trigger_tool_change'; + TOOL_TRIGGER_PROMPT_CHANGE = 'test_trigger_prompt_change'; + TOOL_TRIGGER_RESOURCE_CHANGE = 'test_trigger_resource_change'; + MESSAGE_REMOVED = 'Removed %s'; + MESSAGE_ADDED = 'Added %s'; + 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 := TOOL_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(MCP_METHOD_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(MESSAGE_REMOVED, [DYNAMIC_TOOL_NAME])); + end + else + begin + Tools.AddTool(TDynamicTool.Create); + Result := TMCPToolResult.Text(Format(MESSAGE_ADDED, [DYNAMIC_TOOL_NAME])); + end; +end; + +{ TTriggerPromptChangeTool } + +constructor TTriggerPromptChangeTool.Create; +begin + inherited; + FName := TOOL_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(MCP_METHOD_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(MESSAGE_REMOVED, [DYNAMIC_PROMPT_NAME])); + end + else + begin + Prompts.AddPrompt(TDynamicPrompt.Create); + Result := TMCPToolResult.Text(Format(MESSAGE_ADDED, [DYNAMIC_PROMPT_NAME])); + end; +end; + +{ TTriggerResourceChangeTool } + +constructor TTriggerResourceChangeTool.Create; +begin + inherited; + FName := TOOL_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(MCP_METHOD_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(TOOL_TRIGGER_TOOL_CHANGE, + function: IMCPTool + begin + Result := TTriggerToolChangeTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_TRIGGER_PROMPT_CHANGE, + function: IMCPTool + begin + Result := TTriggerPromptChangeTool.Create; + end); + TMCPRegistry.RegisterTool(TOOL_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..498708b --- /dev/null +++ b/tests/MCPServer.Tests.Authorization.pas @@ -0,0 +1,293 @@ +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 TryValidateToken(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): TMCPAuthResult; + 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.TryValidateToken(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): TMCPAuthResult; +begin + Result := Authorizer.Authorize(Token, 'POST', '/mcp'); +end; + +procedure TAuthorizationTests.StaticBearer_AcceptsListedTokens_RejectsOthers; +begin + var Authorizer: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha', ' beta ']); + var First := Decide(Authorizer, 'alpha'); + Assert.AreEqual(TMCPAuthDecision.Allow, First.Decision); + Assert.AreEqual('token-1', First.Principal.Subject); + Assert.IsTrue(First.Principal.HasScope('anything'), 'pre-shared tokens grant every scope'); + + var Second := Decide(Authorizer, 'beta'); + Assert.AreEqual(TMCPAuthDecision.Allow, Second.Decision); + Assert.AreEqual('token-2', Second.Principal.Subject); + + var Unknown := Decide(Authorizer, 'alph'); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Unknown.Decision); + Assert.AreEqual('invalid_token', Unknown.Challenge.Error); + Assert.AreEqual('', Unknown.Principal.Subject); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, '').Decision); + + var Scoped: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha'], ['read']); + var Limited := Decide(Scoped, 'alpha'); + Assert.AreEqual(TMCPAuthDecision.Allow, Limited.Decision); + Assert.IsTrue(Limited.Principal.HasScope('read')); + Assert.IsFalse(Limited.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; +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])); + var Rejected := Decide(Invalid, 'nope'); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Rejected.Decision); + Assert.AreEqual('invalid_token', Rejected.Challenge.Error); + + var WrongAudience: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"https://other","exp":%d}', [Future])); + var ForAnother := Decide(WrongAudience, 'valid'); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, ForAnother.Decision); + Assert.IsTrue(ForAnother.Challenge.ErrorDescription.Contains('not issued for this server'), + ForAnother.Challenge.ErrorDescription); + + var Expired: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d}', [AUDIENCE, Past])); + var Stale := Decide(Expired, 'valid'); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Stale.Decision); + Assert.IsTrue(Stale.Challenge.ErrorDescription.Contains('expired'), Stale.Challenge.ErrorDescription); + + var NoExpiry: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s"}', [AUDIENCE])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(NoExpiry, 'valid').Decision, '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']; + var Denied := Decide(ScopedRef, 'valid'); + Assert.AreEqual(TMCPAuthDecision.Forbidden, Denied.Decision); + Assert.AreEqual('insufficient_scope', Denied.Challenge.Error); + Assert.AreEqual('read write', Denied.Challenge.Scope); + + Scoped.RequiredScopes := ['read']; + var Allowed := Decide(ScopedRef, 'valid'); + Assert.AreEqual(TMCPAuthDecision.Allow, Allowed.Decision); + Assert.AreEqual('u', Allowed.Principal.Subject); + Assert.IsTrue(Allowed.Principal.HasScope('read')); + Assert.IsFalse(Allowed.Principal.HasScope('write')); +end; + +procedure TAuthorizationTests.OAuth_AcceptsAudienceArray_AndScopeArray; +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])); + var Outcome := Decide(Authorizer, 'valid'); + Assert.AreEqual(TMCPAuthDecision.Allow, Outcome.Decision); + Assert.IsTrue(Outcome.Principal.HasScope('a')); + Assert.IsTrue(Outcome.Principal.HasScope('b')); + Assert.IsFalse(Outcome.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; +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'); + var Active := Decide(Authorizer, 'good'); + Assert.AreEqual(TMCPAuthDecision.Allow, Active.Decision); + Assert.AreEqual('alice', Active.Principal.Subject); + Assert.IsTrue(Active.Principal.HasScope('read')); + Assert.AreEqual('token=good', FSeenBody); + Assert.IsTrue(FSeenAuthorization.StartsWith('Basic '), FSeenAuthorization); + + var Stale := Decide(Authorizer, 'stale'); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Stale.Decision); + Assert.AreEqual('invalid_token', Stale.Challenge.Error); +end; + +end. diff --git a/tests/MCPServer.Tests.Cancellation.pas b/tests/MCPServer.Tests.Cancellation.pas new file mode 100644 index 0000000..33e5134 --- /dev/null +++ b/tests/MCPServer.Tests.Cancellation.pas @@ -0,0 +1,348 @@ +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, + System.Diagnostics; + +{ 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; + const HasMetaJson = (MetaJson <> ''); + if HasMetaJson 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"}'); + const Watch = TStopwatch.StartNew; + Context.ReportProgress(1, 10); + Context.ReportProgress(0.5, 10); + Assert.AreEqual(1, FMessages.Count, 'a smaller value is dropped'); + + Context.ReportProgress(2, 10); + const StayedInsideTheInterval = (Watch.ElapsedMilliseconds < PROGRESS_MIN_INTERVAL_MS); + if StayedInsideTheInterval then + Assert.AreEqual(1, FMessages.Count, 'a burst within the interval is dropped'); + + const BeforeTotal = FMessages.Count; + Context.ReportProgress(10, 10); + Assert.AreEqual(BeforeTotal + 1, FMessages.Count, 'reaching the total is always sent'); + + Sleep(PROGRESS_MIN_INTERVAL_MS + 20); + const BeforeNext = FMessages.Count; + Context.ReportProgress(11); + Assert.AreEqual(BeforeNext + 1, 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..5aaa194 --- /dev/null +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -0,0 +1,105 @@ +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.JSON, + MCPServer.Types, + MCPServer.Capabilities, + MCPServer.Tests.Harness, + System.Generics.Collections; + +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..b8d35f2 --- /dev/null +++ b/tests/MCPServer.Tests.CompletionManager.pas @@ -0,0 +1,236 @@ +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 + begin + Assert.IsTrue(Value.Value.ToUpper.StartsWith('IN'), 'every suggestion starts with the typed prefix'); + end; + 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..8842185 --- /dev/null +++ b/tests/MCPServer.Tests.Constants.pas @@ -0,0 +1,124 @@ +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..370d31a --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -0,0 +1,353 @@ +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..672b1cc --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Modern.pas @@ -0,0 +1,190 @@ +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..f7aebe1 --- /dev/null +++ b/tests/MCPServer.Tests.Golden.pas @@ -0,0 +1,428 @@ +unit MCPServer.Tests.Golden; + +interface + +uses + System.SysUtils, + System.Classes, + 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, + System.Generics.Collections, + DUnitX.TestFramework; + +const + MAX_PARENT_LEVELS = 6; + +{ TGoldenFiles } + +class function TGoldenFiles.GoldenRoot: string; +begin + Result := GetEnvironmentVariable(GOLDEN_DIR_ENVIRONMENT_VARIABLE); + const HasResult = (Result <> ''); + if HasResult 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 + begin + Inc(I); + end; + 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 + begin + Obj.AddPair(Pair.JsonString.Value, Shape(Pair.JsonValue)); + end; + Result := Obj; + end + else if Value is TJSONArray then + begin + var Arr := TJSONArray.Create; + for var Item in TJSONArray(Value) do + begin + Arr.AddElement(Shape(Item)); + end; + 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; + const HasPath = (Path <> ''); + if HasPath 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 + begin + Result[I] := Arr.Items[I].Value; + end; +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; + const HasResponseBody = (ResponseBody.Trim <> ''); + if HasResponseBody 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; + const HasWorkingDirectory = (GoldenCase.WorkingDirectory <> ''); + if HasWorkingDirectory 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); + Assert.AreEqual(Expected, Actual, Format('golden %s/%s', [Suite, CaseName])); + 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.HeaderEncoding.pas b/tests/MCPServer.Tests.HeaderEncoding.pas new file mode 100644 index 0000000..e531cfa --- /dev/null +++ b/tests/MCPServer.Tests.HeaderEncoding.pas @@ -0,0 +1,133 @@ +unit MCPServer.Tests.HeaderEncoding; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + THeaderEncodingTests = class + public + [Test] + procedure HeaderConstants_HaveSpecNames; + + [Test] + procedure Encode_PlainAsciiValue_IsVerbatim; + + [Test] + procedure Encode_EmptyValue_IsVerbatim; + + [Test] + procedure Encode_NonAsciiValue_RoundTrips; + + [Test] + procedure Encode_ControlCharacters_RoundTrip; + + [Test] + procedure Encode_LiteralSentinelPattern_RoundTrips; + + [Test] + procedure Encode_MatchesTheSpecTable; + + [Test] + procedure Encode_LongNonAsciiValue_StaysOnOneLine; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Types, + MCPServer.HttpHeaders; + +const + WORLD = #$4E16#$754C; + +{ THeaderEncodingTests } + +procedure THeaderEncodingTests.HeaderConstants_HaveSpecNames; +begin + Assert.AreEqual('Mcp-Session-Id', MCP_HEADER_SESSION_ID); + Assert.AreEqual('MCP-Protocol-Version', MCP_HEADER_PROTOCOL_VERSION); + Assert.AreEqual('Mcp-Method', MCP_HEADER_METHOD); + Assert.AreEqual('Mcp-Name', MCP_HEADER_NAME); +end; + +procedure THeaderEncodingTests.Encode_PlainAsciiValue_IsVerbatim; +begin + Assert.AreEqual('us-west1', TMCPHeaderValue.Encode('us-west1')); + Assert.AreEqual('file:///projects/myapp/config.json', + TMCPHeaderValue.Encode('file:///projects/myapp/config.json')); + Assert.AreEqual('tools/call', TMCPHeaderValue.Encode('tools/call')); +end; + +procedure THeaderEncodingTests.Encode_EmptyValue_IsVerbatim; +begin + Assert.AreEqual('', TMCPHeaderValue.Encode('')); + + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode(TMCPHeaderValue.Encode(''), Decoded)); + Assert.AreEqual('', Decoded); +end; + +procedure THeaderEncodingTests.Encode_NonAsciiValue_RoundTrips; +begin + const Original = 'Hello, ' + WORLD; + const Encoded = TMCPHeaderValue.Encode(Original); + + Assert.IsTrue(TMCPHeaderValue.IsSentinel(Encoded), 'a non-ASCII value must be wrapped'); + Assert.IsTrue(TMCPHeaderValue.IsHeaderSafe(Encoded), 'the wrapped value must be header safe'); + + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode(Encoded, Decoded)); + Assert.AreEqual(Original, Decoded); +end; + +procedure THeaderEncodingTests.Encode_ControlCharacters_RoundTrip; +begin + const Original = 'line1'#10'line2'; + const Encoded = TMCPHeaderValue.Encode(Original); + + Assert.IsTrue(TMCPHeaderValue.IsSentinel(Encoded)); + + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode(Encoded, Decoded)); + Assert.AreEqual(Original, Decoded); +end; + +procedure THeaderEncodingTests.Encode_LiteralSentinelPattern_RoundTrips; +begin + const Original = '=?base64?literal?='; + const Encoded = TMCPHeaderValue.Encode(Original); + + Assert.AreNotEqual(Original, Encoded, 'a value that looks like a sentinel must be wrapped'); + Assert.AreEqual('=?base64?PT9iYXNlNjQ/bGl0ZXJhbD89?=', Encoded); + + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode(Encoded, Decoded)); + Assert.AreEqual(Original, Decoded); +end; + +procedure THeaderEncodingTests.Encode_MatchesTheSpecTable; +begin + Assert.AreEqual('=?base64?SGVsbG8sIOS4lueVjA==?=', TMCPHeaderValue.Encode('Hello, ' + WORLD)); + Assert.AreEqual('=?base64?bGluZTEKbGluZTI=?=', TMCPHeaderValue.Encode('line1'#10'line2')); +end; + +procedure THeaderEncodingTests.Encode_LongNonAsciiValue_StaysOnOneLine; +begin + var Original := ''; + for var I := 1 to 80 do + Original := Original + WORLD; + + const Encoded = TMCPHeaderValue.Encode(Original); + Assert.AreEqual(-1, Encoded.IndexOf(#13), 'the base64 payload must not be wrapped'); + Assert.AreEqual(-1, Encoded.IndexOf(#10), 'the base64 payload must not be wrapped'); + + var Decoded: string; + Assert.IsTrue(TMCPHeaderValue.TryDecode(Encoded, Decoded)); + Assert.AreEqual(Original, Decoded); +end; + +end. diff --git a/tests/MCPServer.Tests.Host.pas b/tests/MCPServer.Tests.Host.pas new file mode 100644 index 0000000..61a2b71 --- /dev/null +++ b/tests/MCPServer.Tests.Host.pas @@ -0,0 +1,557 @@ +unit MCPServer.Tests.Host; + +interface + +uses + DUnitX.TestFramework, + System.Rtti, + System.JSON, + MCPServer.Tool.Base, + MCPServer.Resource.Base, + MCPServer.Prompt.Base, + MCPServer.Host; + +type + TNamedTool = class(TMCPToolBase) + protected + function BuildSchema: TJSONObject; override; + function DoExecute(const Arguments: TJSONObject): TValue; override; + public + constructor CreateNamed(const AName: string); + end; + + TNamedResourceData = class + private + FValue: string; + public + property Value: string read FValue write FValue; + end; + + TNamedResource = class(TMCPResourceBase) + protected + function GetResourceData: TNamedResourceData; override; + public + constructor CreateNamed(const AUri: string); + end; + + TNamedPromptParams = class + private + FText: string; + public + property Text: string read FText write FText; + end; + + TNamedPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNamedPromptParams; Messages: TMCPPromptMessages): string; override; + public + constructor CreateNamed(const AName: string); + end; + + [TestFixture] + TServerHostTests = class + private + FHost: TMCPServerHost; + FOther: TMCPServerHost; + function PostTo(const Url: string): string; + function ToolNamesOverHttp: TArray; + function NamesOverStdio(const Host: TMCPServerHost; + const Method, ListKey, NameKey: string): TArray; + function ToolNamesOverStdio(const Host: TMCPServerHost): TArray; + function ResourceUrisOverStdio(const Host: TMCPServerHost): TArray; + function TemplateUrisOverStdio(const Host: TMCPServerHost): TArray; + function PromptNamesOverStdio(const Host: TMCPServerHost): TArray; + function ToolNamesOf(const Response: string): TArray; + procedure StartOnAnyPort; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure Default_PublishesNoToolAtAll; + + [Test] + procedure Default_PublishesNoResourceTemplateOrPrompt; + + [Test] + procedure TwoHostsInOneProcess_HaveDisjointToolSets; + + [Test] + procedure TwoHostsInOneProcess_HaveDisjointResourceAndPromptSets; + + [Test] + procedure SeedFromGlobalRegistry_TakesTheGlobalTools; + + [Test] + procedure SeedFromGlobalRegistry_TakesTheGlobalResourcesTemplatesAndPrompts; + + [Test] + procedure DiagnosticsResourcesOff_DropsThemFromASeededHost; + + [Test] + procedure DiagnosticsResourcesOn_KeepsThemOnASeededHost; + + [Test] + procedure SeedFromGlobalRegistry_AfterTheManagersExist_IsAConfigurationError; + + [Test] + procedure RemoveTool_TakesTheToolBackOut; + + [Test] + procedure Create_WithoutSettings_ReadsNoSettingsFile; + + [Test] + procedure Create_WithASettingsFile_ReadsThatFile; + + [Test] + procedure Create_WithSettings_UsesThemAndLeavesThemToTheCaller; + + [Test] + procedure StartHttp_OnPortZero_ReportsTheBoundPort; + + [Test] + procedure StartHttp_OnPortZero_AnswersTheHostNameOnEveryLoopbackFamily; + + [Test] + procedure StartHttp_IsIdempotent; + + [Test] + procedure Stop_IsIdempotent_BeforeAndAfterStart; + + [Test] + procedure ToolsList_OverHttp_ListsOnlyTheAddedTools; + + [Test] + procedure ToolsList_OverStdioStreams_ListsTheSameTools; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + System.IOUtils, + IdHTTP, + IdStack, + MCPServer.Errors, + MCPServer.Registration, + MCPServer.Settings, + MCPServer.Tests.Support; + +const + TOOLS_LIST = '{"jsonrpc":"2.0","id":1,"method":"tools/list"}'; + URI_SERVER_STATUS = 'server://status'; + URI_LOGS_RECENT = 'logs://recent'; + URI_TEMPLATE_LOGS_BY_LEVEL = 'logs://{level}'; + SETTINGS_WITH_ANOTHER_PORT = '[Server]'#13#10'Port=4242'#13#10; + ANOTHER_PORT = 4242; + DEFAULT_PORT = 3000; + +{ TNamedTool } + +constructor TNamedTool.CreateNamed(const AName: string); +begin + inherited Create; + FName := AName; + FDescription := 'A tool handed to a single host'; +end; + +function TNamedTool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{},"additionalProperties":false}') as TJSONObject; +end; + +function TNamedTool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From(FName + ' ran'); +end; + +{ TNamedResource } + +constructor TNamedResource.CreateNamed(const AUri: string); +begin + inherited Create; + FURI := AUri; + FName := 'A resource handed to a single host'; + FMimeType := 'application/json'; +end; + +function TNamedResource.GetResourceData: TNamedResourceData; +begin + Result := TNamedResourceData.Create; + Result.Value := FURI; +end; + +{ TNamedPrompt } + +constructor TNamedPrompt.CreateNamed(const AName: string); +begin + inherited Create; + FName := AName; + FDescription := 'A prompt handed to a single host'; +end; + +function TNamedPrompt.ExecuteWithParams(const Params: TNamedPromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', FName); + Result := FName; +end; + +{ TServerHostTests } + +procedure TServerHostTests.Setup; +begin + FHost := TMCPServerHost.Create; + FHost.Settings.Port := 0; + FHost.Settings.CorsEnabled := False; + FOther := nil; +end; + +procedure TServerHostTests.TearDown; +begin + FOther.Free; + FHost.Free; +end; + +procedure TServerHostTests.StartOnAnyPort; +begin + FHost.StartHttp; +end; + +function TServerHostTests.ToolNamesOf(const Response: string): TArray; +begin + Result := nil; + const Json = TMCPTestJson.ParseObject(Response); + try + const Outcome = Json.GetValue('result') as TJSONObject; + Assert.IsNotNull(Outcome, 'the response carries no result: ' + Response); + for var Tool in Outcome.GetValue('tools') as TJSONArray do + begin + Result := Result + [(Tool as TJSONObject).GetValue('name')]; + end; + finally + Json.Free; + end; +end; + +function TServerHostTests.PostTo(const Url: string): string; +begin + const Http = TIdHTTP.Create(nil); + const Request = TStringStream.Create(TOOLS_LIST, TEncoding.UTF8); + try + Http.Request.ContentType := 'application/json'; + Http.Request.Accept := 'application/json'; + Result := Http.Post(Url, Request); + finally + Request.Free; + Http.Free; + end; +end; + +function TServerHostTests.ToolNamesOverHttp: TArray; +begin + if not FHost.Active then + StartOnAnyPort; + + Result := ToolNamesOf(PostTo(Format('http://127.0.0.1:%d/mcp', [FHost.BoundPort]))); +end; + +function TServerHostTests.NamesOverStdio(const Host: TMCPServerHost; + const Method, ListKey, NameKey: string): TArray; +begin + Result := nil; + const Request = Format('{"jsonrpc":"2.0","id":1,"method":"%s"}', [Method]); + const Input = TStringStream.Create(Request + #10, TEncoding.UTF8); + const Output = TStringStream.Create('', TEncoding.UTF8); + try + Host.RunStdioWith(Input, Output); + const Lines = Output.DataString.Split([#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(1, Integer(Length(Lines)), 'stdio answered with more than one line: ' + Output.DataString); + + const Json = TMCPTestJson.ParseObject(Lines[0]); + try + const Outcome = Json.GetValue('result') as TJSONObject; + Assert.IsNotNull(Outcome, 'the response carries no result: ' + Lines[0]); + for var Entry in Outcome.GetValue(ListKey) as TJSONArray do + begin + Result := Result + [(Entry as TJSONObject).GetValue(NameKey)]; + end; + finally + Json.Free; + end; + finally + Output.Free; + Input.Free; + end; +end; + +function TServerHostTests.ToolNamesOverStdio(const Host: TMCPServerHost): TArray; +begin + Result := NamesOverStdio(Host, 'tools/list', 'tools', 'name'); +end; + +function TServerHostTests.ResourceUrisOverStdio(const Host: TMCPServerHost): TArray; +begin + Result := NamesOverStdio(Host, 'resources/list', 'resources', 'uri'); +end; + +function TServerHostTests.TemplateUrisOverStdio(const Host: TMCPServerHost): TArray; +begin + Result := NamesOverStdio(Host, 'resources/templates/list', 'resourceTemplates', 'uriTemplate'); +end; + +function TServerHostTests.PromptNamesOverStdio(const Host: TMCPServerHost): TArray; +begin + Result := NamesOverStdio(Host, 'prompts/list', 'prompts', 'name'); +end; + +procedure TServerHostTests.Default_PublishesNoToolAtAll; +begin + Assert.IsTrue(Length(TMCPRegistry.GetToolNames) > 0, 'no tool is registered globally, so the test proves nothing'); + Assert.AreEqual(0, Integer(Length(ToolNamesOverStdio(FHost))), 'a fresh host publishes a tool it was never given'); +end; + +procedure TServerHostTests.Default_PublishesNoResourceTemplateOrPrompt; +begin + Assert.IsTrue(Length(TMCPRegistry.GetResourceURIs) > 0, 'no resource is registered globally, so the test proves nothing'); + Assert.IsTrue(Length(TMCPRegistry.GetResourceTemplateURIs) > 0, 'no resource template is registered globally'); + Assert.IsTrue(Length(TMCPRegistry.GetPromptNames) > 0, 'no prompt is registered globally'); + + Assert.AreEqual(0, Integer(Length(ResourceUrisOverStdio(FHost))), + 'a fresh host publishes a resource it was never given'); + Assert.AreEqual(0, Integer(Length(TemplateUrisOverStdio(FHost))), + 'a fresh host publishes a resource template it was never given'); + Assert.AreEqual(0, Integer(Length(PromptNamesOverStdio(FHost))), + 'a fresh host publishes a prompt it was never given'); +end; + +procedure TServerHostTests.TwoHostsInOneProcess_HaveDisjointToolSets; +begin + FOther := TMCPServerHost.Create; + + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + FOther.AddTool(TNamedTool.CreateNamed('second_tool')); + + Assert.IsTrue(FHost.HasTool('first_tool')); + Assert.IsFalse(FHost.HasTool('second_tool'), 'the first host sees the second host tool'); + Assert.IsTrue(FOther.HasTool('second_tool')); + Assert.IsFalse(FOther.HasTool('first_tool'), 'the second host sees the first host tool'); + + Assert.AreEqual('first_tool', string.Join(',', ToolNamesOverStdio(FHost))); + Assert.AreEqual('second_tool', string.Join(',', ToolNamesOverStdio(FOther))); +end; + +procedure TServerHostTests.TwoHostsInOneProcess_HaveDisjointResourceAndPromptSets; +begin + FOther := TMCPServerHost.Create; + + FHost.AddResource(TNamedResource.CreateNamed('first://resource')); + FHost.AddPrompt(TNamedPrompt.CreateNamed('first_prompt')); + FOther.AddResource(TNamedResource.CreateNamed('second://resource')); + FOther.AddPrompt(TNamedPrompt.CreateNamed('second_prompt')); + + Assert.AreEqual('first://resource', string.Join(',', ResourceUrisOverStdio(FHost))); + Assert.AreEqual('first_prompt', string.Join(',', PromptNamesOverStdio(FHost))); + Assert.AreEqual('second://resource', string.Join(',', ResourceUrisOverStdio(FOther))); + Assert.AreEqual('second_prompt', string.Join(',', PromptNamesOverStdio(FOther))); +end; + +procedure TServerHostTests.SeedFromGlobalRegistry_TakesTheGlobalTools; +begin + FHost.SeedFromGlobalRegistry := True; + Assert.AreEqual(Integer(Length(TMCPRegistry.GetToolNames)), Integer(Length(ToolNamesOverStdio(FHost)))); +end; + +procedure TServerHostTests.SeedFromGlobalRegistry_TakesTheGlobalResourcesTemplatesAndPrompts; +begin + FHost.SeedFromGlobalRegistry := True; + + Assert.AreEqual(Integer(Length(TMCPRegistry.GetResourceURIs)), + Integer(Length(ResourceUrisOverStdio(FHost)))); + Assert.AreEqual(Integer(Length(TMCPRegistry.GetResourceTemplateURIs)), + Integer(Length(TemplateUrisOverStdio(FHost)))); + Assert.AreEqual(Integer(Length(TMCPRegistry.GetPromptNames)), + Integer(Length(PromptNamesOverStdio(FHost)))); +end; + +procedure TServerHostTests.DiagnosticsResourcesOff_DropsThemFromASeededHost; +begin + FHost.Settings.ExposeDiagnosticsResources := False; + FHost.SeedFromGlobalRegistry := True; + + const Uris = string.Join(',', ResourceUrisOverStdio(FHost)); + const Templates = string.Join(',', TemplateUrisOverStdio(FHost)); + + Assert.IsFalse(Uris.Contains(URI_SERVER_STATUS), URI_SERVER_STATUS + ' survived ExposeDiagnosticsResources=False'); + Assert.IsFalse(Uris.Contains(URI_LOGS_RECENT), URI_LOGS_RECENT + ' survived ExposeDiagnosticsResources=False'); + Assert.IsFalse(Templates.Contains(URI_TEMPLATE_LOGS_BY_LEVEL), + URI_TEMPLATE_LOGS_BY_LEVEL + ' survived ExposeDiagnosticsResources=False'); + Assert.IsTrue(Uris <> '', 'the setting emptied the resource list instead of hiding the diagnostics'); +end; + +procedure TServerHostTests.DiagnosticsResourcesOn_KeepsThemOnASeededHost; +begin + FHost.SeedFromGlobalRegistry := True; + + const Uris = string.Join(',', ResourceUrisOverStdio(FHost)); + const Templates = string.Join(',', TemplateUrisOverStdio(FHost)); + + Assert.IsTrue(FHost.Settings.ExposeDiagnosticsResources, 'the diagnostics resources are exposed by default'); + Assert.IsTrue(Uris.Contains(URI_SERVER_STATUS), URI_SERVER_STATUS + ' is missing from a seeded host'); + Assert.IsTrue(Uris.Contains(URI_LOGS_RECENT), URI_LOGS_RECENT + ' is missing from a seeded host'); + Assert.IsTrue(Templates.Contains(URI_TEMPLATE_LOGS_BY_LEVEL), + URI_TEMPLATE_LOGS_BY_LEVEL + ' is missing from a seeded host'); +end; + +procedure TServerHostTests.SeedFromGlobalRegistry_AfterTheManagersExist_IsAConfigurationError; +begin + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + Assert.WillRaise( + procedure + begin + FHost.SeedFromGlobalRegistry := True; + end, EMCPConfigurationError); +end; + +procedure TServerHostTests.RemoveTool_TakesTheToolBackOut; +begin + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + FHost.RemoveTool('first_tool'); + Assert.IsFalse(FHost.HasTool('first_tool')); + Assert.AreEqual(0, Integer(Length(ToolNamesOverStdio(FHost)))); +end; + +procedure TServerHostTests.Create_WithoutSettings_ReadsNoSettingsFile; +begin + const NextToTheExecutable = TPath.Combine(TPath.GetDirectoryName(ParamStr(0)), 'settings.ini'); + const AlreadyThere = TFile.Exists(NextToTheExecutable); + var Saved := ''; + if AlreadyThere then + Saved := TFile.ReadAllText(NextToTheExecutable); + + TFile.WriteAllText(NextToTheExecutable, SETTINGS_WITH_ANOTHER_PORT); + try + const Host = TMCPServerHost.Create; + try + Assert.AreEqual('', Host.Settings.SettingsFile, 'a host given no settings named a settings file'); + Assert.AreEqual(DEFAULT_PORT, Host.Settings.Port, + 'a host given no settings read settings.ini from the executable directory'); + finally + Host.Free; + end; + finally + if AlreadyThere then + TFile.WriteAllText(NextToTheExecutable, Saved) + else + TFile.Delete(NextToTheExecutable); + end; +end; + +procedure TServerHostTests.Create_WithASettingsFile_ReadsThatFile; +begin + const Directory = TPath.Combine(TPath.GetTempPath, 'mcp-host-' + TGuid.NewGuid.ToString); + TDirectory.CreateDirectory(Directory); + try + const Path = TPath.Combine(Directory, 'settings.ini'); + TFile.WriteAllText(Path, SETTINGS_WITH_ANOTHER_PORT); + + const Host = TMCPServerHost.Create(Path); + try + Assert.AreEqual(Path, Host.Settings.SettingsFile); + Assert.AreEqual(ANOTHER_PORT, Host.Settings.Port, 'the host ignored the settings file it was given'); + finally + Host.Free; + end; + finally + TDirectory.Delete(Directory, True); + end; +end; + +procedure TServerHostTests.Create_WithSettings_UsesThemAndLeavesThemToTheCaller; +begin + const Settings = TMCPSettings.CreateDefaults; + try + Settings.Port := ANOTHER_PORT; + + const Host = TMCPServerHost.Create(Settings); + try + Assert.AreEqual(ANOTHER_PORT, Host.Settings.Port, 'the host ignored the settings it was given'); + finally + Host.Free; + end; + + Assert.AreEqual(ANOTHER_PORT, Settings.Port, 'the settings did not survive the host'); + finally + Settings.Free; + end; +end; + +procedure TServerHostTests.StartHttp_OnPortZero_ReportsTheBoundPort; +begin + Assert.AreEqual(0, Integer(FHost.BoundPort), 'a host that never started reports a port'); + StartOnAnyPort; + Assert.IsTrue(FHost.BoundPort > 0, 'StartHttp on port 0 reports no bound port'); + Assert.IsTrue(FHost.Active); +end; + +procedure TServerHostTests.StartHttp_OnPortZero_AnswersTheHostNameOnEveryLoopbackFamily; +begin + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + StartOnAnyPort; + + Assert.AreEqual('first_tool', + string.Join(',', ToolNamesOf(PostTo(Format('http://localhost:%d/mcp', [FHost.BoundPort])))), + 'the host name does not answer on the port the host reports'); + + if not GStack.SupportsIPv6 then + Exit; + + Assert.AreEqual('first_tool', + string.Join(',', ToolNamesOf(PostTo(Format('http://[::1]:%d/mcp', [FHost.BoundPort])))), + 'the IPv6 loopback, which localhost resolves to first on Windows, listens on another port'); +end; + +procedure TServerHostTests.StartHttp_IsIdempotent; +begin + StartOnAnyPort; + const FirstPort = FHost.BoundPort; + FHost.StartHttp; + Assert.AreEqual(Integer(FirstPort), Integer(FHost.BoundPort), 'the second StartHttp rebound the server'); + Assert.IsTrue(FHost.Active); + Assert.AreEqual(0, Integer(Length(ToolNamesOverHttp)), 'the server stopped answering after the second StartHttp'); +end; + +procedure TServerHostTests.Stop_IsIdempotent_BeforeAndAfterStart; +begin + FHost.Stop; + Assert.IsFalse(FHost.Active); + + StartOnAnyPort; + FHost.Stop; + FHost.Stop; + Assert.IsFalse(FHost.Active); +end; + +procedure TServerHostTests.ToolsList_OverHttp_ListsOnlyTheAddedTools; +begin + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + FHost.AddTool(TNamedTool.CreateNamed('second_tool')); + Assert.AreEqual('first_tool,second_tool', string.Join(',', ToolNamesOverHttp)); +end; + +procedure TServerHostTests.ToolsList_OverStdioStreams_ListsTheSameTools; +begin + FHost.AddTool(TNamedTool.CreateNamed('first_tool')); + FHost.AddTool(TNamedTool.CreateNamed('second_tool')); + + const OverHttp = string.Join(',', ToolNamesOverHttp); + const OverStdio = string.Join(',', ToolNamesOverStdio(FHost)); + Assert.AreEqual('first_tool,second_tool', OverStdio); + Assert.AreEqual(OverHttp, OverStdio, 'HTTP and stdio disagree about the tool set'); +end; + +end. diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas new file mode 100644 index 0000000..773b037 --- /dev/null +++ b/tests/MCPServer.Tests.Http.pas @@ -0,0 +1,841 @@ +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; + + [Test] + procedure Rejection_CarriesCorsHeaders; + end; + +implementation + +uses + System.Threading, + MCPServer.Tests.Support; + +const + MODERN_VERSION_HEADER = 'MCP-Protocol-Version: 2026-07-28'; + MODERN_META = TMCPTestMeta.MODERN_MEMBER; + 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 := TMCPTestJson.ParseObject(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 EArgumentException.CreateFmt('Unsupported HTTP method %s', [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); + + TMCPTestWait.UntilTrue( + function: Boolean + begin + Result := FHarness.SubscriptionsManager.ActiveCount > 0; + end); + 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; + +procedure THttpTransportTests.Rejection_CarriesCorsHeaders; +begin + FSettings.CorsEnabled := True; + var Denied := Post(LEGACY_PING, ['Origin: http://evil.example']); + Assert.AreEqual(403, Denied.Status); + Assert.AreEqual('http://evil.example', Denied.Header('Access-Control-Allow-Origin'), 'a browser can read the error'); + Assert.IsTrue(Denied.Header('Access-Control-Expose-Headers').Contains('WWW-Authenticate')); +end; + +end. diff --git a/tests/MCPServer.Tests.HttpCancellation.pas b/tests/MCPServer.Tests.HttpCancellation.pas new file mode 100644 index 0000000..4768045 --- /dev/null +++ b/tests/MCPServer.Tests.HttpCancellation.pas @@ -0,0 +1,300 @@ +unit MCPServer.Tests.HttpCancellation; + +// What cancels a running tool over HTTP, asserted against this server with nothing but an HTTP +// client, because both claims are about the server and not about whatever is calling it. +// +// README.md and MIGRATION.md state two things a reader is entitled to rely on: +// +// 1. Closing the response stream cancels the request. The server's next write to the stream +// fails, MCPServer.HttpStream cancels the request the tool is running, and the tool's +// IsCancelled turns True. +// 2. A notifications/cancelled naming a request that is still in flight arrives on a connection +// of its own, is answered 202 and is dropped, because the tracker a request consults is its +// own response stream. The running tool never hears about it and answers as it would have. +// +// TCancelWatchTool is what makes both visible. It reports progress on every step, which is what +// turns the response into a chunked event stream and what gives the server a write that can fail, +// and it records whether it saw its request cancelled or ran to the end. + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + System.Rtti, + DUnitX.TestFramework, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.Tool.Base, + MCPServer.Host; + +type + TNoParams = class + end; + + { Runs until the test releases it or its request is cancelled, and remembers which of the two + happened. } + TCancelWatchTool = class(TMCPToolBase) + strict private + FStarted: TEvent; + FRelease: TEvent; + FCancelSeen: TEvent; + FRequestId: string; + protected + function ExecuteWithContext(const Params: TNoParams; + const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + destructor Destroy; override; + + function WaitForStart(const TimeoutMs: Cardinal): Boolean; + function WaitForCancellation(const TimeoutMs: Cardinal): Boolean; + function SawCancellation: Boolean; + procedure Release; + + { The id the server gave this request, which is what a notifications/cancelled has to name. + Written before the start is signalled, so a test that waited for the start may read it. } + property RequestId: string read FRequestId; + end; + + [TestFixture] + TMCPHttpCancellationTests = class + private + FHost: TMCPServerHost; + FWatch: TCancelWatchTool; + FWatchTool: IMCPTool; + function Url: string; + function Post(const Body: string; out StatusCode: Integer): string; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure ADroppedConnection_CancelsTheRunningTool; + + [Test] + procedure ACancellationOnASecondConnection_IsAcceptedAndTheToolRunsOn; + end; + +implementation + +uses + IdHTTP, + IdTCPClient, + IdGlobal, + MCPServer.Errors, + MCPServer.Tool.Result; + +const + LOOPBACK = '127.0.0.1'; + ENDPOINT = '/mcp'; + URL_TEMPLATE = 'http://%s:%d%s'; + ACCEPT_STREAM = 'application/json, text/event-stream'; + + TOOL_CANCEL_WATCH = 'test_cancel_watch'; + + WATCH_STEPS = 200; + WATCH_STEP_MS = 25; + WATCH_WAIT_MS = 5000; + WATCH_STEP_MESSAGE = 'still working'; + WATCH_ANSWER = 'the watch tool ran to the end'; + + { The call both tests make. Nothing negotiates first: over HTTP a legacy request stands on its + own, which is what lets a raw socket send one. The progress token is not decoration: without + one ReportProgress sends nothing, the response stays a single JSON object, and there is no + stream to close. } + CALL_REQUEST = + '{"jsonrpc":"2.0","id":1,"method":"tools/call",' + + '"params":{"name":"' + TOOL_CANCEL_WATCH + '","arguments":{},' + + '"_meta":{"progressToken":"watch"}}}'; + + CANCEL_NOTIFICATION = + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":%s,' + + '"reason":"a second connection"}}'; + + { Long enough for the server to have written its first progress frame, so the write that fails + is a later one and not the first. } + STREAM_SETTLE_MS = 300; + +{ TCancelWatchTool } + +constructor TCancelWatchTool.Create; +begin + inherited; + FName := TOOL_CANCEL_WATCH; + FDescription := 'Reports progress until the caller goes away or the test releases it'; + FStarted := TEvent.Create(nil, True, False, ''); + FRelease := TEvent.Create(nil, True, False, ''); + FCancelSeen := TEvent.Create(nil, True, False, ''); +end; + +destructor TCancelWatchTool.Destroy; +begin + FCancelSeen.Free; + FRelease.Free; + FStarted.Free; + inherited; +end; + +function TCancelWatchTool.ExecuteWithContext(const Params: TNoParams; + const Context: IMCPRequestContext): TValue; +begin + FRequestId := Context.RequestId.AsText; + FStarted.SetEvent; + + for var Step := 1 to WATCH_STEPS do + begin + if Context.IsCancelled then + begin + FCancelSeen.SetEvent; + Break; + end; + + Context.ReportProgress(Step, WATCH_STEPS, WATCH_STEP_MESSAGE); + + if FRelease.WaitFor(WATCH_STEP_MS) = TWaitResult.wrSignaled then + Break; + end; + + Result := TMCPToolResult.Text(WATCH_ANSWER); +end; + +function TCancelWatchTool.WaitForStart(const TimeoutMs: Cardinal): Boolean; +begin + Result := (FStarted.WaitFor(TimeoutMs) = TWaitResult.wrSignaled); +end; + +function TCancelWatchTool.WaitForCancellation(const TimeoutMs: Cardinal): Boolean; +begin + Result := (FCancelSeen.WaitFor(TimeoutMs) = TWaitResult.wrSignaled); +end; + +function TCancelWatchTool.SawCancellation: Boolean; +begin + Result := (FCancelSeen.WaitFor(0) = TWaitResult.wrSignaled); +end; + +procedure TCancelWatchTool.Release; +begin + FRelease.SetEvent; +end; + +{ TMCPHttpCancellationTests } + +procedure TMCPHttpCancellationTests.Setup; +begin + FWatch := TCancelWatchTool.Create; + FWatchTool := FWatch; + + FHost := TMCPServerHost.Create; + FHost.Settings.Port := 0; + FHost.Settings.CorsEnabled := False; + FHost.AddTool(FWatchTool); + FHost.StartHttp; +end; + +procedure TMCPHttpCancellationTests.TearDown; +begin + // A tool still counting its steps would hold the host open for as long as its budget lasts. + FWatch.Release; + FreeAndNil(FHost); + FWatch := nil; + FWatchTool := nil; +end; + +function TMCPHttpCancellationTests.Url: string; +begin + Result := Format(URL_TEMPLATE, [LOOPBACK, FHost.BoundPort, ENDPOINT]); +end; + +function TMCPHttpCancellationTests.Post(const Body: string; out StatusCode: Integer): string; +begin + const Http = TIdHTTP.Create(nil); + const Request = TStringStream.Create(Body, TEncoding.UTF8); + try + Http.HTTPOptions := Http.HTTPOptions + [hoNoProtocolErrorException]; + Http.Request.ContentType := MEDIA_TYPE_JSON; + Http.Request.Accept := ACCEPT_STREAM; + Result := Http.Post(Url, Request); + StatusCode := Http.ResponseCode; + finally + Request.Free; + Http.Free; + end; +end; + +procedure TMCPHttpCancellationTests.ADroppedConnection_CancelsTheRunningTool; +begin + const Socket = TIdTCPClient.Create(nil); + try + Socket.Host := LOOPBACK; + Socket.Port := FHost.BoundPort; + Socket.Connect; + + const Payload = TEncoding.UTF8.GetBytes(CALL_REQUEST); + Socket.IOHandler.WriteLn('POST ' + ENDPOINT + ' HTTP/1.1'); + Socket.IOHandler.WriteLn(Format('Host: %s:%d', [LOOPBACK, FHost.BoundPort])); + Socket.IOHandler.WriteLn('Content-Type: ' + MEDIA_TYPE_JSON); + Socket.IOHandler.WriteLn('Accept: ' + ACCEPT_STREAM); + Socket.IOHandler.WriteLn(Format('Content-Length: %d', [Length(Payload)])); + Socket.IOHandler.WriteLn('Connection: close'); + Socket.IOHandler.WriteLn; + Socket.IOHandler.Write(TIdBytes(Payload)); + + Assert.IsTrue(FWatch.WaitForStart(WATCH_WAIT_MS), 'the tool never started'); + + // Let the stream get going, so the write that fails is a later one and not the first. + Socket.IOHandler.CheckForDataOnSource(STREAM_SETTLE_MS); + Socket.Disconnect; + finally + Socket.Free; + end; + + Assert.IsTrue(FWatch.WaitForCancellation(WATCH_WAIT_MS), + 'the tool never saw its request cancelled, so the closed stream cancelled nothing'); +end; + +procedure TMCPHttpCancellationTests.ACancellationOnASecondConnection_IsAcceptedAndTheToolRunsOn; +begin + var Answer := ''; + var Failure := ''; + var CallStatus := 0; + + const Caller = TThread.CreateAnonymousThread( + procedure + begin + try + Answer := Post(CALL_REQUEST, CallStatus); + except + on E: Exception do + Failure := E.ClassName + ': ' + E.Message; + end; + end); + Caller.FreeOnTerminate := False; + Caller.Start; + try + Assert.IsTrue(FWatch.WaitForStart(WATCH_WAIT_MS), 'the tool never started'); + + var NotifiedStatus := 0; + Post(Format(CANCEL_NOTIFICATION, [FWatch.RequestId]), NotifiedStatus); + Assert.AreEqual(HTTP_STATUS_ACCEPTED, NotifiedStatus, + 'the server answered the cancellation with something other than 202'); + + // The tool has now outlived the notification, which is the whole point; it may stop. + FWatch.Release; + finally + Caller.WaitFor; + Caller.Free; + end; + + Assert.AreEqual('', Failure, 'the call itself failed'); + Assert.IsFalse(FWatch.SawCancellation, + 'the notification reached the running request after all, which the documents deny'); + Assert.IsTrue(Answer.Contains(WATCH_ANSWER), + 'the tool did not answer after the cancellation it never heard: ' + Answer); +end; + +end. diff --git a/tests/MCPServer.Tests.HttpHeaders.pas b/tests/MCPServer.Tests.HttpHeaders.pas new file mode 100644 index 0000000..faabadd --- /dev/null +++ b/tests/MCPServer.Tests.HttpHeaders.pas @@ -0,0 +1,212 @@ +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..7c038db --- /dev/null +++ b/tests/MCPServer.Tests.Logger.pas @@ -0,0 +1,117 @@ +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.Marshal.pas b/tests/MCPServer.Tests.Marshal.pas new file mode 100644 index 0000000..c4fd85f --- /dev/null +++ b/tests/MCPServer.Tests.Marshal.pas @@ -0,0 +1,750 @@ +unit MCPServer.Tests.Marshal; + +interface + +uses + System.Rtti, + System.TypInfo, + System.Generics.Collections, + DUnitX.TestFramework, + MCPServer.Types; + +type + TMarshalColour = (mcRed, mcGreen, mcBlue); + + TMarshalPoint = class + private + FX: Integer; + FY: Integer; + public + property X: Integer read FX write FX; + property Y: Integer read FY write FY; + end; + + TMarshalLine = class + private + FName: string; + FOrigin: TMarshalPoint; + public + destructor Destroy; override; + property Name: string read FName write FName; + [Optional] + property Origin: TMarshalPoint read FOrigin write FOrigin; + end; + + TMarshalStamp = record + When: TDateTime; + Colour: TMarshalColour; + end; + + TMarshalCoordinate = record + X: Integer; + Y: Integer; + end; + + TMarshalRegion = record + private + FInternal: Integer; + public + Name: string; + Corner: TMarshalCoordinate; + Tags: TArray; + [Optional] + Note: string; + [SchemaName('anchor_point')] + Anchor: TMarshalCoordinate; + + function Internal: Integer; + end; + + TMarshalPlacement = record + Label_: string; + [Optional] + Pin: TMarshalPoint; + end; + + TMarshalCountedPin = class + private + FX: Integer; + FY: Integer; + public + class var DestroyCount: Integer; + destructor Destroy; override; + property X: Integer read FX write FX; + property Y: Integer read FY write FY; + end; + + TMarshalPinned = record + Pin: TMarshalCountedPin; + Count: Integer; + end; + + TMarshalTagged = record + Id: TGUID; + Name: string; + end; + + TMarshalBoxed = class + private + FCorner: TMarshalCoordinate; + public + property Corner: TMarshalCoordinate read FCorner write FCorner; + end; + + TMarshalCoordinateArray = TArray; + TMarshalPlacementArray = TArray; + TMarshalIntegerArray = TArray; + TMarshalStringArray = TArray; + TMarshalPointArray = TArray; + TMarshalIntegerList = TList; + TMarshalPointList = TObjectList; + + [TestFixture] + TMarshalTests = class + private + FContext: TRttiContext; + FOwned: TList; + + function RttiTypeOf(const Info: PTypeInfo): TRttiType; + function FromJson(const Json: string; const RttiType: TRttiType): TValue; + function FromJsonUnowned(const Json: string; const RttiType: TRttiType): TValue; + function ToJsonText(const Value: TValue; const RttiType: TRttiType): string; + procedure ExpectArgumentError(const Json: string; const RttiType: TRttiType; const Fragment: string); + public + [Setup] + procedure Setup; + + [TearDown] + procedure TearDown; + + [Test] + procedure Integer_RoundTrip; + + [Test] + procedure Int64_RoundTrip; + + [Test] + procedure String_RoundTrip; + + [Test] + procedure Float_RoundTrip; + + [Test] + procedure Boolean_RoundTrip; + + [Test] + procedure Enum_ByName_RoundTrip; + + [Test] + procedure Enum_UnknownName_Raises; + + [Test] + procedure DateTime_Iso8601_RoundTrip; + + [Test] + procedure WrongType_MessagesKeepTheirShape; + + [Test] + procedure NestedClass_JsonToValue; + + [Test] + procedure NestedClass_ValueToJson; + + [Test] + procedure NestedClass_ErrorNamesTheParameter; + + [Test] + procedure StringArray_RoundTrip; + + [Test] + procedure IntegerArray_ValueToJson; + + [Test] + procedure ObjectArray_OwnedHoldsEveryElement; + + [Test] + procedure PrimitiveArray_OwnedStaysEmpty; + + [Test] + procedure Owned_HoldsOnlyTheRootOfANestedClass; + + [Test] + procedure Owned_Nil_LeavesTheObjectToTheCaller; + + [Test] + procedure List_ValueToJson; + + [Test] + procedure ObjectList_ValueToJson; + + [Test] + procedure EmptyValue_IsNullForAClassAndEmptyForAnArray; + + [Test] + procedure NoType_IsSafe; + + [Test] + procedure Record_RoundTripIsExact; + + [Test] + procedure Record_NotAnObject_Raises; + + [Test] + procedure NestedRecord_RoundTrip; + + [Test] + procedure RecordWithEnumAndDateTime_RoundTrip; + + [Test] + procedure RecordArray_RoundTrip; + + [Test] + procedure ClassHoldingARecord_RoundTrip; + + [Test] + procedure OptionalRecordField_AbsentKeepsItsDefault; + + [Test] + procedure MissingRequiredRecordField_Raises; + + [Test] + procedure UnknownRecordMember_Raises; + + [Test] + procedure WrongRecordMemberType_NamesTheField; + + [Test] + procedure SchemaNameOnARecordField_IsTheWireName; + + [Test] + procedure PrivateRecordField_IsNeitherReadNorWritten; + + [Test] + procedure RecordHoldingAnObject_OwnedHoldsThatObject; + + [Test] + procedure RecordArrayHoldingObjects_OwnedHoldsEveryOne; + + [Test] + procedure Record_OwnedGainsNothingForAValueOnlyRecord; + + [Test] + procedure RecordMemberFails_FreesTheObjectTheRecordAlreadyHolds; + + [Test] + procedure Guid_RoundTripIsExact; + + [Test] + procedure Guid_AcceptsBracesAndRejectsAnythingElse; + end; + +implementation + +uses + System.SysUtils, + System.DateUtils, + System.JSON, + MCPServer.Serializer; + +{ TMarshalLine } + +destructor TMarshalLine.Destroy; +begin + FOrigin.Free; + inherited; +end; + +{ TMarshalCountedPin } + +destructor TMarshalCountedPin.Destroy; +begin + Inc(DestroyCount); + inherited; +end; + +{ TMarshalRegion } + +function TMarshalRegion.Internal: Integer; +begin + Result := FInternal; +end; + +{ TMarshalTests } + +procedure TMarshalTests.Setup; +begin + FOwned := TList.Create; +end; + +procedure TMarshalTests.TearDown; +begin + for var Obj in FOwned do + Obj.Free; + FOwned.Free; +end; + +function TMarshalTests.RttiTypeOf(const Info: PTypeInfo): TRttiType; +begin + Result := FContext.GetType(Info); +end; + +function TMarshalTests.FromJson(const Json: string; const RttiType: TRttiType): TValue; +begin + const Parsed = TJSONObject.ParseJSONValue(Json); + Assert.IsNotNull(Parsed, 'the test json does not parse: ' + Json); + try + Result := TMCPSerializer.JsonToValue(Parsed, RttiType, FOwned); + finally + Parsed.Free; + end; +end; + +function TMarshalTests.FromJsonUnowned(const Json: string; const RttiType: TRttiType): TValue; +begin + const Parsed = TJSONObject.ParseJSONValue(Json); + Assert.IsNotNull(Parsed, 'the test json does not parse: ' + Json); + try + Result := TMCPSerializer.JsonToValue(Parsed, RttiType, nil); + finally + Parsed.Free; + end; +end; + +function TMarshalTests.ToJsonText(const Value: TValue; const RttiType: TRttiType): string; +begin + const Json = TMCPSerializer.ValueToJson(Value, RttiType); + Assert.IsNotNull(Json, 'ValueToJson returned nil'); + try + Result := Json.ToJSON; + finally + Json.Free; + end; +end; + +procedure TMarshalTests.ExpectArgumentError(const Json: string; const RttiType: TRttiType; const Fragment: string); +begin + try + FromJson(Json, RttiType); + 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 TMarshalTests.Integer_RoundTrip; +begin + const IntegerType = RttiTypeOf(TypeInfo(Integer)); + const Value = FromJson('42', IntegerType); + Assert.AreEqual(42, Value.AsInteger); + Assert.AreEqual('42', ToJsonText(Value, IntegerType)); +end; + +procedure TMarshalTests.Int64_RoundTrip; +begin + const Int64Type = RttiTypeOf(TypeInfo(Int64)); + const Value = FromJson('9007199254740992', Int64Type); + Assert.AreEqual(Int64(9007199254740992), Value.AsInt64); + Assert.AreEqual('9007199254740992', ToJsonText(Value, Int64Type)); +end; + +procedure TMarshalTests.String_RoundTrip; +begin + const StringType = RttiTypeOf(TypeInfo(string)); + const Value = FromJson('"hello"', StringType); + Assert.AreEqual('hello', Value.AsString); + Assert.AreEqual('"hello"', ToJsonText(Value, StringType)); +end; + +procedure TMarshalTests.Float_RoundTrip; +begin + const FloatType = RttiTypeOf(TypeInfo(Double)); + const Value = FromJson('1.5', FloatType); + Assert.AreEqual(1.5, Value.AsExtended, 0.0001); + Assert.AreEqual('1.5', ToJsonText(Value, FloatType)); +end; + +procedure TMarshalTests.Boolean_RoundTrip; +begin + const BooleanType = RttiTypeOf(TypeInfo(Boolean)); + Assert.IsTrue(FromJson('true', BooleanType).AsBoolean); + Assert.IsFalse(FromJson('false', BooleanType).AsBoolean); + Assert.AreEqual('true', ToJsonText(TValue.From(True), BooleanType)); + Assert.AreEqual('false', ToJsonText(TValue.From(False), BooleanType)); +end; + +procedure TMarshalTests.Enum_ByName_RoundTrip; +begin + const ColourType = RttiTypeOf(TypeInfo(TMarshalColour)); + const Value = FromJson('"mcGreen"', ColourType); + Assert.AreEqual(Ord(mcGreen), Integer(Value.AsOrdinal)); + Assert.AreEqual('"mcGreen"', ToJsonText(Value, ColourType)); +end; + +procedure TMarshalTests.Enum_UnknownName_Raises; +begin + ExpectArgumentError('"mcPurple"', RttiTypeOf(TypeInfo(TMarshalColour)), + 'Valid values: mcRed, mcGreen, mcBlue'); +end; + +procedure TMarshalTests.DateTime_Iso8601_RoundTrip; +begin + const DateTimeType = RttiTypeOf(TypeInfo(TDateTime)); + const When = EncodeDateTime(2026, 9, 7, 10, 30, 0, 0); + const Text = ToJsonText(TValue.From(When), DateTimeType); + Assert.IsTrue(Text.StartsWith('"2026-09-07T10:30:00'), Text); + Assert.IsFalse(Text.Contains('Z'), 'the wire format is local time, not UTC: ' + Text); + + const Back = FromJson(Text, DateTimeType); + Assert.AreEqual(Double(When), Double(Back.AsType), 1.0 / SecsPerDay); +end; + +procedure TMarshalTests.WrongType_MessagesKeepTheirShape; +begin + ExpectArgumentError('"two"', RttiTypeOf(TypeInfo(Integer)), 'expected an integer'); + ExpectArgumentError('1.5', RttiTypeOf(TypeInfo(Integer)), 'expected an integer'); + ExpectArgumentError('"nope"', RttiTypeOf(TypeInfo(Double)), 'expected a number'); + ExpectArgumentError('5', RttiTypeOf(TypeInfo(string)), 'expected a string'); + ExpectArgumentError('5', RttiTypeOf(TypeInfo(Boolean)), 'expected a boolean'); + ExpectArgumentError('"not-a-date"', RttiTypeOf(TypeInfo(TDateTime)), 'expected an ISO 8601 date-time'); + ExpectArgumentError('5', FContext.GetType(TMarshalPoint), 'expected an object'); + ExpectArgumentError('5', RttiTypeOf(TypeInfo(TMarshalIntegerArray)), 'expected an array'); +end; + +procedure TMarshalTests.NestedClass_JsonToValue; +begin + const Value = FromJson('{"name":"edge","origin":{"x":1,"y":2}}', FContext.GetType(TMarshalLine)); + const Line = Value.AsObject as TMarshalLine; + Assert.AreEqual('edge', Line.Name); + Assert.IsNotNull(Line.Origin); + Assert.AreEqual(1, Line.Origin.X); + Assert.AreEqual(2, Line.Origin.Y); +end; + +procedure TMarshalTests.NestedClass_ValueToJson; +begin + const LineType = FContext.GetType(TMarshalLine); + const Line = TMarshalLine.Create; + FOwned.Add(Line); + Line.Name := 'edge'; + Line.Origin := TMarshalPoint.Create; + Line.Origin.X := 1; + Line.Origin.Y := 2; + + Assert.AreEqual('{"name":"edge","origin":{"x":1,"y":2}}', ToJsonText(Line, LineType)); +end; + +procedure TMarshalTests.NestedClass_ErrorNamesTheParameter; +begin + ExpectArgumentError('{"name":"edge","origin":{"x":"nope","y":2}}', FContext.GetType(TMarshalLine), + 'Parameter "x": expected an integer'); +end; + +procedure TMarshalTests.StringArray_RoundTrip; +begin + const ArrayType = RttiTypeOf(TypeInfo(TMarshalStringArray)); + const Value = FromJson('["a","b"]', ArrayType); + Assert.AreEqual(2, Integer(Value.GetArrayLength)); + Assert.AreEqual('b', Value.GetArrayElement(1).AsString); + Assert.AreEqual('["a","b"]', ToJsonText(Value, ArrayType)); +end; + +procedure TMarshalTests.IntegerArray_ValueToJson; +begin + const ArrayType = RttiTypeOf(TypeInfo(TMarshalIntegerArray)); + const Numbers: TMarshalIntegerArray = [1, 2, 3]; + Assert.AreEqual('[1,2,3]', ToJsonText(TValue.From(Numbers), ArrayType)); +end; + +procedure TMarshalTests.ObjectArray_OwnedHoldsEveryElement; +begin + const ArrayType = RttiTypeOf(TypeInfo(TMarshalPointArray)); + const Value = FromJson('[{"x":1,"y":2},{"x":3,"y":4}]', ArrayType); + + Assert.AreEqual(2, Integer(Value.GetArrayLength)); + Assert.AreEqual(2, Integer(FOwned.Count)); + Assert.AreSame(Value.GetArrayElement(0).AsObject, FOwned[0]); + Assert.AreSame(Value.GetArrayElement(1).AsObject, FOwned[1]); + Assert.AreEqual(3, (FOwned[1] as TMarshalPoint).X); + Assert.AreEqual('[{"x":1,"y":2},{"x":3,"y":4}]', ToJsonText(Value, ArrayType)); +end; + +procedure TMarshalTests.PrimitiveArray_OwnedStaysEmpty; +begin + const Value = FromJson('[1,2,3]', RttiTypeOf(TypeInfo(TMarshalIntegerArray))); + Assert.AreEqual(3, Integer(Value.GetArrayLength)); + Assert.AreEqual(0, Integer(FOwned.Count)); +end; + +procedure TMarshalTests.Owned_HoldsOnlyTheRootOfANestedClass; +begin + const Value = FromJson('{"name":"edge","origin":{"x":1,"y":2}}', FContext.GetType(TMarshalLine)); + + Assert.AreEqual(1, Integer(FOwned.Count), 'the nested object belongs to the object that holds it'); + Assert.AreSame(Value.AsObject, FOwned[0]); +end; + +procedure TMarshalTests.Owned_Nil_LeavesTheObjectToTheCaller; +begin + const Value = FromJsonUnowned('{"x":1,"y":2}', FContext.GetType(TMarshalPoint)); + + Assert.AreEqual(0, Integer(FOwned.Count)); + const Point = Value.AsObject as TMarshalPoint; + try + Assert.AreEqual(1, Point.X); + finally + Point.Free; + end; +end; + +procedure TMarshalTests.List_ValueToJson; +begin + const ListType = FContext.GetType(TMarshalIntegerList); + const List = TMarshalIntegerList.Create; + FOwned.Add(List); + List.Add(7); + List.Add(8); + + Assert.AreEqual('[7,8]', ToJsonText(List, ListType)); +end; + +procedure TMarshalTests.ObjectList_ValueToJson; +begin + const ListType = FContext.GetType(TMarshalPointList); + const List = TMarshalPointList.Create; + FOwned.Add(List); + const Point = TMarshalPoint.Create; + Point.X := 1; + Point.Y := 2; + List.Add(Point); + + Assert.AreEqual('[{"x":1,"y":2}]', ToJsonText(List, ListType)); +end; + +procedure TMarshalTests.EmptyValue_IsNullForAClassAndEmptyForAnArray; +begin + Assert.AreEqual('null', ToJsonText(TValue.Empty, FContext.GetType(TMarshalPoint))); + Assert.AreEqual('[]', ToJsonText(TValue.Empty, RttiTypeOf(TypeInfo(TMarshalIntegerArray)))); +end; + +procedure TMarshalTests.NoType_IsSafe; +begin + const Parsed = TJSONObject.ParseJSONValue('42'); + try + Assert.IsTrue(TMCPSerializer.JsonToValue(Parsed, nil, FOwned).IsEmpty); + finally + Parsed.Free; + end; + + Assert.IsNull(TMCPSerializer.ValueToJson(TValue.From(42), nil)); + Assert.IsTrue(TMCPSerializer.JsonToValue(nil, RttiTypeOf(TypeInfo(Integer)), FOwned).IsEmpty); +end; + +procedure TMarshalTests.Record_RoundTripIsExact; +begin + const CoordinateType = RttiTypeOf(TypeInfo(TMarshalCoordinate)); + const Text = '{"x":3,"y":4}'; + + const Value = FromJson(Text, CoordinateType); + const Coordinate = Value.AsType; + Assert.AreEqual(3, Coordinate.X); + Assert.AreEqual(4, Coordinate.Y); + + Assert.AreEqual(Text, ToJsonText(Value, CoordinateType)); +end; + +procedure TMarshalTests.Record_NotAnObject_Raises; +begin + ExpectArgumentError('5', RttiTypeOf(TypeInfo(TMarshalCoordinate)), 'expected an object'); +end; + +procedure TMarshalTests.NestedRecord_RoundTrip; +begin + const RegionType = RttiTypeOf(TypeInfo(TMarshalRegion)); + const Text = '{"name":"north","corner":{"x":1,"y":2},"tags":["a","b"],"note":"seen",' + + '"anchor_point":{"x":5,"y":6}}'; + + const Value = FromJson(Text, RegionType); + const Region = Value.AsType; + Assert.AreEqual('north', Region.Name); + Assert.AreEqual(1, Region.Corner.X); + Assert.AreEqual(2, Region.Corner.Y); + Assert.AreEqual(2, Integer(Length(Region.Tags))); + Assert.AreEqual('b', Region.Tags[1]); + Assert.AreEqual('seen', Region.Note); + Assert.AreEqual(5, Region.Anchor.X); + + Assert.AreEqual(Text, ToJsonText(Value, RegionType)); +end; + +procedure TMarshalTests.RecordWithEnumAndDateTime_RoundTrip; +begin + const StampType = RttiTypeOf(TypeInfo(TMarshalStamp)); + const When = EncodeDateTime(2026, 9, 7, 10, 30, 0, 0); + + var Stamp: TMarshalStamp; + Stamp.When := When; + Stamp.Colour := mcBlue; + + const Text = ToJsonText(TValue.From(Stamp), StampType); + Assert.IsTrue(Text.Contains('"2026-09-07T10:30:00'), Text); + Assert.IsTrue(Text.Contains('"mcBlue"'), Text); + + const Back = FromJson(Text, StampType).AsType; + Assert.AreEqual(Double(When), Double(Back.When), 1.0 / SecsPerDay); + Assert.AreEqual(Ord(mcBlue), Ord(Back.Colour)); +end; + +procedure TMarshalTests.RecordArray_RoundTrip; +begin + const ArrayType = RttiTypeOf(TypeInfo(TMarshalCoordinateArray)); + const Text = '[{"x":1,"y":2},{"x":3,"y":4}]'; + + const Value = FromJson(Text, ArrayType); + Assert.AreEqual(2, Integer(Value.GetArrayLength)); + Assert.AreEqual(3, Value.GetArrayElement(1).AsType.X); + + Assert.AreEqual(Text, ToJsonText(Value, ArrayType)); + Assert.AreEqual(0, Integer(FOwned.Count), 'a record is a value, so it owns nothing'); +end; + +procedure TMarshalTests.ClassHoldingARecord_RoundTrip; +begin + const BoxedType = FContext.GetType(TMarshalBoxed); + const Text = '{"corner":{"x":7,"y":8}}'; + + const Value = FromJson(Text, BoxedType); + const Boxed = Value.AsObject as TMarshalBoxed; + Assert.AreEqual(7, Boxed.Corner.X); + Assert.AreEqual(8, Boxed.Corner.Y); + + Assert.AreEqual(Text, ToJsonText(Value, BoxedType)); +end; + +procedure TMarshalTests.OptionalRecordField_AbsentKeepsItsDefault; +begin + const RegionType = RttiTypeOf(TypeInfo(TMarshalRegion)); + const Value = FromJson('{"name":"north","corner":{"x":1,"y":2},"tags":[],"anchor_point":{"x":0,"y":0}}', + RegionType); + + const Region = Value.AsType; + Assert.AreEqual('north', Region.Name); + Assert.AreEqual('', Region.Note, 'an absent optional field keeps the default of its type'); +end; + +procedure TMarshalTests.MissingRequiredRecordField_Raises; +begin + ExpectArgumentError('{"x":1}', RttiTypeOf(TypeInfo(TMarshalCoordinate)), + 'Missing required parameter "y"'); +end; + +procedure TMarshalTests.UnknownRecordMember_Raises; +begin + ExpectArgumentError('{"x":1,"y":2,"z":3}', RttiTypeOf(TypeInfo(TMarshalCoordinate)), + 'Unknown parameter "z"'); +end; + +procedure TMarshalTests.WrongRecordMemberType_NamesTheField; +begin + ExpectArgumentError('{"x":"nope","y":2}', RttiTypeOf(TypeInfo(TMarshalCoordinate)), + 'Parameter "x": expected an integer'); +end; + +procedure TMarshalTests.SchemaNameOnARecordField_IsTheWireName; +begin + const RegionType = RttiTypeOf(TypeInfo(TMarshalRegion)); + ExpectArgumentError('{"name":"north","corner":{"x":1,"y":2},"tags":[],"anchor":{"x":0,"y":0}}', + RegionType, 'Unknown parameter "anchor"'); +end; + +procedure TMarshalTests.PrivateRecordField_IsNeitherReadNorWritten; +begin + const RegionType = RttiTypeOf(TypeInfo(TMarshalRegion)); + const Text = ToJsonText(TValue.From(Default(TMarshalRegion)), RegionType); + + Assert.IsFalse(Text.Contains('finternal'), Text); + ExpectArgumentError('{"name":"north","corner":{"x":1,"y":2},"tags":[],"anchor_point":{"x":0,"y":0},' + + '"finternal":9}', RegionType, 'Unknown parameter "finternal"'); +end; + +procedure TMarshalTests.RecordHoldingAnObject_OwnedHoldsThatObject; +begin + const PlacementType = RttiTypeOf(TypeInfo(TMarshalPlacement)); + const Text = '{"label_":"pin","pin":{"x":1,"y":2}}'; + + const Value = FromJson(Text, PlacementType); + const Placement = Value.AsType; + Assert.IsNotNull(Placement.Pin); + Assert.AreEqual(1, Placement.Pin.X); + + Assert.AreEqual(1, Integer(FOwned.Count), 'a record owns nothing, so the object it holds needs an owner'); + Assert.AreSame(TObject(Placement.Pin), FOwned[0]); + + Assert.AreEqual(Text, ToJsonText(Value, PlacementType)); +end; + +procedure TMarshalTests.RecordArrayHoldingObjects_OwnedHoldsEveryOne; +begin + const ArrayType = RttiTypeOf(TypeInfo(TMarshalPlacementArray)); + const Text = '[{"label_":"a","pin":{"x":1,"y":2}},{"label_":"b","pin":{"x":3,"y":4}}]'; + + const Value = FromJson(Text, ArrayType); + Assert.AreEqual(2, Integer(Value.GetArrayLength)); + Assert.AreEqual(2, Integer(FOwned.Count)); + Assert.AreSame(TObject(Value.GetArrayElement(1).AsType.Pin), FOwned[1]); + + Assert.AreEqual(Text, ToJsonText(Value, ArrayType)); +end; + +procedure TMarshalTests.Record_OwnedGainsNothingForAValueOnlyRecord; +begin + FromJson('{"name":"north","corner":{"x":1,"y":2},"tags":["a"],"anchor_point":{"x":0,"y":0}}', + RttiTypeOf(TypeInfo(TMarshalRegion))); + Assert.AreEqual(0, Integer(FOwned.Count), 'a record made of values owns nothing'); + + const Value = FromJson('{"label_":"pin"}', RttiTypeOf(TypeInfo(TMarshalPlacement))); + Assert.IsNull(Value.AsType.Pin, 'an absent optional object field stays nil'); + Assert.AreEqual(0, Integer(FOwned.Count), 'and nothing nil is put up for freeing'); +end; + +procedure TMarshalTests.RecordMemberFails_FreesTheObjectTheRecordAlreadyHolds; +begin + TMarshalCountedPin.DestroyCount := 0; + + ExpectArgumentError('{"pin":{"x":1,"y":2},"count":"x"}', RttiTypeOf(TypeInfo(TMarshalPinned)), + 'Parameter "count": expected an integer'); + + Assert.AreEqual(0, Integer(FOwned.Count), + 'a record that never finished converting hands nothing to the caller to free'); + Assert.AreEqual(1, TMarshalCountedPin.DestroyCount, + 'the object the half-built record already held is freed on the way out'); +end; + +procedure TMarshalTests.Guid_RoundTripIsExact; +begin + const TaggedType = RttiTypeOf(TypeInfo(TMarshalTagged)); + const Text = '{"id":"f81d4fae-7dec-11d0-a765-00a0c91e6bf6","name":"crate"}'; + + const Value = FromJson(Text, TaggedType); + const Tagged = Value.AsType; + Assert.AreEqual('{F81D4FAE-7DEC-11D0-A765-00A0C91E6BF6}', GUIDToString(Tagged.Id)); + Assert.AreEqual('crate', Tagged.Name); + Assert.AreEqual(0, Integer(FOwned.Count), 'a GUID is a value and owns nothing'); + + Assert.AreEqual(Text, ToJsonText(Value, TaggedType)); +end; + +procedure TMarshalTests.Guid_AcceptsBracesAndRejectsAnythingElse; +begin + const TaggedType = RttiTypeOf(TypeInfo(TMarshalTagged)); + + const Value = FromJson('{"id":"{F81D4FAE-7DEC-11D0-A765-00A0C91E6BF6}","name":"crate"}', TaggedType); + Assert.AreEqual('{F81D4FAE-7DEC-11D0-A765-00A0C91E6BF6}', GUIDToString(Value.AsType.Id)); + + ExpectArgumentError('{"id":"not-a-uuid","name":"crate"}', TaggedType, + 'Parameter "id": expected a UUID string'); + ExpectArgumentError('{"id":7,"name":"crate"}', TaggedType, + 'Parameter "id": expected a UUID string'); +end; + +end. diff --git a/tests/MCPServer.Tests.MethodTool.pas b/tests/MCPServer.Tests.MethodTool.pas new file mode 100644 index 0000000..20b4382 --- /dev/null +++ b/tests/MCPServer.Tests.MethodTool.pas @@ -0,0 +1,932 @@ +unit MCPServer.Tests.MethodTool; + +interface + +uses + DUnitX.TestFramework, + System.Rtti, + System.JSON, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Tool.Base, + MCPServer.Tool.Method; + +type + TCountedFilter = class + private + FCustomer: string; + FLimit: Integer; + public + class var DestroyCount: Integer; + destructor Destroy; override; + property Customer: string read FCustomer write FCustomer; + [Optional] + property Limit: Integer read FLimit write FLimit; + end; + + TCountedLine = class + private + FSku: string; + FQuantity: Integer; + public + class var DestroyCount: Integer; + destructor Destroy; override; + property Sku: string read FSku write FSku; + property Quantity: Integer read FQuantity write FQuantity; + end; + + TSampleBox = record + Width: Integer; + Height: Integer; + end; + + TSampleLabelled = record + Caption: string; + Box: TSampleBox; + [Optional] + Note: string; + end; + + TSampleTarget = class + private + FSeen: string; + FKept: TCountedFilter; + public + destructor Destroy; override; + procedure Ping; + procedure Remember(const Note: string); + function Add(const Left, Right: Integer): Integer; + function Greet(const Person: string): string; + function Describe(const Filter: TCountedFilter): string; + function JoinSkus(const Skus: TArray): string; + function CountLines(const Lines: TArray): Integer; + function MakeLine: TCountedLine; + function MakeLines: TArray; + function Tagged([SchemaName('colour_tag')] const Tag: string): string; + function WithOptional(const Base: string; [Optional] const Suffix: string): string; + function Keep(const Filter: TCountedFilter): string; + function Area(const Box: TSampleBox): Integer; + function Grow(const Box: TSampleBox): TSampleBox; + function Caption(const Labelled: TSampleLabelled): string; + property Seen: string read FSeen; + property Kept: TCountedFilter read FKept; + end; + + TEnvelopeTool = class(TMCPMethodTool) + protected + function ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; override; + public + function GetOutputSchema: TJSONObject; override; + end; + + TMismatchedTool = class(TMCPMethodTool) + protected + function ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; override; + end; + + TKeepingTool = class(TMCPMethodTool) + protected + procedure ReleaseResult(const Value: TValue; const ResultType: TRttiType); override; + public + Kept: TObject; + end; + + TAdoptingTool = class(TMCPMethodTool) + protected + procedure ReleaseArguments(const Owned: TList); override; + end; + + [TestFixture] + TMethodToolTests = class + private + FContext: TRttiContext; + FTarget: TSampleTarget; + function MethodOf(const MethodName: string): TRttiMethod; + function ToolFor(const MethodName: string): IMCPTool; + function Run(const Tool: IMCPTool; const ArgumentsJson: string): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure Procedure_ReturnsOk; + + [Test] + procedure Procedure_PassesItsArgument; + + [Test] + procedure Function_ReturnsTheResultMember; + + [Test] + procedure StringFunction_ReturnsAStringResult; + + [Test] + procedure DtoParameter_IsMarshalledAndFreed; + + [Test] + procedure ArrayParameter_IsMarshalled; + + [Test] + procedure ObjectArrayParameter_IsMarshalledAndEveryElementFreed; + + [Test] + procedure MissingRequiredArgument_RaisesArgumentException; + + [Test] + procedure WrongArgumentType_RaisesArgumentException; + + [Test] + procedure UnknownArgument_RaisesArgumentException; + + [Test] + procedure OptionalArgument_MayBeOmitted; + + [Test] + procedure SchemaName_IsAlsoTheArgumentName; + + [Test] + procedure OverriddenResultToJson_ReplacesTheWholeObject; + + [Test] + procedure ReturnedObject_IsFreedExactlyOnce; + + [Test] + procedure ReturnedObjectArray_IsFreedElementByElement; + + [Test] + procedure OverriddenReleaseResult_KeepsTheReturnedObject; + + [Test] + procedure OverriddenReleaseArguments_LeavesTheArgumentToTheMethod; + + [Test] + procedure GetInputSchema_ReturnsAFreshInstanceEveryCall; + + [Test] + procedure FreeingAnInputSchema_LeavesTheToolUsable; + + [Test] + procedure GetOutputSchema_ReturnsAFreshInstanceEveryCall; + + [Test] + procedure Procedure_HasNoOutputSchema; + + [Test] + procedure OutputSchema_ValidatesTheDefaultFunctionResult; + + [Test] + procedure OutputSchema_ValidatesADtoArrayResult; + + [Test] + procedure Title_FallsBackToTheName; + + [Test] + procedure MarkReadOnly_PublishesTheHints; + + [Test] + procedure ThroughTheManager_LogsNoOutputSchemaMismatch; + + [Test] + procedure ThroughTheManager_ReportsAnEnvelopeWithoutItsOutputSchema; + + [Test] + procedure RecordParameter_IsMarshalled; + + [Test] + procedure RecordResult_IsTheResultMember; + + [Test] + procedure RecordResult_ValidatesAgainstItsOutputSchema; + + [Test] + procedure RecordParameter_IsPublishedAsAnObjectInTheInputSchema; + + [Test] + procedure NestedRecordParameter_IsMarshalled; + + [Test] + procedure RecordParameter_OptionalFieldMayBeOmitted; + + [Test] + procedure RecordParameter_MissingFieldRaisesArgumentException; + + [Test] + procedure RecordParameter_WrongFieldTypeRaisesArgumentException; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + MCPServer.Logger, + MCPServer.Schema.Validator, + MCPServer.ToolsManager; + +const + MISMATCH_WARNING = 'structuredContent does not match its outputSchema'; + +{ TCountedFilter } + +destructor TCountedFilter.Destroy; +begin + Inc(DestroyCount); + inherited; +end; + +{ TCountedLine } + +destructor TCountedLine.Destroy; +begin + Inc(DestroyCount); + inherited; +end; + +{ TSampleTarget } + +procedure TSampleTarget.Ping; +begin + FSeen := 'ping'; +end; + +procedure TSampleTarget.Remember(const Note: string); +begin + FSeen := Note; +end; + +function TSampleTarget.Add(const Left, Right: Integer): Integer; +begin + Result := Left + Right; +end; + +function TSampleTarget.Greet(const Person: string): string; +begin + Result := 'Hello, ' + Person; +end; + +function TSampleTarget.Describe(const Filter: TCountedFilter): string; +begin + Result := Format('%s/%d', [Filter.Customer, Filter.Limit]); +end; + +function TSampleTarget.JoinSkus(const Skus: TArray): string; +begin + Result := string.Join('|', Skus); +end; + +function TSampleTarget.CountLines(const Lines: TArray): Integer; +begin + Result := 0; + for var Line in Lines do + Inc(Result, Line.Quantity); +end; + +function TSampleTarget.MakeLine: TCountedLine; +begin + Result := TCountedLine.Create; + Result.Sku := 'SKU-1'; + Result.Quantity := 3; +end; + +function TSampleTarget.MakeLines: TArray; +const + LineCount = 2; +begin + SetLength(Result, LineCount); + for var Index: Integer := 0 to LineCount - 1 do + begin + Result[Index] := TCountedLine.Create; + Result[Index].Sku := 'SKU-' + (Index + 1).ToString; + Result[Index].Quantity := Index + 1; + end; +end; + +function TSampleTarget.Tagged(const Tag: string): string; +begin + Result := '#' + Tag; +end; + +function TSampleTarget.WithOptional(const Base: string; const Suffix: string): string; +begin + Result := Base + Suffix; +end; + +function TSampleTarget.Keep(const Filter: TCountedFilter): string; +begin + FKept.Free; + FKept := Filter; + Result := Filter.Customer; +end; + +function TSampleTarget.Area(const Box: TSampleBox): Integer; +begin + Result := Box.Width * Box.Height; +end; + +function TSampleTarget.Grow(const Box: TSampleBox): TSampleBox; +begin + Result.Width := Box.Width * 2; + Result.Height := Box.Height * 2; +end; + +function TSampleTarget.Caption(const Labelled: TSampleLabelled): string; +begin + Result := Format('%s %dx%d%s', + [Labelled.Caption, Labelled.Box.Width, Labelled.Box.Height, Labelled.Note]); +end; + +destructor TSampleTarget.Destroy; +begin + FKept.Free; + inherited; +end; + +{ TEnvelopeTool } + +function TEnvelopeTool.ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; +begin + const Envelope = TJSONObject.Create; + Envelope.AddPair('columns', TJSONArray.Create.Add('total')); + Envelope.AddPair('rows', TJSONArray.Create.Add(Value.AsInteger)); + Result := Envelope; +end; + +function TEnvelopeTool.GetOutputSchema: TJSONObject; +begin + Result := nil; +end; + +{ TMismatchedTool } + +function TMismatchedTool.ResultToJson(const Value: TValue; const ResultType: TRttiType): TJSONValue; +begin + const Envelope = TJSONObject.Create; + Envelope.AddPair('columns', TJSONArray.Create.Add('total')); + Result := Envelope; +end; + +{ TAdoptingTool } + +procedure TAdoptingTool.ReleaseArguments(const Owned: TList); +begin +end; + +{ TKeepingTool } + +procedure TKeepingTool.ReleaseResult(const Value: TValue; const ResultType: TRttiType); +begin + if Value.IsObject then + Kept := Value.AsObject; +end; + +{ TMethodToolTests } + +procedure TMethodToolTests.Setup; +begin + FContext := TRttiContext.Create; + FTarget := TSampleTarget.Create; + TCountedFilter.DestroyCount := 0; + TCountedLine.DestroyCount := 0; +end; + +procedure TMethodToolTests.TearDown; +begin + FTarget.Free; + FContext.Free; +end; + +function TMethodToolTests.MethodOf(const MethodName: string): TRttiMethod; +begin + Result := FContext.GetType(TSampleTarget).GetMethod(MethodName); + Assert.IsNotNull(Result, 'TSampleTarget.' + MethodName + ' has no method RTTI'); +end; + +function TMethodToolTests.ToolFor(const MethodName: string): IMCPTool; +begin + Result := TMCPMethodTool.Create(TValue.From(FTarget), MethodOf(MethodName), + 'sample_' + LowerCase(MethodName), 'The ' + MethodName + ' sample'); +end; + +function TMethodToolTests.Run(const Tool: IMCPTool; const ArgumentsJson: string): TJSONObject; +begin + const Arguments = TJSONObject.ParseJSONValue(ArgumentsJson) as TJSONObject; + try + Result := Tool.Execute(Arguments).AsType; + finally + Arguments.Free; + end; +end; + +procedure TMethodToolTests.Procedure_ReturnsOk; +begin + const Json = Run(ToolFor('Ping'), '{}'); + try + Assert.IsTrue(Json.GetValue('ok'), 'a procedure reports {"ok": true}'); + Assert.AreEqual(1, Json.Count, 'nothing else is in the envelope'); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.Procedure_PassesItsArgument; +begin + Run(ToolFor('Remember'), '{"note":"written down"}').Free; + + Assert.AreEqual('written down', FTarget.Seen); +end; + +procedure TMethodToolTests.Function_ReturnsTheResultMember; +begin + const Json = Run(ToolFor('Add'), '{"left":2,"right":40}'); + try + Assert.AreEqual(42, Json.GetValue('result')); + Assert.AreEqual(1, Json.Count, 'the default envelope carries only the result'); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.StringFunction_ReturnsAStringResult; +begin + const Json = Run(ToolFor('Greet'), '{"person":"Ada"}'); + try + Assert.AreEqual('Hello, Ada', Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.DtoParameter_IsMarshalledAndFreed; +begin + const Json = Run(ToolFor('Describe'), '{"filter":{"customer":"ALFKI","limit":5}}'); + try + Assert.AreEqual('ALFKI/5', Json.GetValue('result')); + finally + Json.Free; + end; + + Assert.AreEqual(1, TCountedFilter.DestroyCount, 'the marshalled DTO is freed exactly once'); +end; + +procedure TMethodToolTests.ArrayParameter_IsMarshalled; +begin + const Json = Run(ToolFor('JoinSkus'), '{"skus":["a","b","c"]}'); + try + Assert.AreEqual('a|b|c', Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.ObjectArrayParameter_IsMarshalledAndEveryElementFreed; +begin + const Json = Run(ToolFor('CountLines'), + '{"lines":[{"sku":"a","quantity":2},{"sku":"b","quantity":5}]}'); + try + Assert.AreEqual(7, Json.GetValue('result')); + finally + Json.Free; + end; + + Assert.AreEqual(2, TCountedLine.DestroyCount, 'every marshalled element is freed'); +end; + +procedure TMethodToolTests.MissingRequiredArgument_RaisesArgumentException; +begin + var Tool := ToolFor('Add'); + Assert.WillRaise( + procedure + begin + Run(Tool, '{"left":1}').Free; + end, + EArgumentException); +end; + +procedure TMethodToolTests.WrongArgumentType_RaisesArgumentException; +begin + var Tool := ToolFor('Add'); + Assert.WillRaise( + procedure + begin + Run(Tool, '{"left":"two","right":40}').Free; + end, + EArgumentException); +end; + +procedure TMethodToolTests.UnknownArgument_RaisesArgumentException; +begin + var Tool := ToolFor('Add'); + Assert.WillRaise( + procedure + begin + Run(Tool, '{"left":1,"right":2,"sideways":3}').Free; + end, + EArgumentException); +end; + +procedure TMethodToolTests.OptionalArgument_MayBeOmitted; +begin + const Tool = ToolFor('WithOptional'); + + var Json := Run(Tool, '{"base":"core"}'); + try + Assert.AreEqual('core', Json.GetValue('result'), 'an omitted parameter is its default'); + finally + Json.Free; + end; + + Json := Run(Tool, '{"base":"core","suffix":"-plus"}'); + try + Assert.AreEqual('core-plus', Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.SchemaName_IsAlsoTheArgumentName; +begin + const Tool = ToolFor('Tagged'); + + const Schema = Tool.GetInputSchema; + try + const Properties = Schema.GetValue('properties') as TJSONObject; + Assert.IsNotNull(Properties.GetValue('colour_tag'), 'the schema uses the [SchemaName]'); + Assert.IsNull(Properties.GetValue('tag'), 'and not the lower-cased parameter name'); + finally + Schema.Free; + end; + + const Json = Run(Tool, '{"colour_tag":"amber"}'); + try + Assert.AreEqual('#amber', Json.GetValue('result'), 'the marshal reads the same name'); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.OverriddenResultToJson_ReplacesTheWholeObject; +begin + const Tool: IMCPTool = TEnvelopeTool.Create(TValue.From(FTarget), MethodOf('Add'), + 'sample_envelope', 'An envelope tool'); + + const Json = Run(Tool, '{"left":1,"right":2}'); + try + Assert.IsNull(Json.GetValue('result'), 'the override is not nested under "result"'); + Assert.AreEqual('total', (Json.GetValue('columns') as TJSONArray).Items[0].Value); + Assert.AreEqual(3, ((Json.GetValue('rows') as TJSONArray).Items[0] as TJSONNumber).AsInt); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.ReturnedObject_IsFreedExactlyOnce; +begin + const Json = Run(ToolFor('MakeLine'), '{}'); + try + const Line = Json.GetValue('result') as TJSONObject; + Assert.AreEqual('SKU-1', Line.GetValue('sku')); + Assert.AreEqual(3, Line.GetValue('quantity')); + finally + Json.Free; + end; + + Assert.AreEqual(1, TCountedLine.DestroyCount, 'the returned object is freed exactly once'); +end; + +procedure TMethodToolTests.ReturnedObjectArray_IsFreedElementByElement; +begin + const Json = Run(ToolFor('MakeLines'), '{}'); + try + Assert.AreEqual(2, (Json.GetValue('result') as TJSONArray).Count); + finally + Json.Free; + end; + + Assert.AreEqual(2, TCountedLine.DestroyCount, 'every returned element is freed exactly once'); +end; + +procedure TMethodToolTests.OverriddenReleaseResult_KeepsTheReturnedObject; +begin + var Keeper := TKeepingTool.Create(TValue.From(FTarget), MethodOf('MakeLine'), + 'sample_keeping', 'A tool that keeps its result'); + const Tool: IMCPTool = Keeper; + + Run(Tool, '{}').Free; + + Assert.AreEqual(0, TCountedLine.DestroyCount, 'the override frees nothing'); + Assert.IsNotNull(Keeper.Kept, 'and sees the object the method returned'); + + Keeper.Kept.Free; + Assert.AreEqual(1, TCountedLine.DestroyCount); +end; + +procedure TMethodToolTests.OverriddenReleaseArguments_LeavesTheArgumentToTheMethod; +begin + const Tool: IMCPTool = TAdoptingTool.Create(TValue.From(FTarget), MethodOf('Keep'), + 'sample_adopting', 'A tool whose method keeps what it is handed'); + + const Json = Run(Tool, '{"filter":{"customer":"ALFKI","limit":5}}'); + try + Assert.AreEqual('ALFKI', Json.GetValue('result')); + finally + Json.Free; + end; + + Assert.AreEqual(0, TCountedFilter.DestroyCount, 'the tool freed an argument its method kept'); + Assert.IsNotNull(FTarget.Kept, 'the method was handed nothing to keep'); + Assert.AreEqual('ALFKI', FTarget.Kept.Customer, 'the kept argument was freed underneath the method'); +end; + +procedure TMethodToolTests.GetInputSchema_ReturnsAFreshInstanceEveryCall; +begin + const Tool = ToolFor('Add'); + + const First = Tool.GetInputSchema; + const Second = Tool.GetInputSchema; + try + Assert.IsFalse(First = Second, 'the caller owns each schema, so each call builds one'); + Assert.AreEqual(First.ToJSON, Second.ToJSON); + finally + First.Free; + Second.Free; + end; +end; + +procedure TMethodToolTests.FreeingAnInputSchema_LeavesTheToolUsable; +begin + const Tool = ToolFor('Add'); + + Tool.GetInputSchema.Free; + + const Json = Run(Tool, '{"left":1,"right":1}'); + try + Assert.AreEqual(2, Json.GetValue('result'), 'validation still has its own schema'); + finally + Json.Free; + end; + + Tool.GetInputSchema.Free; +end; + +procedure TMethodToolTests.GetOutputSchema_ReturnsAFreshInstanceEveryCall; +begin + const Tool = ToolFor('Add'); + + const First = Tool.GetOutputSchema; + const Second = Tool.GetOutputSchema; + try + Assert.IsFalse(First = Second, 'the tools manager frees what GetOutputSchema hands it'); + Assert.AreEqual(First.ToJSON, Second.ToJSON); + finally + First.Free; + Second.Free; + end; +end; + +procedure TMethodToolTests.Procedure_HasNoOutputSchema; +begin + Assert.IsNull(ToolFor('Ping').GetOutputSchema, 'a procedure describes no structured result'); +end; + +procedure TMethodToolTests.OutputSchema_ValidatesTheDefaultFunctionResult; +begin + const Tool = ToolFor('Add'); + + const Schema = Tool.GetOutputSchema; + try + const Json = Run(Tool, '{"left":2,"right":3}'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.TryValidate(Schema, Json, Errors), + string.Join('; ', Errors)); + finally + Json.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TMethodToolTests.OutputSchema_ValidatesADtoArrayResult; +begin + const Tool = ToolFor('MakeLines'); + + const Schema = Tool.GetOutputSchema; + try + const Json = Run(Tool, '{}'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.TryValidate(Schema, Json, Errors), + string.Join('; ', Errors)); + finally + Json.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TMethodToolTests.Title_FallsBackToTheName; +begin + const Tool = ToolFor('Ping'); + + Assert.AreEqual('sample_ping', Tool.GetName); + Assert.AreEqual('sample_ping', Tool.GetTitle); + Assert.AreEqual('The Ping sample', Tool.GetDescription); +end; + +procedure TMethodToolTests.MarkReadOnly_PublishesTheHints; +begin + const Tool = TMCPMethodTool.Create(TValue.From(FTarget), MethodOf('Add'), 'sample_readonly', + 'A read-only tool'); + const AsInterface: IMCPTool = Tool; + + var Metadata: IMCPToolMetadata; + Assert.IsTrue(Supports(AsInterface, IMCPToolMetadata, Metadata)); + Assert.IsNull(Metadata.Annotations, 'nothing is published before MarkReadOnly'); + + Tool.MarkReadOnly; + + Assert.IsTrue(Metadata.Annotations.GetValue('readOnlyHint')); + Assert.IsFalse(Metadata.Annotations.GetValue('openWorldHint')); +end; + +procedure TMethodToolTests.ThroughTheManager_LogsNoOutputSchemaMismatch; +const + CALLS: array [0 .. 2] of string = ( + '{"name":"sample_add","arguments":{"left":1,"right":2}}', + '{"name":"sample_makelines","arguments":{}}', + '{"name":"sample_ping","arguments":{}}'); +begin + const Warnings = TStringList.Create; + const Manager: IMCPCapabilityManager = TMCPToolsManager.Create; + const Tools = Manager as TMCPToolsManager; + const OriginalLevel = TLogger.MinLogLevel; + try + Tools.AddTool(ToolFor('Add')); + Tools.AddTool(ToolFor('MakeLines')); + Tools.AddTool(ToolFor('Ping')); + + TLogger.MinLogLevel := TLogLevel.Debug; + TLogger.OnLogMessage := + procedure(const Message: string) + begin + if Message.Contains(MISMATCH_WARNING) then + Warnings.Add(Message); + end; + + for var Call in CALLS do + begin + const Params = TJSONObject.ParseJSONValue(Call) as TJSONObject; + try + Tools.CallTool(Params, TMCPProtocolEra.Modern).AsType.Free; + finally + Params.Free; + end; + end; + + Assert.AreEqual(0, Warnings.Count, string.Join('; ', Warnings.ToStringArray)); + finally + TLogger.OnLogMessage := nil; + TLogger.MinLogLevel := OriginalLevel; + Warnings.Free; + end; +end; + +procedure TMethodToolTests.ThroughTheManager_ReportsAnEnvelopeWithoutItsOutputSchema; +begin + const Warnings = TStringList.Create; + const Manager: IMCPCapabilityManager = TMCPToolsManager.Create; + const Tools = Manager as TMCPToolsManager; + const OriginalLevel = TLogger.MinLogLevel; + try + Tools.AddTool(TMismatchedTool.Create(TValue.From(FTarget), MethodOf('Add'), + 'sample_mismatch', 'An envelope that forgot its output schema')); + + TLogger.MinLogLevel := TLogLevel.Debug; + TLogger.OnLogMessage := + procedure(const Message: string) + begin + if Message.Contains(MISMATCH_WARNING) then + Warnings.Add(Message); + end; + + const Params = TJSONObject.ParseJSONValue( + '{"name":"sample_mismatch","arguments":{"left":1,"right":2}}') as TJSONObject; + try + Tools.CallTool(Params, TMCPProtocolEra.Modern).AsType.Free; + finally + Params.Free; + end; + + {$IFDEF DEBUG} + Assert.AreEqual(1, Warnings.Count, 'a DEBUG build reports the mismatch, so the quiet test above means something'); + {$ELSE} + Assert.AreEqual(0, Warnings.Count, 'only a DEBUG build validates structuredContent'); + {$ENDIF} + finally + TLogger.OnLogMessage := nil; + TLogger.MinLogLevel := OriginalLevel; + Warnings.Free; + end; +end; + +procedure TMethodToolTests.RecordParameter_IsMarshalled; +begin + const Json = Run(ToolFor('Area'), '{"box":{"width":3,"height":4}}'); + try + Assert.AreEqual(12, Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.RecordResult_IsTheResultMember; +begin + const Json = Run(ToolFor('Grow'), '{"box":{"width":3,"height":4}}'); + try + Assert.AreEqual('{"result":{"width":6,"height":8}}', Json.ToJSON); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.RecordResult_ValidatesAgainstItsOutputSchema; +begin + const Tool = ToolFor('Grow'); + + const Schema = Tool.GetOutputSchema; + try + Assert.IsNotNull(Schema, 'a record result describes itself'); + + const Json = Run(Tool, '{"box":{"width":1,"height":2}}'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.TryValidate(Schema, Json, Errors), + string.Join('; ', Errors)); + finally + Json.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TMethodToolTests.RecordParameter_IsPublishedAsAnObjectInTheInputSchema; +begin + const Schema = ToolFor('Area').GetInputSchema; + try + Assert.AreEqual('object', Schema.GetValue('properties.box.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.box.properties.width.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.box.properties.height.type')); + finally + Schema.Free; + end; +end; + +procedure TMethodToolTests.NestedRecordParameter_IsMarshalled; +begin + const Json = Run(ToolFor('Caption'), + '{"labelled":{"caption":"tile","box":{"width":2,"height":5},"note":"!"}}'); + try + Assert.AreEqual('tile 2x5!', Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.RecordParameter_OptionalFieldMayBeOmitted; +begin + const Json = Run(ToolFor('Caption'), '{"labelled":{"caption":"tile","box":{"width":2,"height":5}}}'); + try + Assert.AreEqual('tile 2x5', Json.GetValue('result')); + finally + Json.Free; + end; +end; + +procedure TMethodToolTests.RecordParameter_MissingFieldRaisesArgumentException; +begin + const Tool = ToolFor('Area'); + Assert.WillRaise( + procedure + begin + Run(Tool, '{"box":{"width":3}}').Free; + end, + EArgumentException); +end; + +procedure TMethodToolTests.RecordParameter_WrongFieldTypeRaisesArgumentException; +begin + const Tool = ToolFor('Area'); + Assert.WillRaise( + procedure + begin + Run(Tool, '{"box":{"width":"three","height":4}}').Free; + end, + EArgumentException); +end; + +end. diff --git a/tests/MCPServer.Tests.Mrtr.pas b/tests/MCPServer.Tests.Mrtr.pas new file mode 100644 index 0000000..8f1206a --- /dev/null +++ b/tests/MCPServer.Tests.Mrtr.pas @@ -0,0 +1,788 @@ +unit MCPServer.Tests.Mrtr; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + [TestFixture] + TRequestStateSealerTests = class + private + function Base64Url(const Bytes: TBytes): string; + 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; + + [Test] + procedure EmptyKey_DiffersPerInstance; + + [Test] + procedure Open_PayloadIsNotAnObject_IsInvalidParams; + 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.Classes, + System.Hash, + System.NetEncoding, + MCPServer.Errors, + MCPServer.Mrtr; + +const + SEALER_KEY = 'unit-test-key'; + DIGEST_A = 'digest-a'; + PRINCIPAL_A = 'alice'; + +{ TRequestStateSealerTests } + +function TRequestStateSealerTests.Base64Url(const Bytes: TBytes): string; +begin + Result := TNetEncoding.Base64.EncodeBytesToString(Bytes) + .Replace(#13, '').Replace(#10, '').Replace('+', '-').Replace('/', '_').TrimRight(['=']); +end; + +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; + +procedure TRequestStateSealerTests.EmptyKey_DiffersPerInstance; +begin + var First := TMCPRequestStateSealer.Create(''); + var Second := TMCPRequestStateSealer.Create(''); + try + var FirstToken := First.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + var SecondToken := Second.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.AreNotEqual(FirstToken, SecondToken, 'a random key is not derived from the clock'); + Assert.WillRaise( + procedure + begin + Second.Open(FirstToken, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError, 'another instance cannot open the token'); + finally + Second.Free; + First.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_PayloadIsNotAnObject_IsInvalidParams; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + try + var Payload := TEncoding.UTF8.GetBytes('"a signed string, not an object"'); + var Signature := THashSHA2.GetHMACAsBytes(Payload, TEncoding.UTF8.GetBytes(SEALER_KEY), + THashSHA2.TSHA2Version.SHA256); + var Token := Base64Url(Payload) + '.' + Base64Url(Signature); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError); + finally + 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; + const ParamsIsEmpty = (Params = ''); + if ParamsIsEmpty 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]); + const HasExtraParams = (ExtraParams <> ''); + if HasExtraParams 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.PathBoundary.pas b/tests/MCPServer.Tests.PathBoundary.pas new file mode 100644 index 0000000..d2f1b3d --- /dev/null +++ b/tests/MCPServer.Tests.PathBoundary.pas @@ -0,0 +1,88 @@ +unit MCPServer.Tests.PathBoundary; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TPathBoundaryTest = class + private + FBase: string; + public + [Setup] + procedure Setup; + + [Test] + procedure IsWithin_BaseItself_ReturnsTrue; + + [Test] + procedure IsWithin_BaseWithTrailingDelimiter_ReturnsTrue; + + [Test] + procedure IsWithin_ChildDirectory_ReturnsTrue; + + [Test] + procedure IsWithin_SiblingWithSamePrefix_ReturnsFalse; + + [Test] + procedure IsWithin_ParentTraversal_ReturnsFalse; + + [Test] + procedure IsWithin_UnrelatedDirectory_ReturnsFalse; + end; + +implementation + +uses + System.SysUtils, + System.IOUtils, + MCPServer.PathBoundary; + +procedure TPathBoundaryTest.Setup; +begin + FBase := TPath.Combine(TPath.GetTempPath, 'mcp-server'); +end; + +procedure TPathBoundaryTest.IsWithin_BaseItself_ReturnsTrue; +begin + Assert.IsTrue(TPathBoundary.IsWithin(FBase, FBase)); +end; + +procedure TPathBoundaryTest.IsWithin_BaseWithTrailingDelimiter_ReturnsTrue; +begin + const PathWithDelimiter = IncludeTrailingPathDelimiter(FBase); + + Assert.IsTrue(TPathBoundary.IsWithin(PathWithDelimiter, FBase)); +end; + +procedure TPathBoundaryTest.IsWithin_ChildDirectory_ReturnsTrue; +begin + const Child = TPath.Combine(FBase, 'data'); + + Assert.IsTrue(TPathBoundary.IsWithin(Child, FBase)); +end; + +procedure TPathBoundaryTest.IsWithin_SiblingWithSamePrefix_ReturnsFalse; +begin + const Sibling = FBase + '-secrets'; + + Assert.IsFalse(TPathBoundary.IsWithin(Sibling, FBase), 'A sibling directory that shares the name prefix is outside the base'); +end; + +procedure TPathBoundaryTest.IsWithin_ParentTraversal_ReturnsFalse; +begin + const Traversal = TPath.Combine(FBase, '..\other'); + + Assert.IsFalse(TPathBoundary.IsWithin(Traversal, FBase)); +end; + +procedure TPathBoundaryTest.IsWithin_UnrelatedDirectory_ReturnsFalse; +begin + const Unrelated = TPath.Combine(TPath.GetTempPath, 'elsewhere'); + + Assert.IsFalse(TPathBoundary.IsWithin(Unrelated, FBase)); +end; + +end. diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas new file mode 100644 index 0000000..75c8cdb --- /dev/null +++ b/tests/MCPServer.Tests.Processor.pas @@ -0,0 +1,398 @@ +unit MCPServer.Tests.Processor; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + System.Rtti, + MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + TProbeManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx) + private + FSeenContext: IMCPRequestContext; + FSeenCurrent: IMCPRequestContext; + public + 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; + property SeenContext: IMCPRequestContext read FSeenContext write FSeenContext; + property SeenCurrent: IMCPRequestContext read FSeenCurrent write FSeenCurrent; + 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, + System.Generics.Collections; + +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 + FSeenContext := Context; + FSeenCurrent := 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..3d5f00b --- /dev/null +++ b/tests/MCPServer.Tests.Prompt.pas @@ -0,0 +1,241 @@ +unit MCPServer.Tests.Prompt; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.JSON, + 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 WithAnnotations_BeforeAnyMessage_AttachesToTheNextMessage; + + [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 + +uses + System.Generics.Collections; + +{ 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; + const ToneIsEmpty = (Tone = ''); + if ToneIsEmpty 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_BeforeAnyMessage_AttachesToTheNextMessage; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var Messages := TMCPPromptMessages.Create.WithAnnotations(Annotations).AddText('user', 'first'); + Messages.AddText('user', 'second'); + var Json := Messages.ToJson; + try + Assert.AreEqual(0.5, Json.Items[0].GetValue('content.annotations.priority'), 0.0001); + Assert.IsNull(Json.Items[1].FindValue('content.annotations')); + 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..9607e6d --- /dev/null +++ b/tests/MCPServer.Tests.PromptsManager.pas @@ -0,0 +1,228 @@ +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, + MCPServer.Errors, + System.Generics.Collections; + +{ 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..659fe15 --- /dev/null +++ b/tests/MCPServer.Tests.Registration.pas @@ -0,0 +1,117 @@ +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.IsTrue(Length(TMCPRegistry.GetToolNames) >= 4, 'the built-in tools are registered'); +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.IsTrue(Length(TMCPRegistry.GetResourceURIs) >= 4, 'the built-in resources are registered'); +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.IsTrue(Length(TMCPRegistry.GetPromptNames) >= 1, 'the built-in prompts are registered'); +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, EMCPRegistryNotFound); +end; + +procedure TRegistryTests.CreateResource_UnknownUri_Raises; +begin + var Probe: TProc := + procedure + begin + TMCPRegistry.CreateResource('nope://missing'); + end; + Assert.WillRaise(Probe, EMCPRegistryNotFound); +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..26d8310 --- /dev/null +++ b/tests/MCPServer.Tests.RequestContext.pas @@ -0,0 +1,415 @@ +unit MCPServer.Tests.RequestContext; + +interface + +uses + DUnitX.TestFramework, + 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; + function Request(const Method: string; const ParamsJson: string = ''): string; + 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, + System.Generics.Collections; + +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"}'; + +{ TRequestContextTests } + +function TRequestContextTests.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; + +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..a08103a --- /dev/null +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -0,0 +1,424 @@ +unit MCPServer.Tests.ResourcesManager; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.JSON, + MCPServer.Types, + MCPServer.Resource.Base, + MCPServer.ResourcesManager; + +type + EFailingResource = class(Exception) + end; + + 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.Threading, + MCPServer.Errors, + System.Generics.Collections; + +{ TFailingResource } + +constructor TFailingResource.Create; +begin + inherited; + FURI := 'test://failing'; + FName := 'Failing'; + FMimeType := 'application/json'; +end; + +function TFailingResource.GetResourceData: TFailingData; +begin + raise EFailingResource.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; +var + Mismatches: Integer; +begin + Mismatches := 0; + TParallel.For(1, READS, + procedure(Index: Integer) + begin + const Json = Read(Format('echo://item%d', [Index]), TMCPProtocolEra.Modern); + try + const Expected = Format('{"value":"item%d"}', [Index]); + const IsExpected = (Json.GetValue('contents[0].text') = Expected); + if not IsExpected then + AtomicIncrement(Mismatches); + finally + Json.Free; + end; + end); + + Assert.AreEqual(0, Mismatches, 'every concurrent read resolved its own template variables'); +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..4accbf6 --- /dev/null +++ b/tests/MCPServer.Tests.Schema.pas @@ -0,0 +1,300 @@ +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 + begin + Assert.AreNotEqual('code', Item.Value); + end; + 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.SchemaFromMethod.pas b/tests/MCPServer.Tests.SchemaFromMethod.pas new file mode 100644 index 0000000..803a802 --- /dev/null +++ b/tests/MCPServer.Tests.SchemaFromMethod.pas @@ -0,0 +1,1240 @@ +unit MCPServer.Tests.SchemaFromMethod; + +interface + +uses + DUnitX.TestFramework, + System.Rtti, + System.JSON, + System.Generics.Collections, + MCPServer.Types; + +type + TShipMode = (Standard, Express); + + TMoney = record + Amount: Double; + Currency: string; + end; + + TAddress = record + Street: string; + City: string; + end; + + TContact = record + Name: string; + Home: TAddress; + end; + + TBasket = record + Owner: string; + Skus: TArray; + end; + + TSelfNode = record + Name: string; + Children: TArray; + end; + + TAnnotatedFields = record + private + FChecksum: Integer; + public + [SchemaName('placed_at')] + [SchemaTitle('Placed at')] + [SchemaDescription('When the order was placed')] + [SchemaFormat('date')] + PlacedAt: TDateTime; + + [SchemaMinimum(1)] + [SchemaMaximum(10)] + Count: Integer; + + [SchemaMinLength(2)] + [SchemaMaxLength(8)] + [SchemaPattern('^[a-z]+$')] + [SchemaDefault('"abc"')] + Code: string; + + [Optional] + Note: string; + + function Checksum: Integer; + end; + + TOrderLine = class + private + FSku: string; + FQuantity: Integer; + public + property Sku: string read FSku write FSku; + property Quantity: Integer read FQuantity write FQuantity; + end; + + [SchemaDialect('https://json-schema.org/draft/2020-12/schema')] + TDialectFilter = class + private + FName: string; + public + property Name: string read FName write FName; + end; + + TOrderFilter = class + private + FCustomer: string; + FLimit: Integer; + public + [SchemaDescription('Customer code')] + property Customer: string read FCustomer write FCustomer; + [Optional] + property Limit: Integer read FLimit write FLimit; + end; + + TPricedLine = class + private + FSku: string; + FPrice: TMoney; + public + property Sku: string read FSku write FSku; + property Price: TMoney read FPrice write FPrice; + end; + + TCarrier = class + private + FName: string; + public + property Name: string read FName write FName; + end; + + TShipment = record + Reference: string; + Carrier: TCarrier; + end; + +{$RTTI EXPLICIT FIELDS([vcPublic])} + + TDocumentedMoney = record + private + FInternal: Integer; + public + [SchemaDescription('Amount in the smallest unit')] + [SchemaMinimum(0)] + Amount: Double; + + function Internal: Integer; + end; + +{$RTTI EXPLICIT FIELDS([])} + + TOpaqueMoney = record + Amount: Double; + end; + +{$RTTI EXPLICIT FIELDS([vcPrivate, vcProtected, vcPublic])} + + TRawFrame = record + Tag: Byte; + Payload: array[0..3] of Byte; + end; + + TTaggedFilter = class + private + FId: TGUID; + FName: string; + public + property Id: TGUID read FId write FId; + property Name: string read FName write FName; + end; + + TLegacyDoneEvent = procedure of object; + + TLegacyFilter = class + private + FAnything: Variant; + FThing: IInterface; + FOnDone: TLegacyDoneEvent; + FKind: TClass; + FMoney: TOpaqueMoney; + FCount: Integer; + public + property Anything: Variant read FAnything write FAnything; + property Thing: IInterface read FThing write FThing; + property OnDone: TLegacyDoneEvent read FOnDone write FOnDone; + property Kind: TClass read FKind write FKind; + property Money: TOpaqueMoney read FMoney write FMoney; + property Count: Integer read FCount write FCount; + end; + + TSampleService = class + public + procedure NoParameters; + procedure Primitives(const Name: string; const Count: Integer; const Ratio: Double; + const Flag: Boolean); + procedure Scheduled(const When: TDateTime; const Mode: TShipMode); + procedure WithFilter(const Filter: TOrderFilter); + procedure WithSkus(const Skus: TArray); + procedure WithLines(const Lines: TArray); + procedure WithLineList(const Lines: TList); + procedure WithOptionalLimit(const Customer: string; [Optional] const Limit: Integer); + procedure Annotated( + [SchemaDescription('How many')] [SchemaMinimum(1)] [SchemaMaximum(10)] const Count: Integer; + [SchemaName('colour_tag')] [SchemaPattern('^[a-z]+$')] const Tag: string); + procedure MixedCase(const CustomerCode: string); + procedure Untyped(var Anything); + procedure OutParameter(out Total: Integer); + procedure VarParameter(var Total: Integer); + procedure WithDialect(const Filter: TDialectFilter); + procedure WithInterface(const Thing: IInterface); + procedure WithMoney(const Money: TMoney); + procedure WithContact(const Contact: TContact); + procedure WithBasket(const Basket: TBasket); + procedure WithMoneys(const Moneys: TArray); + procedure WithPricedLine(const Line: TPricedLine); + procedure WithShipment(const Shipment: TShipment); + procedure WithAnnotatedFields(const Stamped: TAnnotatedFields); + procedure WithSelfNode(const Node: TSelfNode); + procedure WithDocumentedMoney(const Money: TDocumentedMoney); + procedure WithOpaqueMoney(const Money: TOpaqueMoney); + procedure WithGuid(const Id: TGUID); + procedure WithRawFrame(const Frame: TRawFrame); + function CountOrders: Integer; + function DescribeOrder: string; + function FindLine: TOrderLine; + function FindLines: TArray; + function Total: TMoney; + function MakeDialect: TDialectFilter; + function OpaqueTotal: TOpaqueMoney; + function FindThing: IInterface; + function MakeGuid: TGUID; + end; + + [TestFixture] + TSchemaFromMethodTests = class + private + FContext: TRttiContext; + function MethodOf(const MethodName: string): TRttiMethod; + function SchemaOf(const MethodName: string): TJSONObject; + function ResultSchemaOf(const MethodName: string): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure NoParameters_GivesAnEmptyObjectSchema; + + [Test] + procedure Primitives_MapToJsonTypes; + + [Test] + procedure DateTime_IsStringWithFormat; + + [Test] + procedure Enumeration_IsStringWithItsNames; + + [Test] + procedure ClassParameter_DelegatesToGenerateSchema; + + [Test] + procedure ArrayParameter_IsArrayWithItems; + + [Test] + procedure ClassArrayParameter_ItemsAreTheDtoSchema; + + [Test] + procedure ListParameter_IsArrayWithItems; + + [Test] + procedure Optional_KeepsAParameterOutOfRequired; + + [Test] + procedure EveryOtherParameter_IsRequiredInDeclarationOrder; + + [Test] + procedure SchemaName_OverridesTheWireName; + + [Test] + procedure WireName_IsTheLowerCasedParameterName; + + [Test] + procedure ParameterAttributes_AreApplied; + + [Test] + procedure MethodSchema_ForbidsAdditionalProperties; + + [Test] + procedure UntypedParameter_IsRejected; + + [Test] + procedure OutParameter_IsRejected_NamingTheParameter; + + [Test] + procedure VarParameter_IsRejected_NamingTheParameter; + + [Test] + procedure Dialect_IsNotCopiedIntoAParameterSchema; + + [Test] + procedure Dialect_IsNotCopiedIntoAResultSchema; + + [Test] + procedure Dialect_StaysOnTheSchemaOfTheClassItself; + + [Test] + procedure Procedure_HasNoResultSchema; + + [Test] + procedure IntegerResult_IsWrappedInRequiredResult; + + [Test] + procedure StringResult_IsAString; + + [Test] + procedure ClassResult_IsTheDtoSchema; + + [Test] + procedure ClassArrayResult_IsAnArrayOfTheDtoSchema; + + [Test] + procedure RecordResult_IsTheRecordSchema; + + [Test] + procedure RecordParameter_IsAnObjectWithItsFields; + + [Test] + procedure RecordParameter_MatchesWhatSchemaFromTypeProduces; + + [Test] + procedure NestedRecord_IsDescribedInPlace; + + [Test] + procedure RecordInsideAClass_IsDescribed; + + [Test] + procedure ClassInsideARecord_IsDescribed; + + [Test] + procedure RecordArrayParameter_ItemsAreTheRecordSchema; + + [Test] + procedure RecordHoldingAnArray_IsDescribed; + + [Test] + procedure RecordFieldAttributes_AreApplied; + + [Test] + procedure OptionalRecordField_StaysOutOfRequired; + + [Test] + procedure PrivateRecordField_IsNotDescribed; + + [Test] + procedure SelfReferencingRecord_StopsAtTheDepthGuard; + + [Test] + procedure RecordWithDocumentedFieldRtti_KeepsItsFieldsAndAttributes; + + [Test] + procedure RecordWithoutFieldRtti_IsRejected; + + [Test] + procedure RecordResultWithoutFieldRtti_HasNoResultSchema; + + [Test] + procedure InterfaceParameter_IsRejected; + + [Test] + procedure InterfaceResult_HasNoResultSchema; + + [Test] + procedure GuidParameter_IsAStringWithUuidFormat; + + [Test] + procedure GuidProperty_IsAStringWithUuidFormat; + + [Test] + procedure GuidResult_IsAStringWithUuidFormat; + + [Test] + procedure FieldWithoutTypeRtti_IsRejectedNamingTheField; + + [Test] + procedure UndescribablePropertyKinds_StayStringsOnTheClassWalk; + + [Test] + procedure OpaqueRecordProperty_StaysAStringOnTheClassWalk; + + [Test] + procedure SchemaFromType_DescribesAPrimitiveAnArrayAndAClass; + + [Test] + procedure SchemaFromType_GivesNilForNoType; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Schema.Generator; + +{ TAnnotatedFields } + +function TAnnotatedFields.Checksum: Integer; +begin + Result := FChecksum; +end; + +{ TDocumentedMoney } + +function TDocumentedMoney.Internal: Integer; +begin + Result := FInternal; +end; + +{ TSampleService } + +procedure TSampleService.NoParameters; +begin +end; + +procedure TSampleService.Primitives(const Name: string; const Count: Integer; const Ratio: Double; + const Flag: Boolean); +begin +end; + +procedure TSampleService.Scheduled(const When: TDateTime; const Mode: TShipMode); +begin +end; + +procedure TSampleService.WithFilter(const Filter: TOrderFilter); +begin +end; + +procedure TSampleService.WithSkus(const Skus: TArray); +begin +end; + +procedure TSampleService.WithLines(const Lines: TArray); +begin +end; + +procedure TSampleService.WithLineList(const Lines: TList); +begin +end; + +procedure TSampleService.WithOptionalLimit(const Customer: string; const Limit: Integer); +begin +end; + +procedure TSampleService.Annotated(const Count: Integer; const Tag: string); +begin +end; + +procedure TSampleService.MixedCase(const CustomerCode: string); +begin +end; + +procedure TSampleService.Untyped(var Anything); +begin +end; + +procedure TSampleService.OutParameter(out Total: Integer); +begin + Total := 0; +end; + +procedure TSampleService.VarParameter(var Total: Integer); +begin + Total := 0; +end; + +procedure TSampleService.WithDialect(const Filter: TDialectFilter); +begin +end; + +procedure TSampleService.WithInterface(const Thing: IInterface); +begin +end; + +procedure TSampleService.WithMoney(const Money: TMoney); +begin +end; + +procedure TSampleService.WithContact(const Contact: TContact); +begin +end; + +procedure TSampleService.WithBasket(const Basket: TBasket); +begin +end; + +procedure TSampleService.WithMoneys(const Moneys: TArray); +begin +end; + +procedure TSampleService.WithPricedLine(const Line: TPricedLine); +begin +end; + +procedure TSampleService.WithShipment(const Shipment: TShipment); +begin +end; + +procedure TSampleService.WithAnnotatedFields(const Stamped: TAnnotatedFields); +begin +end; + +procedure TSampleService.WithSelfNode(const Node: TSelfNode); +begin +end; + +procedure TSampleService.WithDocumentedMoney(const Money: TDocumentedMoney); +begin +end; + +procedure TSampleService.WithOpaqueMoney(const Money: TOpaqueMoney); +begin +end; + +procedure TSampleService.WithGuid(const Id: TGUID); +begin +end; + +procedure TSampleService.WithRawFrame(const Frame: TRawFrame); +begin +end; + +function TSampleService.CountOrders: Integer; +begin + Result := 0; +end; + +function TSampleService.DescribeOrder: string; +begin + Result := ''; +end; + +function TSampleService.FindLine: TOrderLine; +begin + Result := nil; +end; + +function TSampleService.FindLines: TArray; +begin + Result := nil; +end; + +function TSampleService.Total: TMoney; +begin + Result := Default(TMoney); +end; + +function TSampleService.MakeDialect: TDialectFilter; +begin + Result := nil; +end; + +function TSampleService.OpaqueTotal: TOpaqueMoney; +begin + Result := Default(TOpaqueMoney); +end; + +function TSampleService.FindThing: IInterface; +begin + Result := nil; +end; + +function TSampleService.MakeGuid: TGUID; +begin + Result := TGUID.Empty; +end; + +{ TSchemaFromMethodTests } + +procedure TSchemaFromMethodTests.Setup; +begin + FContext := TRttiContext.Create; +end; + +procedure TSchemaFromMethodTests.TearDown; +begin + FContext.Free; +end; + +function TSchemaFromMethodTests.MethodOf(const MethodName: string): TRttiMethod; +begin + Result := FContext.GetType(TSampleService).GetMethod(MethodName); + Assert.IsNotNull(Result, 'TSampleService.' + MethodName + ' has no method RTTI'); +end; + +function TSchemaFromMethodTests.SchemaOf(const MethodName: string): TJSONObject; +begin + Result := TMCPSchemaGenerator.GenerateSchemaFromMethod(MethodOf(MethodName)); +end; + +function TSchemaFromMethodTests.ResultSchemaOf(const MethodName: string): TJSONObject; +begin + Result := TMCPSchemaGenerator.GenerateSchemaFromMethodResult(MethodOf(MethodName)); +end; + +procedure TSchemaFromMethodTests.NoParameters_GivesAnEmptyObjectSchema; +begin + var Schema := SchemaOf('NoParameters'); + try + Assert.AreEqual('object', Schema.GetValue('type')); + Assert.AreEqual(0, (Schema.GetValue('properties') as TJSONObject).Count); + Assert.IsNull(Schema.GetValue('required')); + Assert.IsFalse(Schema.GetValue('additionalProperties')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.Primitives_MapToJsonTypes; +begin + var Schema := SchemaOf('Primitives'); + try + Assert.AreEqual('string', Schema.GetValue('properties.name.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.count.type')); + Assert.AreEqual('number', Schema.GetValue('properties.ratio.type')); + Assert.AreEqual('boolean', Schema.GetValue('properties.flag.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.DateTime_IsStringWithFormat; +begin + var Schema := SchemaOf('Scheduled'); + try + Assert.AreEqual('string', Schema.GetValue('properties.when.type')); + Assert.AreEqual('date-time', Schema.GetValue('properties.when.format')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.Enumeration_IsStringWithItsNames; +begin + var Schema := SchemaOf('Scheduled'); + try + Assert.AreEqual('string', Schema.GetValue('properties.mode.type')); + Assert.AreEqual('Standard', Schema.GetValue('properties.mode.enum[0]')); + Assert.AreEqual('Express', Schema.GetValue('properties.mode.enum[1]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ClassParameter_DelegatesToGenerateSchema; +begin + var Schema := SchemaOf('WithFilter'); + try + var Expected := TMCPSchemaGenerator.GenerateSchema(TOrderFilter); + try + Assert.AreEqual(Expected.ToJSON, (Schema.FindValue('properties.filter') as TJSONObject).ToJSON); + finally + Expected.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ArrayParameter_IsArrayWithItems; +begin + var Schema := SchemaOf('WithSkus'); + try + Assert.AreEqual('array', Schema.GetValue('properties.skus.type')); + Assert.AreEqual('string', Schema.GetValue('properties.skus.items.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ClassArrayParameter_ItemsAreTheDtoSchema; +begin + var Schema := SchemaOf('WithLines'); + try + Assert.AreEqual('array', Schema.GetValue('properties.lines.type')); + Assert.AreEqual('object', Schema.GetValue('properties.lines.items.type')); + Assert.AreEqual('string', Schema.GetValue('properties.lines.items.properties.sku.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.lines.items.properties.quantity.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ListParameter_IsArrayWithItems; +begin + var Schema := SchemaOf('WithLineList'); + try + Assert.AreEqual('array', Schema.GetValue('properties.lines.type')); + Assert.AreEqual('object', Schema.GetValue('properties.lines.items.type')); + Assert.AreEqual('string', Schema.GetValue('properties.lines.items.properties.sku.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.Optional_KeepsAParameterOutOfRequired; +begin + var Schema := SchemaOf('WithOptionalLimit'); + try + Assert.AreEqual('integer', Schema.GetValue('properties.limit.type')); + + var Required := Schema.GetValue('required') as TJSONArray; + Assert.AreEqual(1, Required.Count); + Assert.AreEqual('customer', Required.Items[0].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.EveryOtherParameter_IsRequiredInDeclarationOrder; +begin + var Schema := SchemaOf('Primitives'); + try + var Required := Schema.GetValue('required') as TJSONArray; + Assert.AreEqual(4, Required.Count); + Assert.AreEqual('name', Required.Items[0].Value); + Assert.AreEqual('count', Required.Items[1].Value); + Assert.AreEqual('ratio', Required.Items[2].Value); + Assert.AreEqual('flag', Required.Items[3].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.SchemaName_OverridesTheWireName; +begin + var Schema := SchemaOf('Annotated'); + try + Assert.AreEqual('string', Schema.GetValue('properties.colour_tag.type')); + Assert.IsNull(Schema.GetValue('properties.tag')); + + var Required := Schema.GetValue('required') as TJSONArray; + Assert.AreEqual('colour_tag', Required.Items[1].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.WireName_IsTheLowerCasedParameterName; +begin + var Schema := SchemaOf('MixedCase'); + try + Assert.AreEqual('string', Schema.GetValue('properties.customercode.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ParameterAttributes_AreApplied; +begin + var Schema := SchemaOf('Annotated'); + 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('^[a-z]+$', Schema.GetValue('properties.colour_tag.pattern')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.MethodSchema_ForbidsAdditionalProperties; +begin + var Schema := SchemaOf('Primitives'); + try + Assert.AreEqual('object', Schema.GetValue('type')); + Assert.IsFalse(Schema.GetValue('additionalProperties')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.UntypedParameter_IsRejected; +begin + const Method = MethodOf('Untyped'); + Assert.WillRaise( + procedure + begin + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + end, + EArgumentException); +end; + +procedure TSchemaFromMethodTests.Procedure_HasNoResultSchema; +begin + Assert.IsNull(ResultSchemaOf('NoParameters')); +end; + +procedure TSchemaFromMethodTests.IntegerResult_IsWrappedInRequiredResult; +begin + var Schema := ResultSchemaOf('CountOrders'); + try + Assert.AreEqual('object', Schema.GetValue('type')); + Assert.AreEqual('integer', Schema.GetValue('properties.result.type')); + + var Required := Schema.GetValue('required') as TJSONArray; + Assert.AreEqual(1, Required.Count); + Assert.AreEqual('result', Required.Items[0].Value); + Assert.IsFalse(Schema.GetValue('additionalProperties')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.StringResult_IsAString; +begin + var Schema := ResultSchemaOf('DescribeOrder'); + try + Assert.AreEqual('string', Schema.GetValue('properties.result.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ClassResult_IsTheDtoSchema; +begin + var Schema := ResultSchemaOf('FindLine'); + try + var Expected := TMCPSchemaGenerator.GenerateSchema(TOrderLine); + try + Assert.AreEqual(Expected.ToJSON, (Schema.FindValue('properties.result') as TJSONObject).ToJSON); + finally + Expected.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ClassArrayResult_IsAnArrayOfTheDtoSchema; +begin + var Schema := ResultSchemaOf('FindLines'); + try + Assert.AreEqual('array', Schema.GetValue('properties.result.type')); + Assert.AreEqual('object', Schema.GetValue('properties.result.items.type')); + Assert.AreEqual('string', Schema.GetValue('properties.result.items.properties.sku.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordResult_IsTheRecordSchema; +begin + var Schema := ResultSchemaOf('Total'); + try + Assert.AreEqual('object', Schema.GetValue('properties.result.type')); + Assert.AreEqual('number', Schema.GetValue('properties.result.properties.amount.type')); + Assert.AreEqual('string', Schema.GetValue('properties.result.properties.currency.type')); + + const Required = Schema.FindValue('properties.result.required') as TJSONArray; + Assert.AreEqual(2, Required.Count); + Assert.AreEqual('amount', Required.Items[0].Value); + Assert.AreEqual('currency', Required.Items[1].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordParameter_IsAnObjectWithItsFields; +begin + var Schema := SchemaOf('WithMoney'); + try + Assert.AreEqual('object', Schema.GetValue('properties.money.type')); + Assert.AreEqual('number', Schema.GetValue('properties.money.properties.amount.type')); + Assert.AreEqual('string', Schema.GetValue('properties.money.properties.currency.type')); + + const Required = Schema.FindValue('properties.money.required') as TJSONArray; + Assert.AreEqual(2, Required.Count); + Assert.AreEqual('amount', Required.Items[0].Value); + Assert.AreEqual('currency', Required.Items[1].Value); + Assert.IsNull(Schema.FindValue('properties.money.additionalProperties'), + 'a record with fields says as little about additional properties as a class with properties'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordParameter_MatchesWhatSchemaFromTypeProduces; +begin + var Schema := SchemaOf('WithMoney'); + try + const Parameters = MethodOf('WithMoney').GetParameters; + var Expected := TMCPSchemaGenerator.GenerateSchemaFromType(Parameters[0].ParamType); + try + Assert.AreEqual(Expected.ToJSON, (Schema.FindValue('properties.money') as TJSONObject).ToJSON); + finally + Expected.Free; + end; + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.NestedRecord_IsDescribedInPlace; +begin + var Schema := SchemaOf('WithContact'); + try + Assert.AreEqual('string', Schema.GetValue('properties.contact.properties.name.type')); + Assert.AreEqual('object', Schema.GetValue('properties.contact.properties.home.type')); + Assert.AreEqual('string', + Schema.GetValue('properties.contact.properties.home.properties.street.type')); + Assert.AreEqual('string', + Schema.GetValue('properties.contact.properties.home.properties.city.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordInsideAClass_IsDescribed; +begin + var Schema := SchemaOf('WithPricedLine'); + try + Assert.AreEqual('string', Schema.GetValue('properties.line.properties.sku.type')); + Assert.AreEqual('object', Schema.GetValue('properties.line.properties.price.type')); + Assert.AreEqual('number', + Schema.GetValue('properties.line.properties.price.properties.amount.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.ClassInsideARecord_IsDescribed; +begin + var Schema := SchemaOf('WithShipment'); + try + Assert.AreEqual('string', Schema.GetValue('properties.shipment.properties.reference.type')); + Assert.AreEqual('object', Schema.GetValue('properties.shipment.properties.carrier.type')); + Assert.AreEqual('string', + Schema.GetValue('properties.shipment.properties.carrier.properties.name.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordArrayParameter_ItemsAreTheRecordSchema; +begin + var Schema := SchemaOf('WithMoneys'); + try + Assert.AreEqual('array', Schema.GetValue('properties.moneys.type')); + Assert.AreEqual('object', Schema.GetValue('properties.moneys.items.type')); + Assert.AreEqual('number', Schema.GetValue('properties.moneys.items.properties.amount.type')); + Assert.AreEqual('string', Schema.GetValue('properties.moneys.items.properties.currency.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordHoldingAnArray_IsDescribed; +begin + var Schema := SchemaOf('WithBasket'); + try + Assert.AreEqual('string', Schema.GetValue('properties.basket.properties.owner.type')); + Assert.AreEqual('array', Schema.GetValue('properties.basket.properties.skus.type')); + Assert.AreEqual('string', Schema.GetValue('properties.basket.properties.skus.items.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordFieldAttributes_AreApplied; +begin + var Schema := SchemaOf('WithAnnotatedFields'); + try + const Fields = Schema.FindValue('properties.stamped.properties') as TJSONObject; + + Assert.IsNotNull(Fields.GetValue('placed_at'), '[SchemaName] renames the field'); + Assert.IsNull(Fields.GetValue('placedat'), 'and the field name itself is gone'); + Assert.AreEqual('Placed at', Fields.GetValue('placed_at.title')); + Assert.AreEqual('When the order was placed', Fields.GetValue('placed_at.description')); + Assert.AreEqual('date', Fields.GetValue('placed_at.format'), + 'SchemaFormat replaces the date-time a TDateTime carries by default'); + + Assert.AreEqual(1, Fields.GetValue('count.minimum')); + Assert.AreEqual(10, Fields.GetValue('count.maximum')); + + Assert.AreEqual(2, Fields.GetValue('code.minLength')); + Assert.AreEqual(8, Fields.GetValue('code.maxLength')); + Assert.AreEqual('^[a-z]+$', Fields.GetValue('code.pattern')); + Assert.AreEqual('abc', Fields.GetValue('code.default')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.OptionalRecordField_StaysOutOfRequired; +begin + var Schema := SchemaOf('WithAnnotatedFields'); + try + Assert.AreEqual('string', Schema.GetValue('properties.stamped.properties.note.type'), + 'an optional field is still described'); + + const Required = Schema.FindValue('properties.stamped.required') as TJSONArray; + Assert.AreEqual(3, Required.Count); + Assert.AreEqual('placed_at', Required.Items[0].Value); + Assert.AreEqual('count', Required.Items[1].Value); + Assert.AreEqual('code', Required.Items[2].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.PrivateRecordField_IsNotDescribed; +begin + var Schema := SchemaOf('WithAnnotatedFields'); + try + const Fields = Schema.FindValue('properties.stamped.properties') as TJSONObject; + Assert.AreEqual(4, Fields.Count, 'only the public fields are on the wire'); + Assert.IsNull(Fields.GetValue('fchecksum')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.SelfReferencingRecord_StopsAtTheDepthGuard; +begin + var Schema := SchemaOf('WithSelfNode'); + try + var Level := Schema.FindValue('properties.node') as TJSONObject; + var Depth := 0; + while Assigned(Level.FindValue('properties.children.items.properties')) do + begin + Level := Level.FindValue('properties.children.items') as TJSONObject; + Inc(Depth); + Assert.IsTrue(Depth < 32, 'the walk must stop, not recurse forever'); + end; + + Assert.IsTrue(Depth > 0, 'the record describes itself at least once'); + Assert.AreEqual('object', + (Level.FindValue('properties.children.items') as TJSONObject).GetValue('type'), + 'the deepest level is an opaque object, not another walk'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordWithDocumentedFieldRtti_KeepsItsFieldsAndAttributes; +begin + var Schema := SchemaOf('WithDocumentedMoney'); + try + Assert.AreEqual('number', Schema.GetValue('properties.money.properties.amount.type')); + Assert.AreEqual('Amount in the smallest unit', + Schema.GetValue('properties.money.properties.amount.description')); + Assert.AreEqual(0, Schema.GetValue('properties.money.properties.amount.minimum')); + + const Fields = Schema.FindValue('properties.money.properties') as TJSONObject; + Assert.AreEqual(1, Fields.Count, + 'FIELDS([vcPublic]) publishes the public fields and leaves the private one off the wire'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.RecordWithoutFieldRtti_IsRejected; +begin + const Method = MethodOf('WithOpaqueMoney'); + Assert.WillRaiseWithMessage( + procedure + begin + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + end, + EArgumentException, + 'Parameter "Money" of WithOpaqueMoney is record TOpaqueMoney, which publishes no field RTTI, ' + + 'so it has no schema. Declare it in a unit whose field RTTI covers its public fields, for ' + + 'example {$RTTI EXPLICIT FIELDS([vcPublic])}.'); +end; + +procedure TSchemaFromMethodTests.RecordResultWithoutFieldRtti_HasNoResultSchema; +begin + Assert.IsNull(ResultSchemaOf('OpaqueTotal'), + 'a result whose members cannot be seen is published as no output schema at all'); +end; + +procedure TSchemaFromMethodTests.InterfaceParameter_IsRejected; +begin + const Method = MethodOf('WithInterface'); + Assert.WillRaiseWithMessage( + procedure + begin + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + end, + EArgumentException, + 'Parameter "Thing" of WithInterface is of type IInterface, which has no JSON schema'); +end; + +procedure TSchemaFromMethodTests.InterfaceResult_HasNoResultSchema; +begin + Assert.IsNull(ResultSchemaOf('FindThing'), + 'a result that cannot cross a wire is published as no output schema at all'); +end; + +procedure TSchemaFromMethodTests.SchemaFromType_DescribesAPrimitiveAnArrayAndAClass; +begin + const Method = MethodOf('WithLines'); + const Parameters = Method.GetParameters; + + var ArraySchema := TMCPSchemaGenerator.GenerateSchemaFromType(Parameters[0].ParamType); + try + Assert.AreEqual('array', ArraySchema.GetValue('type')); + finally + ArraySchema.Free; + end; + + var IntegerSchema := TMCPSchemaGenerator.GenerateSchemaFromType(MethodOf('CountOrders').ReturnType); + try + Assert.AreEqual('integer', IntegerSchema.GetValue('type')); + finally + IntegerSchema.Free; + end; + + var DtoSchema := TMCPSchemaGenerator.GenerateSchemaFromType(MethodOf('FindLine').ReturnType); + try + Assert.AreEqual('object', DtoSchema.GetValue('type')); + Assert.AreEqual('integer', DtoSchema.GetValue('properties.quantity.type')); + finally + DtoSchema.Free; + end; +end; + +procedure TSchemaFromMethodTests.SchemaFromType_GivesNilForNoType; +begin + Assert.IsNull(TMCPSchemaGenerator.GenerateSchemaFromType(nil)); +end; + +procedure TSchemaFromMethodTests.OutParameter_IsRejected_NamingTheParameter; +begin + const Method = MethodOf('OutParameter'); + try + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + Assert.Fail('an out parameter is published as an input and its value is dropped, so it must be refused'); + except + on E: EArgumentException do + Assert.IsTrue(E.Message.Contains('Total'), 'the refusal does not name the parameter: ' + E.Message); + end; +end; + +procedure TSchemaFromMethodTests.VarParameter_IsRejected_NamingTheParameter; +begin + const Method = MethodOf('VarParameter'); + try + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + Assert.Fail('a var parameter is published as an input and its value is dropped, so it must be refused'); + except + on E: EArgumentException do + Assert.IsTrue(E.Message.Contains('Total'), 'the refusal does not name the parameter: ' + E.Message); + end; +end; + +procedure TSchemaFromMethodTests.Dialect_IsNotCopiedIntoAParameterSchema; +begin + var Schema := SchemaOf('WithDialect'); + try + Assert.AreEqual('object', Schema.GetValue('properties.filter.type')); + Assert.IsNull(Schema.FindValue('properties.filter.$schema'), '$schema is a root-only keyword'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.Dialect_IsNotCopiedIntoAResultSchema; +begin + var Schema := ResultSchemaOf('MakeDialect'); + try + Assert.AreEqual('object', Schema.GetValue('properties.result.type')); + Assert.IsNull(Schema.FindValue('properties.result.$schema'), '$schema is a root-only keyword'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.Dialect_StaysOnTheSchemaOfTheClassItself; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TDialectFilter); + try + Assert.AreEqual('https://json-schema.org/draft/2020-12/schema', Schema.GetValue('$schema')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.GuidParameter_IsAStringWithUuidFormat; +begin + var Schema := SchemaOf('WithGuid'); + try + Assert.AreEqual('string', Schema.GetValue('properties.id.type')); + Assert.AreEqual('uuid', Schema.GetValue('properties.id.format')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.GuidProperty_IsAStringWithUuidFormat; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TTaggedFilter); + try + Assert.AreEqual('string', Schema.GetValue('properties.id.type'), + 'TGUID.D4 has no type RTTI, so a TGUID is described as the string it travels as'); + Assert.AreEqual('uuid', Schema.GetValue('properties.id.format')); + Assert.AreEqual('string', Schema.GetValue('properties.name.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.GuidResult_IsAStringWithUuidFormat; +begin + var Schema := ResultSchemaOf('MakeGuid'); + try + Assert.AreEqual('string', Schema.GetValue('properties.result.type')); + Assert.AreEqual('uuid', Schema.GetValue('properties.result.format')); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.FieldWithoutTypeRtti_IsRejectedNamingTheField; +begin + const Method = MethodOf('WithRawFrame'); + Assert.WillRaiseWithMessage( + procedure + begin + TMCPSchemaGenerator.GenerateSchemaFromMethod(Method).Free; + end, + EArgumentException, + 'Field TRawFrame.Payload has no type RTTI, so it has no schema'); +end; + +procedure TSchemaFromMethodTests.UndescribablePropertyKinds_StayStringsOnTheClassWalk; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TLegacyFilter); + try + Assert.AreEqual('string', Schema.GetValue('properties.anything.type')); + Assert.AreEqual('string', Schema.GetValue('properties.thing.type')); + Assert.AreEqual('string', Schema.GetValue('properties.ondone.type')); + Assert.AreEqual('string', Schema.GetValue('properties.kind.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.count.type'), + 'one property the generator cannot describe leaves the rest of the class described'); + finally + Schema.Free; + end; +end; + +procedure TSchemaFromMethodTests.OpaqueRecordProperty_StaysAStringOnTheClassWalk; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TLegacyFilter); + try + Assert.AreEqual('string', Schema.GetValue('properties.money.type'), + 'a record whose fields are invisible keeps the string every record was described as'); + Assert.IsNull(Schema.FindValue('properties.money.properties')); + 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..1aaea92 --- /dev/null +++ b/tests/MCPServer.Tests.SchemaValidator.pas @@ -0,0 +1,326 @@ +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.TryValidate(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.TryValidate(Schema, TextInstance, Errors)); + Assert.IsTrue(TMCPSchemaValidator.TryValidate(Schema, NullInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(Schema, WholeInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(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.TryValidate(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.TryValidate(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.TryValidate(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.TryValidate(Schema, InRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(Schema, BelowRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(Schema, Ok, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(Schema, TooShort, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(Schema, TooLong, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(Schema, Allowed, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(Schema, SameValue, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(Schema, Valid, Errors)); + Assert.IsFalse(TMCPSchemaValidator.TryValidate(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.TryValidate(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.TryValidate(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.TryValidate(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..348fc2d --- /dev/null +++ b/tests/MCPServer.Tests.Serializer.pas @@ -0,0 +1,289 @@ +unit MCPServer.Tests.Serializer; + +interface + +uses + DUnitX.TestFramework, + 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, + System.Generics.Collections; + +{ 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..6a651e5 --- /dev/null +++ b/tests/MCPServer.Tests.ServerStatus.pas @@ -0,0 +1,131 @@ +unit MCPServer.Tests.ServerStatus; + +interface + +uses + DUnitX.TestFramework; + +type + TServerCounters = record + RequestCount: Int64; + ActiveConnections: Integer; + end; + + [TestFixture] + TServerStatusResourceTests = class + private + function ReadCounters: TServerCounters; + 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; + +function TServerStatusResourceTests.ReadCounters: TServerCounters; +begin + Result := Default(TServerCounters); + var Resource: IMCPResource := TServerStatusResource.Create; + const Status = TJSONObject.ParseJSONValue(Resource.Read) as TJSONObject; + try + Assert.IsNotNull(Status, 'server://status must return a JSON object'); + Result.RequestCount := Status.GetValue('requestcount'); + Result.ActiveConnections := Status.GetValue('activeconnections'); + finally + Status.Free; + end; +end; + +procedure TServerStatusResourceTests.Counters_StartAtZero; +begin + const Counters = ReadCounters; + + Assert.AreEqual(Int64(0), Counters.RequestCount); + Assert.AreEqual(0, Counters.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); + + const Counters = ReadCounters; + + Assert.AreEqual(Int64(THREAD_COUNT) * ITERATIONS_PER_THREAD, Counters.RequestCount, 'lost request increments'); + Assert.AreEqual(0, Counters.ActiveConnections, 'every opened connection was closed'); +end; + +procedure TServerStatusResourceTests.ConnectionClosed_NeverGoesBelowZero; +begin + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionOpened; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + + const Counters = ReadCounters; + + Assert.AreEqual(0, Counters.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.Settings.pas b/tests/MCPServer.Tests.Settings.pas new file mode 100644 index 0000000..32a181d --- /dev/null +++ b/tests/MCPServer.Tests.Settings.pas @@ -0,0 +1,338 @@ +unit MCPServer.Tests.Settings; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TMCPSettingsTest = class + private + FDirectory: string; + function TempSettingsPath: string; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure Create_WithoutFile_LoadsExpectedDefaults; + + [Test] + procedure Create_WithoutFile_LoadsExpectedLimitDefaults; + + [Test] + procedure Create_EmptyPathAndNoCreate_CreatesNoFile; + + [Test] + procedure Create_MissingPathAndNoCreate_CreatesNoFile; + + [Test] + procedure Create_MissingPathAndCreate_WritesDefaultsToFile; + + [Test] + procedure Protocol_SslDisabled_ReturnsHttp; + + [Test] + procedure Protocol_SslEnabled_ReturnsHttps; + + [Test] + procedure SetProperties_ReadBack_ReturnsAssignedValues; + + [Test] + procedure LoadFromFile_ExistingFile_OverridesDefaults; + + [Test] + procedure SaveToFile_ReloadedByNewInstance_RoundTripsValues; + + [Test] + procedure AllowedOrigins_SecurityOriginsEmpty_FallsBackToCorsOrigins; + + [Test] + procedure AllowedOrigins_SecurityOriginsSet_WinsOverCorsOrigins; + + [Test] + procedure AllowedHostList_MixedSpacingAndBlanks_ReturnsTrimmedEntries; + + [Test] + procedure BearerTokenList_EmptyValue_ReturnsEmptyArray; + + [Test] + procedure ScopesSupportedList_TwoScopes_ReturnsBothScopes; + end; + +implementation + +uses + System.SysUtils, + System.IniFiles, + System.IOUtils, + MCPServer.Settings; + +{ TMCPSettingsTest } + +procedure TMCPSettingsTest.Setup; +begin + FDirectory := TPath.Combine(TPath.GetTempPath, 'mcp-settings-' + TGuid.NewGuid.ToString); + TDirectory.CreateDirectory(FDirectory); +end; + +procedure TMCPSettingsTest.TearDown; +begin + if TDirectory.Exists(FDirectory) then + TDirectory.Delete(FDirectory, True); +end; + +function TMCPSettingsTest.TempSettingsPath: string; +begin + Result := TPath.Combine(FDirectory, 'settings.ini'); +end; + +procedure TMCPSettingsTest.Create_WithoutFile_LoadsExpectedDefaults; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Assert.AreEqual(3000, Settings.Port); + Assert.AreEqual('localhost', Settings.Host); + Assert.AreEqual('delphi-mcp-server', Settings.ServerName); + Assert.AreEqual('1.0.0', Settings.ServerVersion); + Assert.AreEqual('/mcp', Settings.Endpoint); + Assert.IsTrue(Settings.CorsEnabled); + Assert.IsFalse(Settings.SSLEnabled); + Assert.IsTrue(Settings.ExposeDiagnosticsResources); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.Create_WithoutFile_LoadsExpectedLimitDefaults; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Assert.AreEqual(TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES, Settings.MaxRequestBodyBytes); + Assert.AreEqual(TMCPSettings.DEFAULT_MAX_JSON_DEPTH, Settings.MaxJsonDepth); + Assert.AreEqual(TMCPSettings.DEFAULT_MAX_CONCURRENT_REQUESTS, Settings.MaxConcurrentRequests); + Assert.AreEqual(TMCPSettings.DEFAULT_REQUEST_STATE_TTL_SECONDS, Settings.RequestStateTtlSeconds); + Assert.AreEqual(0, Settings.MaxConnections); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.Create_EmptyPathAndNoCreate_CreatesNoFile; +begin + const ExpectedFile = TPath.Combine(ExtractFilePath(ParamStr(0)), 'settings.ini'); + const ExistedBefore = TFile.Exists(ExpectedFile); + + const Settings = TMCPSettings.Create('', False); + try + Assert.AreEqual(ExpectedFile, Settings.SettingsFile); + Assert.AreEqual(ExistedBefore, TFile.Exists(ExpectedFile), + 'Create with an empty path and ACreateFile False must never write a settings file'); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.Create_MissingPathAndNoCreate_CreatesNoFile; +begin + const SettingsFile = TempSettingsPath; + + const Settings = TMCPSettings.Create(SettingsFile, False); + try + Assert.AreEqual(SettingsFile, Settings.SettingsFile); + Assert.IsFalse(TFile.Exists(SettingsFile)); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.Create_MissingPathAndCreate_WritesDefaultsToFile; +begin + const SettingsFile = TempSettingsPath; + + const Settings = TMCPSettings.Create(SettingsFile, True); + try + Assert.IsTrue(TFile.Exists(SettingsFile)); + finally + Settings.Free; + end; + + const IniFile = TIniFile.Create(SettingsFile); + try + Assert.AreEqual(3000, IniFile.ReadInteger('Server', 'Port', 0)); + Assert.AreEqual('localhost', IniFile.ReadString('Server', 'Host', '')); + Assert.IsFalse(IniFile.ReadBool('SSL', 'Enabled', True)); + finally + IniFile.Free; + end; +end; + +procedure TMCPSettingsTest.Protocol_SslDisabled_ReturnsHttp; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Assert.IsFalse(Settings.SSLEnabled); + + Assert.AreEqual('http', Settings.Protocol); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.Protocol_SslEnabled_ReturnsHttps; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.SSLEnabled := True; + + Assert.AreEqual('https', Settings.Protocol); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.SetProperties_ReadBack_ReturnsAssignedValues; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.Port := 8080; + Settings.Host := '127.0.0.1'; + Settings.ServerName := 'custom-server'; + Settings.Endpoint := '/agent'; + + Assert.AreEqual(8080, Settings.Port); + Assert.AreEqual('127.0.0.1', Settings.Host); + Assert.AreEqual('custom-server', Settings.ServerName); + Assert.AreEqual('/agent', Settings.Endpoint); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.LoadFromFile_ExistingFile_OverridesDefaults; +begin + const SettingsFile = TempSettingsPath; + + const IniFile = TIniFile.Create(SettingsFile); + try + IniFile.WriteInteger('Server', 'Port', 9123); + IniFile.WriteString('Server', 'Name', 'from-file'); + IniFile.WriteBool('SSL', 'Enabled', True); + IniFile.WriteString('Security', 'AllowedHosts', 'localhost:9123'); + finally + IniFile.Free; + end; + + const Settings = TMCPSettings.Create(SettingsFile, False); + try + Assert.AreEqual(9123, Settings.Port); + Assert.AreEqual('from-file', Settings.ServerName); + Assert.AreEqual('https', Settings.Protocol); + Assert.AreEqual('localhost:9123', Settings.AllowedHosts); + Assert.AreEqual('localhost', Settings.Host, 'A key absent from the file keeps its default'); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.SaveToFile_ReloadedByNewInstance_RoundTripsValues; +begin + const SettingsFile = TempSettingsPath; + + const Written = TMCPSettings.Create(SettingsFile, False); + try + Written.Port := 8123; + Written.ServerName := 'round-trip'; + Written.BearerTokens := 'alpha,beta'; + Written.MaxJsonDepth := 12; + Written.SaveToFile; + finally + Written.Free; + end; + + const Reloaded = TMCPSettings.Create(SettingsFile, False); + try + Assert.AreEqual(8123, Reloaded.Port); + Assert.AreEqual('round-trip', Reloaded.ServerName); + Assert.AreEqual('alpha,beta', Reloaded.BearerTokens); + Assert.AreEqual(12, Reloaded.MaxJsonDepth); + Assert.AreEqual(2, Length(Reloaded.BearerTokenList)); + finally + Reloaded.Free; + end; +end; + +procedure TMCPSettingsTest.AllowedOrigins_SecurityOriginsEmpty_FallsBackToCorsOrigins; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.CorsAllowedOrigins := 'http://localhost'; + Settings.SecurityAllowedOrigins := ''; + + Assert.AreEqual('http://localhost', Settings.AllowedOrigins); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.AllowedOrigins_SecurityOriginsSet_WinsOverCorsOrigins; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.CorsAllowedOrigins := 'http://localhost'; + Settings.SecurityAllowedOrigins := 'https://example.test'; + + Assert.AreEqual('https://example.test', Settings.AllowedOrigins); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.AllowedHostList_MixedSpacingAndBlanks_ReturnsTrimmedEntries; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.AllowedHosts := ' localhost:3000 , ,127.0.0.1:3000'; + + const Hosts = Settings.AllowedHostList; + + Assert.AreEqual(2, Length(Hosts)); + Assert.AreEqual('localhost:3000', Hosts[0]); + Assert.AreEqual('127.0.0.1:3000', Hosts[1]); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.BearerTokenList_EmptyValue_ReturnsEmptyArray; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Assert.AreEqual('', Settings.BearerTokens); + + Assert.AreEqual(0, Length(Settings.BearerTokenList)); + finally + Settings.Free; + end; +end; + +procedure TMCPSettingsTest.ScopesSupportedList_TwoScopes_ReturnsBothScopes; +begin + const Settings = TMCPSettings.Create(TempSettingsPath, False); + try + Settings.ScopesSupported := 'mcp:read, mcp:write'; + + const Scopes = Settings.ScopesSupportedList; + + Assert.AreEqual(2, Length(Scopes)); + Assert.AreEqual('mcp:read', Scopes[0]); + Assert.AreEqual('mcp:write', Scopes[1]); + finally + Settings.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Stdio.pas b/tests/MCPServer.Tests.Stdio.pas new file mode 100644 index 0000000..ba0359e --- /dev/null +++ b/tests/MCPServer.Tests.Stdio.pas @@ -0,0 +1,368 @@ +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 GetById(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 + begin + Input := Input + Line + Separator; + end; + + 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.GetById(const Lines: TArray; const Id: string): TJSONObject; +begin + Result := FindById(Lines, Id); + Assert.IsNotNull(Result, Format('no message with id %s in %s', [Id, string.Join(' | ', Lines)])); +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 := GetById(Lines, '1'); + var Tools := GetById(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 := GetById(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 + begin + Assert.AreNotEqual(13, Integer(B), 'no CR on stdout'); + end; +end; + +procedure TStdioTransportTests.CrLf_Input_IsAccepted; +begin + var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"ping"}'], 2000, #13#10); + var Pong := GetById(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 := GetById(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 := GetById(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 := GetById(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 := GetById(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..ede9b22 --- /dev/null +++ b/tests/MCPServer.Tests.StdioChannel.pas @@ -0,0 +1,253 @@ +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; const MaxLineBytes: Integer): 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_ReportsReplacedUtf8_AsInvalid; + + [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; const MaxLineBytes: Integer): TArray; +var + Line: TMCPLine; +begin + Result := nil; + const Stream = TBytesStream.Create(Bytes); + const Reader = TMCPLineReader.Create(Stream, MaxLineBytes); + try + while Reader.TryReadLine(Line) do + begin + Result := Result + [Line]; + end; + finally + Reader.Free; + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Reader_SplitsOnLf_DropsCr_LastLineWithoutNewline; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes('one'#13#10'two'#10#10'three'), 1024); + Assert.AreEqual(4, Integer(Length(Lines))); + Assert.AreEqual('one', Lines[0].Text); + Assert.AreEqual('two', Lines[1].Text); + Assert.AreEqual('', Lines[2].Text); + Assert.AreEqual('three', Lines[3].Text); + for var Line in Lines do + begin + Assert.IsTrue(Line.Status = TMCPLineStatus.Ok); + end; +end; + +procedure TStdioChannelTests.Reader_SkipsByteOrderMark; +begin + var Bytes := TBytes.Create($EF, $BB, $BF) + TEncoding.UTF8.GetBytes('{"a":1}'#10); + var Lines := ReadAll(Bytes, 1024); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.AreEqual('{"a":1}', Lines[0].Text); +end; + +procedure TStdioChannelTests.Reader_DecodesUtf8; +begin + var Probe := 'h' + Char($00E9) + 'llo w' + Char($00F6) + 'rld ' + Char($D83D) + Char($DE00); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Probe + #10), 1024); + Assert.AreEqual(Probe, Lines[0].Text); +end; + +procedure TStdioChannelTests.Reader_ReportsOverlongLine_AndContinues; +begin + var Long := StringOfChar('x', 100); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'short'#10), 50); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Lines[0].Status = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0].Text); + Assert.IsTrue(Lines[1].Status = TMCPLineStatus.Ok); + Assert.AreEqual('short', Lines[1].Text); +end; + +procedure TStdioChannelTests.Reader_OverlongLineWithoutNewline_EndsStream; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes(StringOfChar('x', 100)), 50); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.IsTrue(Lines[0].Status = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0].Text); +end; + +procedure TStdioChannelTests.Reader_OverlongLineBeyondChunk_IsSkippedUpToNewline; +const + BEYOND_ONE_CHUNK = 70 * 1024; + LIMIT = 1024; +begin + var Long := StringOfChar('y', BEYOND_ONE_CHUNK); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'after'#10'last'), LIMIT); + Assert.AreEqual(3, Integer(Length(Lines))); + Assert.IsTrue(Lines[0].Status = TMCPLineStatus.TooLong); + Assert.IsTrue(Lines[1].Status = TMCPLineStatus.Ok); + Assert.AreEqual('after', Lines[1].Text); + Assert.IsTrue(Lines[2].Status = TMCPLineStatus.Ok); + Assert.AreEqual('last', Lines[2].Text); +end; + +procedure TStdioChannelTests.Reader_ReportsInvalidUtf8_AndContinues; +begin + var Bytes := TBytes.Create($FF, $FE, $41) + TEncoding.UTF8.GetBytes(#10'ok'#10); + var Lines := ReadAll(Bytes, 1024); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Lines[0].Status = TMCPLineStatus.InvalidUtf8, 'first line is not UTF-8'); + Assert.AreEqual('ok', Lines[1].Text); +end; + +procedure TStdioChannelTests.Reader_ReportsReplacedUtf8_AsInvalid; +begin + var Truncated := TBytes.Create($41, $C3) + TEncoding.UTF8.GetBytes(#10); + var Overlong := TBytes.Create($C0, $AF) + TEncoding.UTF8.GetBytes(#10'ok'#10); + var Lines := ReadAll(Truncated + Overlong, 1024); + Assert.AreEqual(3, Integer(Length(Lines))); + Assert.IsTrue(Lines[0].Status = TMCPLineStatus.InvalidUtf8, 'a truncated sequence is not UTF-8'); + Assert.IsTrue(Lines[1].Status = TMCPLineStatus.InvalidUtf8, 'an overlong sequence is not UTF-8'); + Assert.IsTrue(Lines[2].Status = TMCPLineStatus.Ok); + Assert.AreEqual('ok', Lines[2].Text); +end; + +procedure TStdioChannelTests.Reader_EmptyStream_HasNoLines; +begin + var Lines := ReadAll(nil, 1024); + 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 + begin + SinkIntf.Send('{"thread":' + ThreadNo.ToString + ',"payload":"' + StringOfChar('x', 300) + '"}'); + end; + 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..1324954 --- /dev/null +++ b/tests/MCPServer.Tests.Subscriptions.pas @@ -0,0 +1,482 @@ +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) + private + FEvents: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + property Events: TStringList read FEvents; + 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, + MCPServer.Tests.Support; + +const + MODERN_META = TMCPTestMeta.MODERN_FIELDS; + 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; + FEvents := TStringList.Create; +end; + +destructor TRecordingHub.Destroy; +begin + FEvents.Free; + inherited; +end; + +procedure TRecordingHub.ToolsListChanged; +begin + FEvents.Add('tools'); +end; + +procedure TRecordingHub.PromptsListChanged; +begin + FEvents.Add('prompts'); +end; + +procedure TRecordingHub.ResourcesListChanged; +begin + FEvents.Add('resources'); +end; + +procedure TRecordingHub.ResourceUpdated(const Uri: string); +begin + FEvents.Add('updated:' + Uri); +end; + +procedure TRecordingHub.CloseAll(const Reason: string); +begin + FEvents.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 + TMCPTestWait.UntilTrue( + function: Boolean + begin + Result := (FManager.ActiveCount > 0) or (FError <> ''); + end, WAIT_MS); + 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; + TMCPTestWait.UntilTrue( + function: Boolean + begin + Result := FManager.ActiveCount = 0; + end, WAIT_MS); + 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; + TMCPTestWait.UntilTrue( + function: Boolean + begin + Result := FSink.KeepAlives >= 2; + end, WAIT_MS); + 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.Support.pas b/tests/MCPServer.Tests.Support.pas new file mode 100644 index 0000000..fafeaca --- /dev/null +++ b/tests/MCPServer.Tests.Support.pas @@ -0,0 +1,64 @@ +unit MCPServer.Tests.Support; + +interface + +uses + System.SysUtils, + System.JSON; + +type + TMCPTestMeta = record + public const + MODERN_FIELDS = '{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + MODERN_MEMBER = '"_meta":' + MODERN_FIELDS; + end; + + TMCPTestJson = record + public + class function ParseObject(const Text: string): TJSONObject; static; + end; + + TMCPTestWait = record + public const + DEFAULT_TIMEOUT_MS = 2000; + STEP_MS = 5; + public + class function UntilTrue(const Condition: TFunc; + const TimeoutMs: Cardinal = DEFAULT_TIMEOUT_MS): Boolean; static; + end; + +implementation + +uses + System.Classes, + DUnitX.TestFramework; + +{ TMCPTestJson } + +class function TMCPTestJson.ParseObject(const Text: string): TJSONObject; +begin + const Value = TJSONObject.ParseJSONValue(Text); + const IsObject = (Value is TJSONObject); + if not IsObject then + begin + Value.Free; + Assert.Fail('expected a JSON object but got: ' + Text); + end; + Result := TJSONObject(Value); +end; + +{ TMCPTestWait } + +class function TMCPTestWait.UntilTrue(const Condition: TFunc; + const TimeoutMs: Cardinal): Boolean; +begin + const Deadline = TThread.GetTickCount64 + TimeoutMs; + Result := Condition; + while not Result and (TThread.GetTickCount64 < Deadline) do + begin + TThread.Sleep(STEP_MS); + Result := Condition; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.ToolResult.pas b/tests/MCPServer.Tests.ToolResult.pas new file mode 100644 index 0000000..74d5dd8 --- /dev/null +++ b/tests/MCPServer.Tests.ToolResult.pas @@ -0,0 +1,190 @@ +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 Annotations_BeforeAnyBlock_AttachToTheNextBlock; + + [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_BeforeAnyBlock_AttachToTheNextBlock; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var ToolResult := TMCPToolResult.Create.WithAnnotations(Annotations).AddText('first').AddText('second'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.AreEqual(0.5, Json.GetValue('content[0].annotations.priority'), 0.0001); + Assert.IsNull(Json.FindValue('content[1].annotations')); + 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 + begin + Bytes[I] := Byte(I); + end; + var Encoded := TMCPContentBlock.EncodeBlob(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..0ba3594 --- /dev/null +++ b/tests/MCPServer.Tests.ToolsManager.pas @@ -0,0 +1,680 @@ +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; + + TReadOnlyTool = class(THandWrittenTool) + public + constructor Create; override; + end; + + TProbeTool = class(TMCPToolBase) + protected + function BuildSchema: TJSONObject; override; + function DoExecute(const Arguments: TJSONObject): TValue; override; + public + constructor CreateNamed(const AName: string); + end; + + TLegacyDoneEvent = procedure of object; + + TLegacyParams = class + private + FAnything: Variant; + FThing: IInterface; + FOnDone: TLegacyDoneEvent; + FKind: TClass; + FCount: Integer; + public + property Anything: Variant read FAnything write FAnything; + property Thing: IInterface read FThing write FThing; + property OnDone: TLegacyDoneEvent read FOnDone write FOnDone; + property Kind: TClass read FKind write FKind; + property Count: Integer read FCount write FCount; + end; + + TLegacyTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TLegacyParams): string; 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 UndescribableProperties_AreStringsAndHideNoOtherTool; + + [Test] + procedure MarkReadOnly_SetsBothHints_Once; + + [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; + + [TestFixture] + TToolsManagerIsolationTests = class + private + function ToolNames(const Manager: TMCPToolsManager): TArray; + function NewManagerWith(const SeedFromRegistry: Boolean; const ToolName: string): TMCPToolsManager; + function FirstRegisteredToolName: string; + public + [Test] + procedure Registry_HasAtLeastOneTool; + + [Test] + procedure NoSeed_PublishesNoRegistryTool; + + [Test] + procedure NoSeed_ListsOnlyItsOwnTool; + + [Test] + procedure NoSeed_TwoManagersDoNotShareTools; + + [Test] + procedure NoSeed_CallingARegistryTool_IsInvalidParams; + + [Test] + procedure NoSeed_RunsItsOwnTool; + + [Test] + procedure Parameterless_SeedsFromRegistry; + + [Test] + procedure SeedTrue_MatchesTheParameterlessConstructor; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors, + MCPServer.Registration, + System.Generics.Collections; + +const + PROBE_FIRST = 'probe_first'; + PROBE_SECOND = 'probe_second'; + +{ 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; + +{ TReadOnlyTool } + +constructor TReadOnlyTool.Create; +begin + inherited; + FName := 'read_only'; + MarkReadOnly(True); + MarkReadOnly(True); +end; + +{ TLegacyTool } + +constructor TLegacyTool.Create; +begin + inherited; + FName := 'legacy_variant'; + FDescription := 'A tool whose parameter class predates the schema rules'; +end; + +function TLegacyTool.ExecuteWithParams(const Params: TLegacyParams): string; +begin + Result := Params.Count.ToString; +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.UndescribableProperties_AreStringsAndHideNoOtherTool; +begin + FManager.AddTool(TLegacyTool.Create); + + const Json = FManager.ListTools(nil, TMCPProtocolEra.Legacy).AsType; + try + const Tools = Json.GetValue('tools') as TJSONArray; + const Last = Tools.Count - 1; + Assert.AreEqual('legacy_variant', Tools.Items[Last].GetValue('name')); + Assert.AreEqual('hand_written', Tools.Items[Last - 1].GetValue('name'), + 'a property the generator cannot describe hides no tool that was listed before it'); + Assert.AreEqual('doubling', Tools.Items[Last - 2].GetValue('name')); + Assert.AreEqual('echo', Json.GetValue('tools[0].name')); + + const Prefix = Format('tools[%d].inputSchema.properties.', [Last]); + Assert.AreEqual('string', Json.GetValue(Prefix + 'anything.type')); + Assert.AreEqual('string', Json.GetValue(Prefix + 'thing.type')); + Assert.AreEqual('string', Json.GetValue(Prefix + 'ondone.type')); + Assert.AreEqual('string', Json.GetValue(Prefix + 'kind.type')); + Assert.AreEqual('integer', Json.GetValue(Prefix + 'count.type')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.MarkReadOnly_SetsBothHints_Once; +begin + FManager.AddTool(TReadOnlyTool.Create); + var Json := FManager.ListTools(nil, TMCPProtocolEra.Legacy).AsType; + try + const Tools = Json.GetValue('tools') as TJSONArray; + var Annotations: TJSONObject := nil; + for var Tool in Tools do + begin + const IsReadOnlyTool = (Tool.GetValue('name') = 'read_only'); + if IsReadOnlyTool then + Annotations := (Tool as TJSONObject).GetValue('annotations') as TJSONObject; + end; + + Assert.IsNotNull(Annotations, 'the tool is listed with its annotations'); + Assert.IsTrue(Annotations.GetValue('readOnlyHint'), 'the tool reads only'); + Assert.IsTrue(Annotations.GetValue('openWorldHint'), 'the tool reaches outside the server'); + Assert.AreEqual(2, Annotations.Count, 'marking twice leaves one pair per hint'); + 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; + +{ TProbeTool } + +constructor TProbeTool.CreateNamed(const AName: string); +begin + inherited Create; + FName := AName; + FDescription := 'A probe tool handed to a single manager'; +end; + +function TProbeTool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{},"additionalProperties":false}') as TJSONObject; +end; + +function TProbeTool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From(FName + ' ran'); +end; + +{ TToolsManagerIsolationTests } + +function TToolsManagerIsolationTests.ToolNames(const Manager: TMCPToolsManager): TArray; +begin + Result := nil; + var Json := Manager.ListTools(nil, TMCPProtocolEra.Modern).AsType; + try + for var Tool in Json.GetValue('tools') as TJSONArray do + Result := Result + [Tool.GetValue('name')]; + finally + Json.Free; + end; +end; + +function TToolsManagerIsolationTests.NewManagerWith(const SeedFromRegistry: Boolean; + const ToolName: string): TMCPToolsManager; +begin + Result := TMCPToolsManager.Create(SeedFromRegistry); + Result.AddTool(TProbeTool.CreateNamed(ToolName)); +end; + +function TToolsManagerIsolationTests.FirstRegisteredToolName: string; +begin + var Names := TMCPRegistry.GetToolNames; + Assert.IsTrue(Length(Names) > 0, 'no tool is registered globally'); + Result := Names[0]; +end; + +procedure TToolsManagerIsolationTests.Registry_HasAtLeastOneTool; +begin + Assert.IsTrue(Length(TMCPRegistry.GetToolNames) > 0, + 'the seeding tests only mean something while the registry holds a tool'); +end; + +procedure TToolsManagerIsolationTests.NoSeed_PublishesNoRegistryTool; +begin + var Manager := TMCPToolsManager.Create(False); + try + for var ToolName in TMCPRegistry.GetToolNames do + Assert.IsFalse(Manager.HasTool(ToolName), 'an unseeded manager must not publish ' + ToolName); + Assert.AreEqual(0, Length(ToolNames(Manager)), 'an unseeded manager starts empty'); + finally + Manager.Free; + end; +end; + +procedure TToolsManagerIsolationTests.NoSeed_ListsOnlyItsOwnTool; +begin + var Manager := NewManagerWith(False, PROBE_FIRST); + try + var Names := ToolNames(Manager); + Assert.AreEqual(1, Length(Names), 'only the added tool is listed'); + Assert.AreEqual(PROBE_FIRST, Names[0]); + finally + Manager.Free; + end; +end; + +procedure TToolsManagerIsolationTests.NoSeed_TwoManagersDoNotShareTools; +begin + var First := NewManagerWith(False, PROBE_FIRST); + try + var Second := NewManagerWith(False, PROBE_SECOND); + try + Assert.IsTrue(First.HasTool(PROBE_FIRST)); + Assert.IsFalse(First.HasTool(PROBE_SECOND), 'the first manager sees only what it was given'); + Assert.IsTrue(Second.HasTool(PROBE_SECOND)); + Assert.IsFalse(Second.HasTool(PROBE_FIRST), 'the second manager sees only what it was given'); + finally + Second.Free; + end; + finally + First.Free; + end; +end; + +procedure TToolsManagerIsolationTests.NoSeed_CallingARegistryTool_IsInvalidParams; +begin + var Manager := NewManagerWith(False, PROBE_FIRST); + try + var Params := TJSONObject.ParseJSONValue( + '{"name":"' + FirstRegisteredToolName + '","arguments":{}}') as TJSONObject; + try + try + Manager.CallTool(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('a globally registered tool must not be callable on an unseeded manager'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code, E.Message); + end; + finally + Params.Free; + end; + finally + Manager.Free; + end; +end; + +procedure TToolsManagerIsolationTests.NoSeed_RunsItsOwnTool; +begin + var Manager := NewManagerWith(False, PROBE_FIRST); + try + var Params := TJSONObject.ParseJSONValue( + '{"name":"' + PROBE_FIRST + '","arguments":{}}') as TJSONObject; + try + var Json := Manager.CallTool(Params, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Json.GetValue('isError')); + Assert.AreEqual(PROBE_FIRST + ' ran', Json.GetValue('content[0].text')); + finally + Json.Free; + end; + finally + Params.Free; + end; + finally + Manager.Free; + end; +end; + +procedure TToolsManagerIsolationTests.Parameterless_SeedsFromRegistry; +begin + var Manager := TMCPToolsManager.Create; + try + for var ToolName in TMCPRegistry.GetToolNames do + Assert.IsTrue(Manager.HasTool(ToolName), 'the parameterless constructor still seeds ' + ToolName); + finally + Manager.Free; + end; +end; + +procedure TToolsManagerIsolationTests.SeedTrue_MatchesTheParameterlessConstructor; +begin + var Seeded := TMCPToolsManager.Create(True); + try + var Parameterless := TMCPToolsManager.Create; + try + Assert.AreEqual(string.Join(',', ToolNames(Parameterless)), string.Join(',', ToolNames(Seeded)), + 'Create(True) and Create publish the same tools in the same order'); + finally + Parameterless.Free; + end; + finally + Seeded.Free; + end; +end; + +end. diff --git a/tests/MCPServerTests.D11.dproj b/tests/MCPServerTests.D11.dproj new file mode 100644 index 0000000..d7c357b --- /dev/null +++ b/tests/MCPServerTests.D11.dproj @@ -0,0 +1,187 @@ + + + {C8F5D2E3-4B67-4A90-8C1D-E2F3A4B5C6D7} + MCPServerTests.dpr + True + Debug + 3 + Console + 19.5 + 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)\D11 + .\$(Platform)\$(Config)\D11 + 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/MCPServerTests.dpr b/tests/MCPServerTests.dpr new file mode 100644 index 0000000..ef2b721 --- /dev/null +++ b/tests/MCPServerTests.dpr @@ -0,0 +1,131 @@ +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.PathBoundary in '..\src\Core\MCPServer.PathBoundary.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.Tool.Method in '..\src\Tools\MCPServer.Tool.Method.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', + MCPServer.Host in '..\src\Server\MCPServer.Host.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.Support in 'MCPServer.Tests.Support.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.Settings in 'MCPServer.Tests.Settings.pas', + MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas', + MCPServer.Tests.Logger in 'MCPServer.Tests.Logger.pas', + MCPServer.Tests.PathBoundary in 'MCPServer.Tests.PathBoundary.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.HeaderEncoding in 'MCPServer.Tests.HeaderEncoding.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.Marshal in 'MCPServer.Tests.Marshal.pas', + MCPServer.Tests.Schema in 'MCPServer.Tests.Schema.pas', + MCPServer.Tests.SchemaFromMethod in 'MCPServer.Tests.SchemaFromMethod.pas', + MCPServer.Tests.MethodTool in 'MCPServer.Tests.MethodTool.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', + MCPServer.Tests.Host in 'MCPServer.Tests.Host.pas', + MCPServer.Tests.HttpCancellation in 'MCPServer.Tests.HttpCancellation.pas'; + +procedure RunTests; +begin + TDUnitX.CheckCommandLine; + + var Runner := TDUnitX.CreateRunner; + Runner.UseRTTI := True; + Runner.FailsOnNoAsserts := True; + + 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..6ab4e6b --- /dev/null +++ b/tests/MCPServerTests.dproj @@ -0,0 +1,187 @@ + + + {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..548e5bc --- /dev/null +++ b/tests/golden/README.md @@ -0,0 +1,61 @@ +# 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 | Verified by | +|---|---|---| +| `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr`, initialize-based protocol revisions | DUnitX fixture `TLegacyGoldenTests` | +| `modern/` | The same layer for requests that carry per-request `_meta` (MCP 2026-07-28), including the rejected shapes | DUnitX fixture `TModernGoldenTests` | + +## 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-tests.bat Debug Win64` (the test program is `tests\MCPServerTests.dpr`). +2. Run `tests\Win64\Debug\MCPServerTests.exe` once with the environment + variable `MCP_GOLDEN_RECORD=1`; this rewrites the `expected` sections. + Use `-run:` with fully qualified test names to re-record single cases. +3. Review the diff: only the cases whose behaviour changed on purpose may + differ. +4. The test program must be green without the variable 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. 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..83e9afd --- /dev/null +++ b/tests/golden/legacy/tools-list.json @@ -0,0 +1,394 @@ +{ + "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, + "openWorldHint": false + } + }, + { + "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..64f074f --- /dev/null +++ b/tests/golden/modern/tools-list.json @@ -0,0 +1,414 @@ +{ + "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, + "openWorldHint": false + } + }, + { + "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" + } + } + } +}