From 3400134efa52401aaff167884b930c23a0815143 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:02:33 +0200 Subject: [PATCH 01/56] test: add DUnitX harness and record legacy golden files Pins the JSON-RPC layer (37 cases through TMCPJsonRpcProcessor with the same registry as MCPServer.dpr) and the Streamable HTTP transport (26 curl cases against the built executable) as they behave on the unchanged 2025-06-18 code. - tests/MCPServer.Tests.dpr: DUnitX console runner, Win32 and Win64 - tests/MCPServer.Tests.Golden.pas: golden loader, mask and shape normalisation, record mode via MCP_GOLDEN_RECORD=1 - build-tests.bat, scripts/run-tests.ps1, scripts/capture-http-goldens.ps1 - tests/golden/README.md documents the format, the recording procedure and the current defects the goldens pin (logs://recent double free, nil params) --- .gitignore | 8 + build-tests.bat | 64 +++ scripts/capture-http-goldens.ps1 | 231 ++++++++++ scripts/run-tests.ps1 | 88 ++++ tests/MCPServer.Tests.Golden.Legacy.pas | 306 +++++++++++++ tests/MCPServer.Tests.Golden.pas | 406 ++++++++++++++++++ tests/MCPServer.Tests.Harness.pas | 76 ++++ tests/MCPServer.Tests.dpr | 72 ++++ tests/MCPServer.Tests.dproj | 128 ++++++ tests/fixtures/files/alpha.txt | 1 + tests/fixtures/files/beta.txt | 1 + tests/golden/README.md | 79 ++++ tests/golden/http/delete-endpoint.txt | 11 + tests/golden/http/get-endpoint-info.txt | 13 + tests/golden/http/get-sse-stream.txt | 14 + tests/golden/http/options-preflight.txt | 11 + .../golden/http/post-batch-notifications.txt | 11 + tests/golden/http/post-batch-requests.txt | 12 + tests/golden/http/post-client-response.txt | 11 + tests/golden/http/post-empty-body.txt | 12 + tests/golden/http/post-initialize-sse.txt | 18 + tests/golden/http/post-initialize.txt | 13 + tests/golden/http/post-no-accept-header.txt | 12 + .../http/post-notification-initialized.txt | 11 + tests/golden/http/post-origin-allowed.txt | 12 + tests/golden/http/post-origin-forbidden.txt | 6 + tests/golden/http/post-parse-error.txt | 12 + .../http/post-protocol-version-header.txt | 12 + tests/golden/http/post-resources-list.txt | 12 + .../http/post-resources-read-project-info.txt | 12 + .../http/post-session-echo-lowercase.txt | 13 + tests/golden/http/post-session-echo.txt | 13 + tests/golden/http/post-tools-call-echo.txt | 12 + tests/golden/http/post-tools-list-sse.txt | 18 + tests/golden/http/post-tools-list.txt | 12 + tests/golden/http/post-unknown-method.txt | 12 + tests/golden/http/post-wrong-path.txt | 11 + tests/golden/http/put-endpoint.txt | 11 + tests/golden/legacy/empty-body.json | 11 + tests/golden/legacy/id-null.json | 8 + tests/golden/legacy/id-string.json | 13 + .../golden/legacy/initialize-2025-03-26.json | 41 ++ .../golden/legacy/initialize-2025-06-18.json | 41 ++ .../golden/legacy/initialize-2025-11-25.json | 41 ++ .../legacy/initialize-unknown-version.json | 41 ++ .../legacy/initialize-without-params.json | 32 ++ .../golden/legacy/missing-jsonrpc-field.json | 12 + tests/golden/legacy/missing-method.json | 14 + .../legacy/notifications-initialized.json | 7 + tests/golden/legacy/params-not-an-object.json | 24 ++ tests/golden/legacy/parse-error.json | 11 + tests/golden/legacy/ping.json | 13 + .../golden/legacy/request-not-an-object.json | 11 + tests/golden/legacy/resources-list.json | 33 ++ .../legacy/resources-read-logs-recent.json | 23 + .../legacy/resources-read-project-info.json | 23 + .../legacy/resources-read-project-readme.json | 23 + .../legacy/resources-read-unknown-uri.json | 23 + .../legacy/resources-read-without-params.json | 18 + .../legacy/resources-templates-list.json | 15 + .../legacy/server-discover-without-meta.json | 15 + .../tools-call-calculate-divide-by-zero.json | 28 ++ tests/golden/legacy/tools-call-calculate.json | 27 ++ .../legacy/tools-call-echo-unicode.json | 25 ++ tests/golden/legacy/tools-call-echo.json | 25 ++ .../golden/legacy/tools-call-empty-name.json | 25 ++ tests/golden/legacy/tools-call-get-time.json | 27 ++ .../tools-call-invalid-argument-type.json | 27 ++ ...-list-files-outside-allowed-directory.json | 27 ++ .../golden/legacy/tools-call-list-files.json | 29 ++ .../legacy/tools-call-missing-arguments.json | 26 ++ .../legacy/tools-call-unknown-tool.json | 25 ++ .../legacy/tools-call-without-params.json | 20 + tests/golden/legacy/tools-list.json | 92 ++++ tests/golden/legacy/unknown-method.json | 15 + 75 files changed, 2688 insertions(+) create mode 100644 build-tests.bat create mode 100644 scripts/capture-http-goldens.ps1 create mode 100644 scripts/run-tests.ps1 create mode 100644 tests/MCPServer.Tests.Golden.Legacy.pas create mode 100644 tests/MCPServer.Tests.Golden.pas create mode 100644 tests/MCPServer.Tests.Harness.pas create mode 100644 tests/MCPServer.Tests.dpr create mode 100644 tests/MCPServer.Tests.dproj create mode 100644 tests/fixtures/files/alpha.txt create mode 100644 tests/fixtures/files/beta.txt create mode 100644 tests/golden/README.md create mode 100644 tests/golden/http/delete-endpoint.txt create mode 100644 tests/golden/http/get-endpoint-info.txt create mode 100644 tests/golden/http/get-sse-stream.txt create mode 100644 tests/golden/http/options-preflight.txt create mode 100644 tests/golden/http/post-batch-notifications.txt create mode 100644 tests/golden/http/post-batch-requests.txt create mode 100644 tests/golden/http/post-client-response.txt create mode 100644 tests/golden/http/post-empty-body.txt create mode 100644 tests/golden/http/post-initialize-sse.txt create mode 100644 tests/golden/http/post-initialize.txt create mode 100644 tests/golden/http/post-no-accept-header.txt create mode 100644 tests/golden/http/post-notification-initialized.txt create mode 100644 tests/golden/http/post-origin-allowed.txt create mode 100644 tests/golden/http/post-origin-forbidden.txt create mode 100644 tests/golden/http/post-parse-error.txt create mode 100644 tests/golden/http/post-protocol-version-header.txt create mode 100644 tests/golden/http/post-resources-list.txt create mode 100644 tests/golden/http/post-resources-read-project-info.txt create mode 100644 tests/golden/http/post-session-echo-lowercase.txt create mode 100644 tests/golden/http/post-session-echo.txt create mode 100644 tests/golden/http/post-tools-call-echo.txt create mode 100644 tests/golden/http/post-tools-list-sse.txt create mode 100644 tests/golden/http/post-tools-list.txt create mode 100644 tests/golden/http/post-unknown-method.txt create mode 100644 tests/golden/http/post-wrong-path.txt create mode 100644 tests/golden/http/put-endpoint.txt create mode 100644 tests/golden/legacy/empty-body.json create mode 100644 tests/golden/legacy/id-null.json create mode 100644 tests/golden/legacy/id-string.json create mode 100644 tests/golden/legacy/initialize-2025-03-26.json create mode 100644 tests/golden/legacy/initialize-2025-06-18.json create mode 100644 tests/golden/legacy/initialize-2025-11-25.json create mode 100644 tests/golden/legacy/initialize-unknown-version.json create mode 100644 tests/golden/legacy/initialize-without-params.json create mode 100644 tests/golden/legacy/missing-jsonrpc-field.json create mode 100644 tests/golden/legacy/missing-method.json create mode 100644 tests/golden/legacy/notifications-initialized.json create mode 100644 tests/golden/legacy/params-not-an-object.json create mode 100644 tests/golden/legacy/parse-error.json create mode 100644 tests/golden/legacy/ping.json create mode 100644 tests/golden/legacy/request-not-an-object.json create mode 100644 tests/golden/legacy/resources-list.json create mode 100644 tests/golden/legacy/resources-read-logs-recent.json create mode 100644 tests/golden/legacy/resources-read-project-info.json create mode 100644 tests/golden/legacy/resources-read-project-readme.json create mode 100644 tests/golden/legacy/resources-read-unknown-uri.json create mode 100644 tests/golden/legacy/resources-read-without-params.json create mode 100644 tests/golden/legacy/resources-templates-list.json create mode 100644 tests/golden/legacy/server-discover-without-meta.json create mode 100644 tests/golden/legacy/tools-call-calculate-divide-by-zero.json create mode 100644 tests/golden/legacy/tools-call-calculate.json create mode 100644 tests/golden/legacy/tools-call-echo-unicode.json create mode 100644 tests/golden/legacy/tools-call-echo.json create mode 100644 tests/golden/legacy/tools-call-empty-name.json create mode 100644 tests/golden/legacy/tools-call-get-time.json create mode 100644 tests/golden/legacy/tools-call-invalid-argument-type.json create mode 100644 tests/golden/legacy/tools-call-list-files-outside-allowed-directory.json create mode 100644 tests/golden/legacy/tools-call-list-files.json create mode 100644 tests/golden/legacy/tools-call-missing-arguments.json create mode 100644 tests/golden/legacy/tools-call-unknown-tool.json create mode 100644 tests/golden/legacy/tools-call-without-params.json create mode 100644 tests/golden/legacy/tools-list.json create mode 100644 tests/golden/legacy/unknown-method.json diff --git a/.gitignore b/.gitignore index 5de0fe5..65f6541 100644 --- a/.gitignore +++ b/.gitignore @@ -94,3 +94,11 @@ backup/ # Claude Code specific # Dependencies + +# Test and conformance output +tests/results/ +results/ + +# Node tooling for conformance and Inspector runs +node_modules/ +package-lock.json diff --git a/build-tests.bat b/build-tests.bat new file mode 100644 index 0000000..a90ce6f --- /dev/null +++ b/build-tests.bat @@ -0,0 +1,64 @@ +@echo off +setlocal EnableDelayedExpansion + +echo Delphi MCP Server Test Build Script (DUnitX) +echo ============================================ +echo. + +REM Set Delphi installation path - adjust if needed (same as build.bat) +set DELPHI_PATH=C:\Program Files (x86)\Embarcadero\Studio\37.0 + +if not exist "!DELPHI_PATH!\bin\dcc32.exe" ( + echo ERROR: dcc32.exe not found at !DELPHI_PATH!\bin\ + echo Please update DELPHI_PATH in this script to point to your Delphi installation + exit /b 1 +) + +set DCC32="!DELPHI_PATH!\bin\dcc32.exe" +set DCC64="!DELPHI_PATH!\bin\dcc64.exe" + +REM DUnitX ships with RAD Studio; the include path is needed for DUnitX.inc +set DUNITX_PATH=!DELPHI_PATH!\source\DUnitX + +set CONFIG=%1 +if "%CONFIG%"=="" set CONFIG=Debug + +set PLATFORM=%2 +if "%PLATFORM%"=="" set PLATFORM=Win32 + +set OUTPUT_DIR=.\tests\%PLATFORM%\%CONFIG% +if not exist %OUTPUT_DIR% mkdir %OUTPUT_DIR% + +set UNIT_PATHS=src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;tests +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% -I"!DUNITX_PATH!" -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServer.Tests.dpr + goto :CheckBuildResult +) else if "%PLATFORM%"=="Win64" ( + !DCC64! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win64\debug";%UNIT_PATHS% -I"!DUNITX_PATH!" -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServer.Tests.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%\MCPServer.Tests.exe + +endlocal diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 new file mode 100644 index 0000000..da80a84 --- /dev/null +++ b/scripts/capture-http-goldens.ps1 @@ -0,0 +1,231 @@ +<# +.SYNOPSIS + Records or verifies the HTTP transport golden files with curl. + +.DESCRIPTION + Starts the built server executable on a dedicated port, sends a fixed set + of requests with curl and stores status line, headers and body of each + response under tests\golden\http. In verify mode the stored files are + compared with a fresh capture. + + Volatile parts are normalised before storing: the Date and Server + headers are dropped, GUIDs become , SSE "id:" lines become + "id: ", and line endings are LF. + +.PARAMETER Record + Overwrite the stored golden files with the current responses. + +.PARAMETER ServerExe + Path to the server executable. Default: Win64\Debug\MCPServer.exe. + +.PARAMETER Port + TCP port the server is started on. Default: 3939. + +.EXAMPLE + .\scripts\capture-http-goldens.ps1 -Record + .\scripts\capture-http-goldens.ps1 +#> +[CmdletBinding()] +param( + [switch]$Record, + [string]$ServerExe, + [int]$Port = 3939 +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +if (-not $ServerExe) { + $ServerExe = Join-Path $repoRoot 'Win64\Debug\MCPServer.exe' +} +$ServerExe = (Resolve-Path $ServerExe).Path +$goldenDir = Join-Path $repoRoot 'tests\golden\http' +$resultsDir = Join-Path $repoRoot 'tests\results\http-golden' +$endpoint = "http://127.0.0.1:$Port/mcp" + +New-Item -ItemType Directory -Force -Path $goldenDir, $resultsDir | Out-Null + +$curl = Get-Command curl.exe -ErrorAction Stop + +# --------------------------------------------------------------------------- +# Server lifecycle: the server reads settings.ini next to its executable, so a +# temporary one with the test port is written and the original restored. +# --------------------------------------------------------------------------- +$exeDir = Split-Path -Parent $ServerExe +$settingsFile = Join-Path $exeDir 'settings.ini' +$settingsBackup = $null +if (Test-Path $settingsFile) { + $settingsBackup = Get-Content -Raw $settingsFile +} + +$settingsContent = @" +[Server] +Port=$Port +Host=localhost +Name=delphi-mcp-server +Version=1.0.0 +Endpoint=/mcp + +[CORS] +Enabled=1 +AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1 + +[SSL] +Enabled=0 +"@ +Set-Content -Path $settingsFile -Value $settingsContent -Encoding ASCII + +function Wait-ForPort([int]$PortNumber, [int]$TimeoutSeconds = 15) { + $deadline = (Get-Date).AddSeconds($TimeoutSeconds) + while ((Get-Date) -lt $deadline) { + $client = New-Object System.Net.Sockets.TcpClient + try { + $client.Connect('127.0.0.1', $PortNumber) + if ($client.Connected) { return $true } + } catch { + } finally { + $client.Dispose() + } + Start-Sleep -Milliseconds 200 + } + return $false +} + +$serverLog = Join-Path $resultsDir 'server.log' +$serverErr = Join-Path $resultsDir 'server.err.log' +$server = Start-Process -FilePath $ServerExe -WorkingDirectory $exeDir -PassThru -NoNewWindow ` + -RedirectStandardOutput $serverLog -RedirectStandardError $serverErr + +try { + if (-not (Wait-ForPort $Port)) { + throw "Server did not open port $Port within the timeout (see $serverLog)" + } + + # Observation for the PR description: which address does Indy bind to? + $listen = (netstat -ano | Select-String ":$Port\s" | Select-String 'LISTENING' | ForEach-Object { $_.Line.Trim() }) -join "`n" + Set-Content -Path (Join-Path $resultsDir 'listen.txt') -Value $listen -Encoding ASCII + Write-Host "Listening sockets:`n$listen" + + # ----------------------------------------------------------------------- + # Cases + # ----------------------------------------------------------------------- + $jsonAccept = 'Accept: application/json' + $sseAccept = 'Accept: application/json, text/event-stream' + $jsonType = 'Content-Type: application/json' + $initialize = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0.0"}}}' + + $cases = @( + @{ Name = 'post-initialize'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = $initialize } + @{ Name = 'post-initialize-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = $initialize } + @{ Name = 'post-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } + @{ Name = 'post-tools-list-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } + @{ Name = 'post-tools-call-echo'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hello golden"}}}' } + @{ Name = 'post-resources-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":4,"method":"resources/list"}' } + @{ Name = 'post-resources-read-project-info'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":5,"method":"resources/read","params":{"uri":"project://info"}}' } + @{ Name = 'post-notification-initialized'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","method":"notifications/initialized"}' } + @{ Name = 'post-client-response'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":1,"result":{}}' } + @{ Name = 'post-batch-notifications'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","method":"notifications/initialized"}]' } + @{ Name = 'post-batch-requests'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","id":6,"method":"ping"}]' } + @{ Name = 'post-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":7,"method":"prompts/list"}' } + @{ Name = 'post-parse-error'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":8,"method":' } + @{ Name = 'post-empty-body'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '' } + @{ Name = 'post-no-accept-header'; Method = 'POST'; Headers = @($jsonType); Body = '{"jsonrpc":"2.0","id":9,"method":"ping"}' } + @{ Name = 'post-session-echo'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Mcp-Session-Id: golden-session-1'); Body = '{"jsonrpc":"2.0","id":10,"method":"ping"}' } + @{ Name = 'post-session-echo-lowercase'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'mcp-session-id: golden-session-2'); Body = '{"jsonrpc":"2.0","id":11,"method":"ping"}' } + @{ Name = 'post-protocol-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 2025-06-18'); Body = '{"jsonrpc":"2.0","id":12,"method":"ping"}' } + @{ Name = 'post-origin-allowed'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Origin: http://localhost'); Body = '{"jsonrpc":"2.0","id":13,"method":"ping"}' } + @{ Name = 'post-origin-forbidden'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Origin: http://evil.example'); Body = '{"jsonrpc":"2.0","id":14,"method":"ping"}' } + @{ Name = 'post-wrong-path'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":15,"method":"ping"}'; Path = '/other' } + @{ Name = 'get-endpoint-info'; Method = 'GET'; Headers = @($jsonAccept) } + @{ Name = 'get-sse-stream'; Method = 'GET'; Headers = @('Accept: text/event-stream') } + @{ Name = 'options-preflight'; Method = 'OPTIONS'; Headers = @('Origin: http://localhost', 'Access-Control-Request-Method: POST', 'Access-Control-Request-Headers: Content-Type') } + @{ Name = 'delete-endpoint'; Method = 'DELETE'; Headers = @($jsonAccept) } + @{ Name = 'put-endpoint'; Method = 'PUT'; Headers = @($jsonType, $jsonAccept); Body = '{}' } + ) + + function Normalize-Response([string]$Text) { + $lines = ($Text -replace "`r`n", "`n").Split("`n") + $kept = New-Object System.Collections.Generic.List[string] + foreach ($line in $lines) { + if ($line -match '^(Date|Server):\s') { continue } + $normalized = $line + $normalized = [regex]::Replace($normalized, '\{?[0-9A-Fa-f]{8}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{12}\}?', '') + $normalized = [regex]::Replace($normalized, '^id: \d+$', 'id: ') + $kept.Add($normalized) + } + return ($kept -join "`n") + } + + $failures = 0 + $bodyFile = Join-Path $resultsDir 'request-body.tmp' + $responseFile = Join-Path $resultsDir 'response.tmp' + + foreach ($case in $cases) { + $path = if ($case.Path) { $case.Path } else { '/mcp' } + $url = "http://127.0.0.1:$Port$path" + $arguments = @('-s', '-i', '--http1.1', '-X', $case.Method, '-o', $responseFile) + foreach ($header in $case.Headers) { + $arguments += @('-H', $header) + } + if ($case.ContainsKey('Body')) { + [System.IO.File]::WriteAllBytes($bodyFile, [System.Text.Encoding]::UTF8.GetBytes([string]$case.Body)) + $arguments += @('--data-binary', "@$bodyFile") + } + $arguments += $url + + & $curl.Source @arguments + if ($LASTEXITCODE -ne 0) { + Write-Host "[$($case.Name)] curl failed with exit code $LASTEXITCODE" + $failures++ + continue + } + + $raw = [System.Text.Encoding]::UTF8.GetString([System.IO.File]::ReadAllBytes($responseFile)) + $actual = Normalize-Response $raw + $goldenFile = Join-Path $goldenDir "$($case.Name).txt" + + if ($Record) { + [System.IO.File]::WriteAllText($goldenFile, $actual + "`n", (New-Object System.Text.UTF8Encoding($false))) + Write-Host "[$($case.Name)] recorded" + continue + } + + if (-not (Test-Path $goldenFile)) { + Write-Host "[$($case.Name)] MISSING golden file (run with -Record)" + $failures++ + continue + } + + $expected = ([System.IO.File]::ReadAllText($goldenFile) -replace "`r`n", "`n").TrimEnd("`n") + if ($expected -eq $actual) { + Write-Host "[$($case.Name)] ok" + } else { + Write-Host "[$($case.Name)] MISMATCH" + Write-Host '--- expected ---' + Write-Host $expected + Write-Host '--- actual ---' + Write-Host $actual + Write-Host '---' + $failures++ + } + } + + Remove-Item $bodyFile, $responseFile -ErrorAction SilentlyContinue + + if ($failures -gt 0) { + Write-Host "$failures case(s) failed" + exit 1 + } + Write-Host 'All HTTP golden cases passed' +} +finally { + if ($server -and -not $server.HasExited) { + Stop-Process -Id $server.Id -Force + $server.WaitForExit(5000) | Out-Null + } + if ($null -ne $settingsBackup) { + Set-Content -Path $settingsFile -Value $settingsBackup -NoNewline + } else { + Remove-Item $settingsFile -ErrorAction SilentlyContinue + } +} diff --git a/scripts/run-tests.ps1 b/scripts/run-tests.ps1 new file mode 100644 index 0000000..c19ca01 --- /dev/null +++ b/scripts/run-tests.ps1 @@ -0,0 +1,88 @@ +<# +.SYNOPSIS + Builds and runs the DUnitX test project. + +.DESCRIPTION + Compiles tests\MCPServer.Tests.dpr with build-tests.bat and runs the + resulting executable. Results are written as NUnit XML to tests\results. + +.PARAMETER Configuration + Debug (default) or Release. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER Record + Re-record the golden files from the current code instead of comparing. + Only do this on a commit whose behaviour you want to pin; review the diff. + +.PARAMETER Filter + Optional DUnitX run filter with fully qualified test names, comma separated, + for example "MCPServer.Tests.Golden.Legacy.TLegacyGoldenTests.Ping". + +.PARAMETER NoBuild + Skip the compile step and run the existing executable. + +.EXAMPLE + .\scripts\run-tests.ps1 + .\scripts\run-tests.ps1 -Platform Win32 + .\scripts\run-tests.ps1 -Record +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Debug', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [switch]$Record, + + [string]$Filter, + + [switch]$NoBuild +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +$testExe = Join-Path $repoRoot "tests\$Platform\$Configuration\MCPServer.Tests.exe" +$resultsDir = Join-Path $repoRoot 'tests\results' +$xmlFile = Join-Path $resultsDir "dunitx-$Platform-$Configuration.xml" + +if (-not $NoBuild) { + Write-Host "Building tests ($Configuration $Platform)..." + & cmd.exe /c "cd /d `"$repoRoot`" && .\build-tests.bat $Configuration $Platform" + if ($LASTEXITCODE -ne 0) { + Write-Error "Test build failed with exit code $LASTEXITCODE" + exit $LASTEXITCODE + } +} + +if (-not (Test-Path $testExe)) { + Write-Error "Test executable not found: $testExe" + exit 1 +} + +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null + +if ($Record) { + $env:MCP_GOLDEN_RECORD = '1' + Write-Host 'Golden record mode: expectations will be rewritten.' +} else { + Remove-Item Env:\MCP_GOLDEN_RECORD -ErrorAction SilentlyContinue +} + +$arguments = @('-exit:continue', "-xml:$xmlFile") +if ($Filter) { + $arguments += "-run:$Filter" +} + +Write-Host "Running $testExe $($arguments -join ' ')" +& $testExe @arguments +$exitCode = $LASTEXITCODE + +Remove-Item Env:\MCP_GOLDEN_RECORD -ErrorAction SilentlyContinue + +Write-Host "Results: $xmlFile" +exit $exitCode diff --git a/tests/MCPServer.Tests.Golden.Legacy.pas b/tests/MCPServer.Tests.Golden.Legacy.pas new file mode 100644 index 0000000..a485455 --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -0,0 +1,306 @@ +unit MCPServer.Tests.Golden.Legacy; + +interface + +uses + DUnitX.TestFramework, + MCPServer.Tests.Harness, + MCPServer.Tests.Golden; + +type + /// Pins the legacy (initialize-based) wire behaviour of the JSON-RPC layer. + /// + /// Every test replays one file from tests\golden\legacy through a fresh + /// harness and compares the normalised response with the recorded one. + /// The only differences allowed after the recording are the items in the + /// allow-list of docs\mcp-2026-07-28-implementation-plan.md, section 4.3. + [TestFixture] + TLegacyGoldenTests = class + private + FHarness: TMCPTestHarness; + procedure CheckGolden(const CaseName: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + // Lifecycle + [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; + + // Tools + [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; + + // Resources + [Test] procedure Resources_List; + [Test] procedure Resources_Read_ProjectInfo; + [Test] procedure Resources_Read_ProjectReadme; + [Test] procedure Resources_Read_LogsRecent; + [Test] procedure Resources_Read_UnknownUri; + [Test] procedure Resources_Read_WithoutParams; + [Test] procedure Resources_Templates_List; + + // Method and message shape + [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 + var GoldenCase := TGoldenCase.Create(TGoldenFiles.CaseFile(TGoldenFiles.LEGACY_SUITE, CaseName)); + try + var Response: string; + var SavedDirectory := GetCurrentDir; + if GoldenCase.WorkingDirectory <> '' then + SetCurrentDir(GoldenCase.WorkingDirectory); + try + Response := FHarness.Process(GoldenCase.RequestBody); + finally + SetCurrentDir(SavedDirectory); + end; + + if TGoldenFiles.RecordMode then + begin + GoldenCase.RecordExpected(Response); + Exit; + end; + + Assert.AreEqual(GoldenCase.ExpectedText, GoldenCase.NormalizeResponse(Response), + 'Golden mismatch for ' + CaseName); + finally + GoldenCase.Free; + 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_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; + +initialization + TDUnitX.RegisterTestFixture(TLegacyGoldenTests); + +end. diff --git a/tests/MCPServer.Tests.Golden.pas b/tests/MCPServer.Tests.Golden.pas new file mode 100644 index 0000000..6785178 --- /dev/null +++ b/tests/MCPServer.Tests.Golden.pas @@ -0,0 +1,406 @@ +unit MCPServer.Tests.Golden; + +interface + +uses + System.SysUtils, + System.Classes, + System.Generics.Collections, + System.JSON; + +type + EGoldenError = class(Exception); + + /// Locates the golden directory and exposes the record switch. + /// + /// The golden root is the "golden" folder under "tests". It is found by + /// walking up from the test executable, or taken from the environment + /// variable MCP_GOLDEN_DIR. Setting MCP_GOLDEN_RECORD=1 makes the golden + /// tests overwrite the expected sections instead of comparing. + 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'; + + class function GoldenRoot: string; + class function TestsRoot: string; + class function CaseFile(const Suite, CaseName: string): string; + class function RecordMode: Boolean; + end; + + /// Replaces known-volatile values in a parsed JSON response so that two + /// runs can be compared byte for byte. + /// + /// A path is a dotted member path with array indexes, for example + /// "result.content[0].text". A pattern may use [*] to match any index. + /// Mask paths are replaced by the placeholder string; shape paths are + /// replaced by their shape (every leaf becomes its JSON type name, and a + /// string that itself contains a JSON document is parsed first). Paths must + /// end at an object member. + 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; + + /// One golden case file. Fields: + /// request JSON value sent as the request body, or + /// requestText raw request body for non-JSON input + /// mask optional list of paths replaced by "" + /// shape optional list of paths replaced by their shape + /// workingDirectory optional directory (relative to "tests") made + /// current while the request runs + /// expected normalised JSON response, or + /// expectedText raw response when it is empty or not JSON + 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; + + /// Applies mask and shape rules to an actual response and returns the + /// formatted text used for comparison. Empty or non-JSON responses are + /// returned unchanged. + function NormalizeResponse(const ResponseBody: string): string; + /// The recorded expectation in the same formatted form. + function ExpectedText: string; + /// Stores the normalised response as the new expectation and saves the file. + 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; + +implementation + +uses + System.IOUtils; + +const + MAX_PARENT_LEVELS = 6; + +{ TGoldenFiles } + +class function TGoldenFiles.GoldenRoot: string; +begin + Result := GetEnvironmentVariable(GOLDEN_DIR_ENVIRONMENT_VARIABLE); + if Result <> '' then + Exit(TPath.GetFullPath(Result)); + + var Dir := ExtractFilePath(ParamStr(0)); + for var Level := 0 to MAX_PARENT_LEVELS do + begin + var Candidate := TPath.Combine(Dir, GOLDEN_DIRECTORY_NAME); + if TDirectory.Exists(TPath.Combine(Candidate, LEGACY_SUITE)) then + Exit(Candidate); + Dir := TPath.GetFullPath(TPath.Combine(Dir, '..')); + end; + + raise EGoldenError.CreateFmt('Golden directory not found above %s (set %s)', + [ExtractFilePath(ParamStr(0)), GOLDEN_DIR_ENVIRONMENT_VARIABLE]); +end; + +class function TGoldenFiles.TestsRoot: string; +begin + Result := TPath.GetFullPath(TPath.Combine(GoldenRoot, '..')); +end; + +class function TGoldenFiles.CaseFile(const Suite, CaseName: string): string; +begin + Result := TPath.Combine(TPath.Combine(GoldenRoot, Suite), CaseName + '.json'); +end; + +class function TGoldenFiles.RecordMode: Boolean; +begin + Result := GetEnvironmentVariable(RECORD_ENVIRONMENT_VARIABLE) = '1'; +end; + +{ TGoldenNormalizer } + +class function TGoldenNormalizer.ReplaceIndexes(const Segment: string): string; +begin + Result := ''; + var I := 1; + while I <= Length(Segment) do + begin + if Segment[I] = '[' then + begin + Result := Result + '[*'; + Inc(I); + while (I <= Length(Segment)) and CharInSet(Segment[I], ['0'..'9']) do + Inc(I); + end + else + begin + Result := Result + Segment[I]; + Inc(I); + end; + end; +end; + +class function TGoldenNormalizer.SegmentMatches(const Segment, Pattern: string): Boolean; +begin + Result := Segment = Pattern; + if (not Result) and Pattern.Contains('[*]') then + Result := ReplaceIndexes(Segment) = Pattern; +end; + +class function TGoldenNormalizer.PathMatches(const Path, Pattern: string): Boolean; +begin + var PathParts := Path.Split(['.']); + var PatternParts := Pattern.Split(['.']); + if Length(PathParts) <> Length(PatternParts) then + Exit(False); + + for var I := 0 to High(PathParts) do + if not SegmentMatches(PathParts[I], PatternParts[I]) then + Exit(False); + + Result := True; +end; + +class function TGoldenNormalizer.MatchesAny(const Path: string; const Patterns: TArray): Boolean; +begin + for var Pattern in Patterns do + if PathMatches(Path, Pattern) then + Exit(True); + Result := False; +end; + +class function TGoldenNormalizer.ShapeOfString(const Value: string): TJSONValue; +begin + var Parsed := TJSONObject.ParseJSONValue(Value); + try + if (Parsed is TJSONObject) or (Parsed is TJSONArray) then + Result := Shape(Parsed) + else + Result := TJSONString.Create('string'); + finally + Parsed.Free; + end; +end; + +class function TGoldenNormalizer.Shape(const Value: TJSONValue): TJSONValue; +begin + if Value is TJSONObject then + begin + var Obj := TJSONObject.Create; + for var Pair in TJSONObject(Value) do + Obj.AddPair(Pair.JsonString.Value, Shape(Pair.JsonValue)); + Result := Obj; + end + else if Value is TJSONArray then + begin + var Arr := TJSONArray.Create; + for var Item in TJSONArray(Value) do + Arr.AddElement(Shape(Item)); + Result := Arr; + end + else if Value is TJSONNull then + Result := TJSONString.Create('null') + else if Value is TJSONBool then + Result := TJSONString.Create('boolean') + else if Value is TJSONNumber then + Result := TJSONString.Create('number') + else if Value is TJSONString then + Result := ShapeOfString(TJSONString(Value).Value) + else + Result := TJSONString.Create(Value.ClassName); +end; + +class procedure TGoldenNormalizer.NormalizeObject(const Obj: TJSONObject; const Path: string; + const MaskPaths, ShapePaths: TArray); +begin + for var Pair in Obj do + begin + var ChildPath := Pair.JsonString.Value; + if Path <> '' then + ChildPath := Path + '.' + ChildPath; + + if MatchesAny(ChildPath, MaskPaths) then + Pair.JsonValue := TJSONString.Create(MASK_PLACEHOLDER) + else if MatchesAny(ChildPath, ShapePaths) then + Pair.JsonValue := Shape(Pair.JsonValue) + else if Pair.JsonValue is TJSONObject then + NormalizeObject(TJSONObject(Pair.JsonValue), ChildPath, MaskPaths, ShapePaths) + else if Pair.JsonValue is TJSONArray then + NormalizeArray(TJSONArray(Pair.JsonValue), ChildPath, MaskPaths, ShapePaths); + end; +end; + +class procedure TGoldenNormalizer.NormalizeArray(const Arr: TJSONArray; const Path: string; + const MaskPaths, ShapePaths: TArray); +begin + for var I := 0 to Arr.Count - 1 do + begin + var ChildPath := Path + '[' + I.ToString + ']'; + var Item := Arr.Items[I]; + if Item is TJSONObject then + NormalizeObject(TJSONObject(Item), ChildPath, MaskPaths, ShapePaths) + else if Item is TJSONArray then + NormalizeArray(TJSONArray(Item), ChildPath, MaskPaths, ShapePaths); + end; +end; + +class procedure TGoldenNormalizer.Normalize(const Root: TJSONValue; const MaskPaths, ShapePaths: TArray); +begin + if Root is TJSONObject then + NormalizeObject(TJSONObject(Root), '', MaskPaths, ShapePaths) + else if Root is TJSONArray then + NormalizeArray(TJSONArray(Root), '', MaskPaths, ShapePaths); +end; + +{ TGoldenCase } + +constructor TGoldenCase.Create(const AFileName: string); +begin + inherited Create; + FFileName := AFileName; + + if not TFile.Exists(FFileName) then + raise EGoldenError.CreateFmt('Golden file not found: %s', [FFileName]); + + var Parsed := TJSONObject.ParseJSONValue(TFile.ReadAllText(FFileName, TEncoding.UTF8)); + if not (Parsed is TJSONObject) then + begin + Parsed.Free; + raise EGoldenError.CreateFmt('Golden file is not a JSON object: %s', [FFileName]); + end; + FDocument := TJSONObject(Parsed); +end; + +destructor TGoldenCase.Destroy; +begin + FDocument.Free; + inherited; +end; + +function TGoldenCase.ReadStringArray(const Name: string): TArray; +begin + Result := nil; + var Value := FDocument.GetValue(Name); + if not (Value is TJSONArray) then + Exit; + + var Arr := TJSONArray(Value); + SetLength(Result, Arr.Count); + for var I := 0 to Arr.Count - 1 do + Result[I] := Arr.Items[I].Value; +end; + +function TGoldenCase.GetRequestBody: string; +begin + var Request := FDocument.GetValue('request'); + if Assigned(Request) then + Exit(Request.ToJSON); + + var RequestText := FDocument.GetValue('requestText'); + if Assigned(RequestText) then + Exit(RequestText.Value); + + raise EGoldenError.CreateFmt('Golden file has neither "request" nor "requestText": %s', [FFileName]); +end; + +function TGoldenCase.GetWorkingDirectory: string; +begin + var Value := FDocument.GetValue('workingDirectory'); + if Assigned(Value) and (Value.Value <> '') then + Result := TPath.GetFullPath(TPath.Combine(TGoldenFiles.TestsRoot, Value.Value)) + else + Result := ''; +end; + +function TGoldenCase.GetHasExpected: Boolean; +begin + Result := Assigned(FDocument.GetValue('expected')) or Assigned(FDocument.GetValue('expectedText')); +end; + +function TGoldenCase.NormalizeResponse(const ResponseBody: string): string; +begin + if ResponseBody.Trim = '' then + Exit(ResponseBody); + + var Parsed := TJSONObject.ParseJSONValue(ResponseBody); + if not Assigned(Parsed) then + Exit(ResponseBody); + + try + TGoldenNormalizer.Normalize(Parsed, ReadStringArray('mask'), ReadStringArray('shape')); + Result := Parsed.Format(INDENTATION); + finally + Parsed.Free; + end; +end; + +function TGoldenCase.ExpectedText: string; +begin + var Expected := FDocument.GetValue('expected'); + if Assigned(Expected) then + Exit(Expected.Format(INDENTATION)); + + var ExpectedText := FDocument.GetValue('expectedText'); + if Assigned(ExpectedText) then + Exit(ExpectedText.Value); + + raise EGoldenError.CreateFmt('No expectation recorded in %s (run once with %s=1)', + [FFileName, TGoldenFiles.RECORD_ENVIRONMENT_VARIABLE]); +end; + +procedure TGoldenCase.RemoveExpected; +begin + FDocument.RemovePair('expected').Free; + FDocument.RemovePair('expectedText').Free; +end; + +procedure TGoldenCase.RecordExpected(const ResponseBody: string); +begin + RemoveExpected; + + var Parsed: TJSONValue := nil; + if ResponseBody.Trim <> '' then + Parsed := TJSONObject.ParseJSONValue(ResponseBody); + + if Assigned(Parsed) then + begin + TGoldenNormalizer.Normalize(Parsed, ReadStringArray('mask'), ReadStringArray('shape')); + FDocument.AddPair('expected', Parsed); + end + else + FDocument.AddPair('expectedText', ResponseBody); + + Save; +end; + +procedure TGoldenCase.Save; +begin + var Text := FDocument.Format(INDENTATION) + sLineBreak; + TFile.WriteAllBytes(FFileName, TEncoding.UTF8.GetBytes(Text)); +end; + +end. diff --git a/tests/MCPServer.Tests.Harness.pas b/tests/MCPServer.Tests.Harness.pas new file mode 100644 index 0000000..37de683 --- /dev/null +++ b/tests/MCPServer.Tests.Harness.pas @@ -0,0 +1,76 @@ +unit MCPServer.Tests.Harness; + +interface + +uses + System.SysUtils, + MCPServer.Types, + MCPServer.Settings, + MCPServer.JsonRpcProcessor; + +type + /// Builds the same manager registry as MCPServer.dpr (core, tools and + /// resources managers on top of the built-in registrations) and drives the + /// transport-independent JSON-RPC processor directly. + TMCPTestHarness = class + private + FSettings: TMCPSettings; + FManagerRegistry: IMCPManagerRegistry; + FCoreManager: IMCPCapabilityManager; + FProcessor: TMCPJsonRpcProcessor; + public + constructor Create; + destructor Destroy; override; + + /// Sends one JSON-RPC message through the processor and returns the raw + /// response body; an empty string means "no response" (notification). + function Process(const RequestBody: string): string; + + property Settings: TMCPSettings read FSettings; + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; + property CoreManager: IMCPCapabilityManager read FCoreManager; + end; + +implementation + +uses + MCPServer.ManagerRegistry, + MCPServer.CoreManager, + MCPServer.ToolsManager, + MCPServer.ResourcesManager; + +{ TMCPTestHarness } + +constructor TMCPTestHarness.Create; +begin + inherited Create; + + // Never create a settings.ini next to the test executable; the defaults are + // the same values the server writes into a fresh settings.ini. + FSettings := TMCPSettings.Create('', False); + + FManagerRegistry := TMCPManagerRegistry.Create; + FCoreManager := TMCPCoreManager.Create(FSettings); + + FManagerRegistry.RegisterManager(FCoreManager); + FManagerRegistry.RegisterManager(TMCPToolsManager.Create); + FManagerRegistry.RegisterManager(TMCPResourcesManager.Create); + + 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.dpr b/tests/MCPServer.Tests.dpr new file mode 100644 index 0000000..7540889 --- /dev/null +++ b/tests/MCPServer.Tests.dpr @@ -0,0 +1,72 @@ +program MCPServer.Tests; + +{$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.Serializer in '..\src\Protocol\MCPServer.Serializer.pas', + MCPServer.Schema.Generator in '..\src\Protocol\MCPServer.Schema.Generator.pas', + MCPServer.Logger in '..\src\Core\MCPServer.Logger.pas', + MCPServer.Settings in '..\src\Core\MCPServer.Settings.pas', + MCPServer.Registration in '..\src\Core\MCPServer.Registration.pas', + MCPServer.ManagerRegistry in '..\src\Core\MCPServer.ManagerRegistry.pas', + MCPServer.Tool.Base in '..\src\Tools\MCPServer.Tool.Base.pas', + MCPServer.Resource.Base in '..\src\Resources\MCPServer.Resource.Base.pas', + MCPServer.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', + // 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.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'; + +procedure RunTests; +begin + TDUnitX.CheckCommandLine; + + var Runner := TDUnitX.CreateRunner; + Runner.UseRTTI := True; + Runner.FailsOnNoAsserts := False; + + if TDUnitX.Options.ConsoleMode <> TDunitXConsoleMode.Off then + Runner.AddLogger(TDUnitXConsoleLogger.Create(TDUnitX.Options.ConsoleMode = TDunitXConsoleMode.Quiet)); + + Runner.AddLogger(TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile)); + + var Results := Runner.Execute; + if not Results.AllPassed then + System.ExitCode := EXIT_ERRORS; + + if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then + begin + System.Write('Done. Press to quit.'); + System.Readln; + end; +end; + +begin + try + RunTests; + except + on E: Exception do + begin + System.Writeln(E.ClassName, ': ', E.Message); + System.ExitCode := EXIT_ERRORS; + end; + end; +end. diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServer.Tests.dproj new file mode 100644 index 0000000..19f8c81 --- /dev/null +++ b/tests/MCPServer.Tests.dproj @@ -0,0 +1,128 @@ + + + {5C1E6B2A-7D4F-4E8B-9A3C-2F1D0E9B8C7A} + MCPServer.Tests.dpr + True + Debug + 3 + Console + 20.3 + Win32 + MCPServer.Tests + 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 + MCPServer_Tests + true + ..\src;..\src\Managers;..\src\Server;..\src\Tools;..\src\Core;..\src\Protocol;..\src\Libraries;..\src\Resources;$(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 + + + + MCPServer.Tests.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..4826b19 --- /dev/null +++ b/tests/golden/README.md @@ -0,0 +1,79 @@ +# Golden files + +The golden files pin the wire behaviour of the server so that every later change +can prove "no regression for existing clients". They were recorded from the +unchanged 2025-06-18 code before the MCP 2026-07-28 work started. After that +recording the only differences allowed on the legacy wire are the items in the +allow-list of `docs/mcp-2026-07-28-implementation-plan.md`, section 4.3. Anything +else that changes a golden file is a bug. + +## Layout + +| Directory | Layer | Recorded by | Verified by | +|---|---|---|---| +| `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr` | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TLegacyGoldenTests`) | +| `http/` | Streamable HTTP transport (`TMCPIdHTTPServer`) of the built executable, captured with curl | `scripts\capture-http-goldens.ps1 -Record` | `scripts\capture-http-goldens.ps1` | + +Later phases add `modern/` for 2026-07-28 requests. + +## 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, exception text with addresses). +- `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` 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. Check out the commit whose behaviour must be pinned. +2. `build.bat Debug Win64` and `build-tests.bat Debug Win64`. +3. `.\scripts\run-tests.ps1 -Record -NoBuild` rewrites the `expected` sections + in `legacy/`. +4. `.\scripts\capture-http-goldens.ps1 -Record` starts `Win64\Debug\MCPServer.exe` + on port 3939 and writes `http/*.txt`. +5. Review the diff. Only the intended cases may change, and only within the + allow-list. +6. `.\scripts\run-tests.ps1` and `.\scripts\capture-http-goldens.ps1` must be + green before committing. + +## Notes on the recorded behaviour + +- `server://status` is declared in `MCPServer.Resource.Server.pas` but the + executable never registers it (`SetNamePrefix` is the only caller of + `RegisterServerStatusResource`), so `resources/list` returns three resources. +- `resources/read` without `params` dereferences nil and answers `-32603` with + an access-violation message; the message is masked. `tools/call` without + `arguments` fails the same way inside the tool and comes back as an `isError` + text result; that text is masked too. +- `logs://recent` answers "Error reading resource: Invalid pointer operation": + `TLogsRecentResource.GetResourceData` puts the copied entries into a second + owning list, so they are freed twice. The golden pins this current behaviour + until the resource is fixed in a later phase. +- `tools/call` with `id: null` is treated as a notification and gets no + response. +- HTTP responses are normalised: `Date` and `Server` headers are dropped, GUIDs + become ``, SSE `id:` lines become `id: `, line endings are LF. diff --git a/tests/golden/http/delete-endpoint.txt b/tests/golden/http/delete-endpoint.txt new file mode 100644 index 0000000..5b1f9c2 --- /dev/null +++ b/tests/golden/http/delete-endpoint.txt @@ -0,0 +1,11 @@ +HTTP/1.1 405 Method Not Allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 55 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +405 Method Not Allowed diff --git a/tests/golden/http/get-endpoint-info.txt b/tests/golden/http/get-endpoint-info.txt new file mode 100644 index 0000000..0f69064 --- /dev/null +++ b/tests/golden/http/get-endpoint-info.txt @@ -0,0 +1,13 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 57 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +Connection: keep-alive + +{"url": "http://localhost:3939/mcp", "transport": "http"} diff --git a/tests/golden/http/get-sse-stream.txt b/tests/golden/http/get-sse-stream.txt new file mode 100644 index 0000000..10d7054 --- /dev/null +++ b/tests/golden/http/get-sse-stream.txt @@ -0,0 +1,14 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 39 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +Connection: keep-alive +X-Accel-Buffering: no + +200 OK diff --git a/tests/golden/http/options-preflight.txt b/tests/golden/http/options-preflight.txt new file mode 100644 index 0000000..ec8d22c --- /dev/null +++ b/tests/golden/http/options-preflight.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 39 +Access-Control-Allow-Origin: http://localhost +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +200 OK diff --git a/tests/golden/http/post-batch-notifications.txt b/tests/golden/http/post-batch-notifications.txt new file mode 100644 index 0000000..cc7546b --- /dev/null +++ b/tests/golden/http/post-batch-notifications.txt @@ -0,0 +1,11 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 45 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +202 Accepted diff --git a/tests/golden/http/post-batch-requests.txt b/tests/golden/http/post-batch-requests.txt new file mode 100644 index 0000000..1562083 --- /dev/null +++ b/tests/golden/http/post-batch-requests.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 98 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"JSON-RPC request must be an object"}} diff --git a/tests/golden/http/post-client-response.txt b/tests/golden/http/post-client-response.txt new file mode 100644 index 0000000..cc7546b --- /dev/null +++ b/tests/golden/http/post-client-response.txt @@ -0,0 +1,11 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 45 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +202 Accepted diff --git a/tests/golden/http/post-empty-body.txt b/tests/golden/http/post-empty-body.txt new file mode 100644 index 0000000..22f9e0f --- /dev/null +++ b/tests/golden/http/post-empty-body.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 76 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt new file mode 100644 index 0000000..39074a8 --- /dev/null +++ b/tests/golden/http/post-initialize-sse.txt @@ -0,0 +1,18 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/event-stream; charset=utf-8 +Content-Length: 341 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +Connection: keep-alive +X-Accel-Buffering: no + +id: +event: message +data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"supportsProgress":false,"supportsCancellation":false},"resources":{"subscribe":false,"listChanged":false}},"sessionId":"","serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} + + diff --git a/tests/golden/http/post-initialize.txt b/tests/golden/http/post-initialize.txt new file mode 100644 index 0000000..999bab2 --- /dev/null +++ b/tests/golden/http/post-initialize.txt @@ -0,0 +1,13 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 312 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive +Mcp-Session-Id: + +{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"supportsProgress":false,"supportsCancellation":false},"resources":{"subscribe":false,"listChanged":false}},"sessionId":"","serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-no-accept-header.txt b/tests/golden/http/post-no-accept-header.txt new file mode 100644 index 0000000..2ae6ded --- /dev/null +++ b/tests/golden/http/post-no-accept-header.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 36 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":9,"result":{}} diff --git a/tests/golden/http/post-notification-initialized.txt b/tests/golden/http/post-notification-initialized.txt new file mode 100644 index 0000000..cc7546b --- /dev/null +++ b/tests/golden/http/post-notification-initialized.txt @@ -0,0 +1,11 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 45 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +202 Accepted diff --git a/tests/golden/http/post-origin-allowed.txt b/tests/golden/http/post-origin-allowed.txt new file mode 100644 index 0000000..6a33cf7 --- /dev/null +++ b/tests/golden/http/post-origin-allowed.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: http://localhost +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":13,"result":{}} diff --git a/tests/golden/http/post-origin-forbidden.txt b/tests/golden/http/post-origin-forbidden.txt new file mode 100644 index 0000000..33a8934 --- /dev/null +++ b/tests/golden/http/post-origin-forbidden.txt @@ -0,0 +1,6 @@ +HTTP/1.1 403 Forbidden - Origin not allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 67 + +403 Forbidden - Origin not allowed diff --git a/tests/golden/http/post-parse-error.txt b/tests/golden/http/post-parse-error.txt new file mode 100644 index 0000000..22f9e0f --- /dev/null +++ b/tests/golden/http/post-parse-error.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 76 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-protocol-version-header.txt b/tests/golden/http/post-protocol-version-header.txt new file mode 100644 index 0000000..3887969 --- /dev/null +++ b/tests/golden/http/post-protocol-version-header.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":12,"result":{}} diff --git a/tests/golden/http/post-resources-list.txt b/tests/golden/http/post-resources-list.txt new file mode 100644 index 0000000..edde8b4 --- /dev/null +++ b/tests/golden/http/post-resources-list.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 451 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"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"}]}} diff --git a/tests/golden/http/post-resources-read-project-info.txt b/tests/golden/http/post-resources-read-project-info.txt new file mode 100644 index 0000000..7ab9ced --- /dev/null +++ b/tests/golden/http/post-resources-read-project-info.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 547 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":{\"capacity\":4,\"count\":4,\"isempty\":false}}"}]}} diff --git a/tests/golden/http/post-session-echo-lowercase.txt b/tests/golden/http/post-session-echo-lowercase.txt new file mode 100644 index 0000000..06753ef --- /dev/null +++ b/tests/golden/http/post-session-echo-lowercase.txt @@ -0,0 +1,13 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive +Mcp-Session-Id: golden-session-2 + +{"jsonrpc":"2.0","id":11,"result":{}} diff --git a/tests/golden/http/post-session-echo.txt b/tests/golden/http/post-session-echo.txt new file mode 100644 index 0000000..5c93ed2 --- /dev/null +++ b/tests/golden/http/post-session-echo.txt @@ -0,0 +1,13 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 37 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive +Mcp-Session-Id: golden-session-1 + +{"jsonrpc":"2.0","id":10,"result":{}} diff --git a/tests/golden/http/post-tools-call-echo.txt b/tests/golden/http/post-tools-call-echo.txt new file mode 100644 index 0000000..63a3da0 --- /dev/null +++ b/tests/golden/http/post-tools-call-echo.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 91 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":3,"result":{"content":[{"type":"text","text":"Echo: hello golden"}]}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt new file mode 100644 index 0000000..d158d81 --- /dev/null +++ b/tests/golden/http/post-tools-list-sse.txt @@ -0,0 +1,18 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: text/event-stream; charset=utf-8 +Content-Length: 1085 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Cache-Control: no-cache +Connection: keep-alive +X-Accel-Buffering: no + +id: +event: message +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} + + diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt new file mode 100644 index 0000000..9e42b4b --- /dev/null +++ b/tests/golden/http/post-tools-list.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 1056 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} diff --git a/tests/golden/http/post-unknown-method.txt b/tests/golden/http/post-unknown-method.txt new file mode 100644 index 0000000..7976d79 --- /dev/null +++ b/tests/golden/http/post-unknown-method.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 140 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":7,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/post-wrong-path.txt b/tests/golden/http/post-wrong-path.txt new file mode 100644 index 0000000..ac68fc0 --- /dev/null +++ b/tests/golden/http/post-wrong-path.txt @@ -0,0 +1,11 @@ +HTTP/1.1 404 Not Found +Connection: close +Content-Type: text/html; charset=utf-8 +Content-Length: 46 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +404 Not Found diff --git a/tests/golden/http/put-endpoint.txt b/tests/golden/http/put-endpoint.txt new file mode 100644 index 0000000..5b1f9c2 --- /dev/null +++ b/tests/golden/http/put-endpoint.txt @@ -0,0 +1,11 @@ +HTTP/1.1 405 Method Not Allowed +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 55 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 + +405 Method Not Allowed 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..2ee796b --- /dev/null +++ b/tests/golden/legacy/id-null.json @@ -0,0 +1,8 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": null, + "method": "ping" + }, + "expectedText": "" +} 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..dbeb4af --- /dev/null +++ b/tests/golden/legacy/initialize-2025-03-26.json @@ -0,0 +1,41 @@ +{ + "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-06-18", + "capabilities": { + "tools": { + "supportsProgress": false, + "supportsCancellation": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "sessionId": "", + "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..02d1a61 --- /dev/null +++ b/tests/golden/legacy/initialize-2025-06-18.json @@ -0,0 +1,41 @@ +{ + "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": { + "supportsProgress": false, + "supportsCancellation": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "sessionId": "", + "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..8b71a55 --- /dev/null +++ b/tests/golden/legacy/initialize-2025-11-25.json @@ -0,0 +1,41 @@ +{ + "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-06-18", + "capabilities": { + "tools": { + "supportsProgress": false, + "supportsCancellation": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "sessionId": "", + "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..6459de9 --- /dev/null +++ b/tests/golden/legacy/initialize-unknown-version.json @@ -0,0 +1,41 @@ +{ + "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-06-18", + "capabilities": { + "tools": { + "supportsProgress": false, + "supportsCancellation": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "sessionId": "", + "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..4262720 --- /dev/null +++ b/tests/golden/legacy/initialize-without-params.json @@ -0,0 +1,32 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 1, + "method": "initialize" + }, + "mask": [ + "result.sessionId" + ], + "expected": { + "jsonrpc": "2.0", + "id": 1, + "result": { + "protocolVersion": "2025-06-18", + "capabilities": { + "tools": { + "supportsProgress": false, + "supportsCancellation": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "sessionId": "", + "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..5f8921e --- /dev/null +++ b/tests/golden/legacy/missing-jsonrpc-field.json @@ -0,0 +1,12 @@ +{ + "request": { + "id": 25, + "method": "ping" + }, + "expected": { + "jsonrpc": "2.0", + "id": 25, + "result": { + } + } +} diff --git a/tests/golden/legacy/missing-method.json b/tests/golden/legacy/missing-method.json new file mode 100644 index 0000000..9afc9c8 --- /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": -32601, + "message": "Method [] not found. The method does not exist or is not available." + } + } +} 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..6f00ce1 --- /dev/null +++ b/tests/golden/legacy/params-not-an-object.json @@ -0,0 +1,24 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 27, + "method": "tools/call", + "params": [ + 1, + 2 + ] + }, + "expected": { + "jsonrpc": "2.0", + "id": 27, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Invalid tool parameters" + } + ], + "isError": true + } + } +} 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..3d94870 --- /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": -32700, + "message": "JSON-RPC request must be an object" + } + } +} diff --git a/tests/golden/legacy/resources-list.json b/tests/golden/legacy/resources-list.json new file mode 100644 index 0000000..4d5c546 --- /dev/null +++ b/tests/golden/legacy/resources-list.json @@ -0,0 +1,33 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 13, + "method": "resources/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 13, + "result": { + "resources": [ + { + "uri": "project://readme", + "name": "Project README", + "description": "README.md file contents", + "mimeType": "text/markdown" + }, + { + "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" + } + ] + } + } +} 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..973dd4d --- /dev/null +++ b/tests/golden/legacy/resources-read-logs-recent.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 16, + "method": "resources/read", + "params": { + "uri": "logs://recent" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 16, + "result": { + "contents": [ + { + "uri": "logs://recent", + "mimeType": "application/json", + "text": "Error reading resource: Invalid pointer operation" + } + ] + } + } +} 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..4bfcdb5 --- /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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":{\"capacity\":4,\"count\":4,\"isempty\":false}}" + } + ] + } + } +} 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-unknown-uri.json b/tests/golden/legacy/resources-read-unknown-uri.json new file mode 100644 index 0000000..df41980 --- /dev/null +++ b/tests/golden/legacy/resources-read-unknown-uri.json @@ -0,0 +1,23 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 17, + "method": "resources/read", + "params": { + "uri": "nope://missing" + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 17, + "result": { + "contents": [ + { + "uri": "nope://missing", + "mimeType": "text/plain", + "text": "Error: Resource not found: 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..9139997 --- /dev/null +++ b/tests/golden/legacy/resources-read-without-params.json @@ -0,0 +1,18 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 18, + "method": "resources/read" + }, + "mask": [ + "error.message" + ], + "expected": { + "jsonrpc": "2.0", + "id": 18, + "error": { + "code": -32603, + "message": "" + } + } +} diff --git a/tests/golden/legacy/resources-templates-list.json b/tests/golden/legacy/resources-templates-list.json new file mode 100644 index 0000000..c933ac2 --- /dev/null +++ b/tests/golden/legacy/resources-templates-list.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 19, + "method": "resources/templates/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 19, + "result": { + "resourceTemplates": [ + ] + } + } +} 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..fc72266 --- /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": -32601, + "message": "Method [server/discover] not found. The method does not exist or is not available." + } + } +} 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..eb64a21 --- /dev/null +++ b/tests/golden/legacy/tools-call-empty-name.json @@ -0,0 +1,25 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 12, + "method": "tools/call", + "params": { + "name": "", + "arguments": { + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 12, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Invalid tool parameters" + } + ], + "isError": true + } + } +} 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..391f563 --- /dev/null +++ b/tests/golden/legacy/tools-call-invalid-argument-type.json @@ -0,0 +1,27 @@ +{ + "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": "0 add 3 = 3" + } + ] + } + } +} 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..7794573 --- /dev/null +++ b/tests/golden/legacy/tools-call-missing-arguments.json @@ -0,0 +1,26 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 8, + "method": "tools/call", + "params": { + "name": "echo" + } + }, + "mask": [ + "result.content[0].text" + ], + "expected": { + "jsonrpc": "2.0", + "id": 8, + "result": { + "content": [ + { + "type": "text", + "text": "" + } + ], + "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..c5fb316 --- /dev/null +++ b/tests/golden/legacy/tools-call-unknown-tool.json @@ -0,0 +1,25 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 9, + "method": "tools/call", + "params": { + "name": "no_such_tool", + "arguments": { + } + } + }, + "expected": { + "jsonrpc": "2.0", + "id": 9, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Tool not found: no_such_tool" + } + ], + "isError": true + } + } +} 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..fbc7ceb --- /dev/null +++ b/tests/golden/legacy/tools-call-without-params.json @@ -0,0 +1,20 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 11, + "method": "tools/call" + }, + "expected": { + "jsonrpc": "2.0", + "id": 11, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Invalid tool parameters" + } + ], + "isError": true + } + } +} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json new file mode 100644 index 0000000..b3678c0 --- /dev/null +++ b/tests/golden/legacy/tools-list.json @@ -0,0 +1,92 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 3, + "method": "tools/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 3, + "result": { + "tools": [ + { + "name": "get_time", + "description": "Get the current server time in ISO format", + "inputSchema": { + "type": "object", + "properties": { + } + } + }, + { + "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": "echo", + "description": "Echo a message back to the user", + "inputSchema": { + "type": "object", + "properties": { + "message": { + "type": "string", + "description": "Message to echo back" + } + }, + "required": [ + "message" + ] + } + }, + { + "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" + ] + } + } + ] + } + } +} diff --git a/tests/golden/legacy/unknown-method.json b/tests/golden/legacy/unknown-method.json new file mode 100644 index 0000000..5f0db5c --- /dev/null +++ b/tests/golden/legacy/unknown-method.json @@ -0,0 +1,15 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 20, + "method": "prompts/list" + }, + "expected": { + "jsonrpc": "2.0", + "id": 20, + "error": { + "code": -32601, + "message": "Method [prompts/list] not found. The method does not exist or is not available." + } + } +} From ce9a9b1a26a42f6299407fc82a07538d8ab69582 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:05:29 +0200 Subject: [PATCH 02/56] refactor: define protocol constants once in MCPServer.Types Moves the JSON-RPC error codes to MCPServer.Types and adds the constants the 2026-07-28 work needs: protocol revisions and version sets, the MCP error codes -32020/-32021/-32022 (and the legacy -32002), the reserved _meta keys and the list of cacheable methods. MCPServer.JsonRpcProcessor keeps JSONRPC_* as aliases so consumer code compiles unchanged; the unused duplicate block in MCPServer.IdHTTPServer is removed. MCP_PROTOCOL_VERSION stays '2025-06-18'. Also makes the HTTP golden comparison trim trailing newlines on both sides (SSE bodies end with a blank line). --- scripts/capture-http-goldens.ps1 | 2 +- src/Protocol/MCPServer.JsonRpcProcessor.pas | 13 +-- src/Protocol/MCPServer.Types.pas | 55 ++++++++++++ src/Server/MCPServer.IdHTTPServer.pas | 7 -- tests/MCPServer.Tests.Constants.pas | 98 +++++++++++++++++++++ tests/MCPServer.Tests.dpr | 3 +- tests/MCPServer.Tests.dproj | 1 + 7 files changed, 165 insertions(+), 14 deletions(-) create mode 100644 tests/MCPServer.Tests.Constants.pas diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 index da80a84..89ca750 100644 --- a/scripts/capture-http-goldens.ps1 +++ b/scripts/capture-http-goldens.ps1 @@ -181,7 +181,7 @@ try { } $raw = [System.Text.Encoding]::UTF8.GetString([System.IO.File]::ReadAllBytes($responseFile)) - $actual = Normalize-Response $raw + $actual = (Normalize-Response $raw).TrimEnd("`n") $goldenFile = Join-Path $goldenDir "$($case.Name).txt" if ($Record) { diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 8e9b4e6..46bd86a 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -25,11 +25,14 @@ TMCPJsonRpcProcessor = class end; const - JSONRPC_PARSE_ERROR = -32700; - JSONRPC_INVALID_REQUEST = -32600; - JSONRPC_METHOD_NOT_FOUND = -32601; - JSONRPC_INVALID_PARAMS = -32602; - JSONRPC_INTERNAL_ERROR = -32603; + // The JSON-RPC error codes are defined in MCPServer.Types. These aliases + // keep consumer code that references MCPServer.JsonRpcProcessor.JSONRPC_* + // compiling for one release. + 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 diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index df0641f..e78dccb 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -8,8 +8,63 @@ interface System.Rtti; const + /// Protocol version answered by the legacy initialize handshake today. + /// Kept under its historic name for library consumers. MCP_PROTOCOL_VERSION = '2025-06-18'; + // Protocol revisions + 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'; + + /// Newest revision this server targets (stateless, per-request _meta). + MCP_LATEST_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2026_07_28; + /// Newest revision served through the initialize handshake. + MCP_LATEST_LEGACY_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2025_11_25; + + MCP_LEGACY_PROTOCOL_VERSIONS: array[0..1] of string = ( + MCP_PROTOCOL_VERSION_2025_06_18, + MCP_PROTOCOL_VERSION_2025_11_25 + ); + MCP_MODERN_PROTOCOL_VERSIONS: array[0..0] of string = ( + MCP_PROTOCOL_VERSION_2026_07_28 + ); + + // 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; + + // MCP error codes reserved by the specification (basic/index.mdx, "Error Codes") + MCP_ERROR_HEADER_MISMATCH = -32020; + MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY = -32021; + MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION = -32022; + /// Resource not found in 2025-11-25 and earlier; 2026-07-28 uses JSONRPC_INVALID_PARAMS. + MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY = -32002; + + // Reserved _meta keys (2026-07-28) + 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'; + + /// Methods whose complete results must carry ttlMs and cacheScope + /// (server/utilities/caching.mdx, "Cacheable Results"). + MCP_CACHEABLE_METHODS: array[0..5] of string = ( + 'server/discover', + 'tools/list', + 'prompts/list', + 'resources/list', + 'resources/templates/list', + 'resources/read' + ); + type OptionalAttribute = class(TCustomAttribute) end; diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 6516352..c2c5c4e 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -91,13 +91,6 @@ implementation // CORS Max Age (24 hours in seconds) CORS_MAX_AGE = 86400; - // JSON-RPC 2.0 Error Codes - JSONRPC_PARSE_ERROR = -32700; - JSONRPC_INVALID_REQUEST = -32600; - JSONRPC_METHOD_NOT_FOUND = -32601; - JSONRPC_INVALID_PARAMS = -32602; - JSONRPC_INTERNAL_ERROR = -32603; - // SSE Message Format SSE_EVENT_PREFIX = 'event: '; SSE_DATA_PREFIX = 'data: '; diff --git a/tests/MCPServer.Tests.Constants.pas b/tests/MCPServer.Tests.Constants.pas new file mode 100644 index 0000000..da773a9 --- /dev/null +++ b/tests/MCPServer.Tests.Constants.pas @@ -0,0 +1,98 @@ +unit MCPServer.Tests.Constants; + +interface + +uses + DUnitX.TestFramework; + +type + /// Guards the protocol constants in MCPServer.Types and the aliases that + /// keep MCPServer.JsonRpcProcessor.JSONRPC_* compiling for consumers. + [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; + end; + +implementation + +uses + System.SysUtils, + 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, 'legacy default must not change without the allow-list'); + 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_06_18, MCP_LEGACY_PROTOCOL_VERSIONS[0]); + Assert.AreEqual(MCP_PROTOCOL_VERSION_2025_11_25, 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; + +initialization + TDUnitX.RegisterTestFixture(TProtocolConstantsTests); + +end. diff --git a/tests/MCPServer.Tests.dpr b/tests/MCPServer.Tests.dpr index 7540889..0f82b5a 100644 --- a/tests/MCPServer.Tests.dpr +++ b/tests/MCPServer.Tests.dpr @@ -33,7 +33,8 @@ uses MCPServer.Resource.Project in '..\src\Resources\MCPServer.Resource.Project.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.Golden.Legacy in 'MCPServer.Tests.Golden.Legacy.pas', + MCPServer.Tests.Constants in 'MCPServer.Tests.Constants.pas'; procedure RunTests; begin diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServer.Tests.dproj index 19f8c81..0236bb1 100644 --- a/tests/MCPServer.Tests.dproj +++ b/tests/MCPServer.Tests.dproj @@ -95,6 +95,7 @@ + Base From 0773b4b1ca48202406cce8029a6012991e4d1e27 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:08:48 +0200 Subject: [PATCH 03/56] fix: make shared counters atomic and create the registry eagerly TServerStatusResource.IncrementRequestCount, ConnectionOpened and ConnectionClosed run on every Indy connection thread; they now use AtomicIncrement and a compare-and-swap loop that never goes below zero, and GetResourceData reads the counters atomically. GetNextEventID uses AtomicIncrement as well. TMCPRegistry creates its dictionaries in a class constructor instead of lazily, and documents that registration must complete before the managers are created. SetNamePrefix documents the same constraint. Tests: concurrent counter updates, below-zero guard, registry contents. --- src/Core/MCPServer.Registration.pas | 60 ++++----- src/Resources/MCPServer.Resource.Server.pas | 29 ++++- src/Server/MCPServer.IdHTTPServer.pas | 4 +- tests/MCPServer.Tests.Registration.pas | 86 +++++++++++++ tests/MCPServer.Tests.ServerStatus.pas | 129 ++++++++++++++++++++ tests/MCPServer.Tests.dpr | 4 +- tests/MCPServer.Tests.dproj | 2 + 7 files changed, 269 insertions(+), 45 deletions(-) create mode 100644 tests/MCPServer.Tests.Registration.pas create mode 100644 tests/MCPServer.Tests.ServerStatus.pas diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index 9551b88..7f8f029 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -11,26 +11,35 @@ interface type TMCPToolClass = class of TMCPToolBase; - + TMCPToolFactory = reference to function: IMCPTool; TMCPResourceFactory = reference to function: IMCPResource; + /// Process-wide registry of tool and resource factories. + /// + /// The dictionaries exist from the class constructor on, so registration + /// from unit initialization sections needs no lazy checks. Registration is + /// not synchronised: register everything before the managers are created. + /// TMCPToolsManager.Create and TMCPResourcesManager.Create read the + /// registry once, so in practice that means before TMCPIdHTTPServer.Start + /// or TMCPStdioTransport.Run. TMCPRegistry = class private class var FTools: TDictionary; class var FResources: TDictionary; - - class procedure EnsureInitialized; + + class constructor Create; + class destructor Destroy; public class procedure RegisterTool(const Name: string; Factory: TMCPToolFactory); class procedure RegisterResource(const URI: string; Factory: TMCPResourceFactory); - + class function CreateTool(const Name: string): IMCPTool; class function CreateResource(const URI: string): IMCPResource; - + class function GetToolNames: TArray; class function GetResourceURIs: TArray; - + class function HasTool(const Name: string): Boolean; class function HasResource(const URI: string): Boolean; end; @@ -39,27 +48,26 @@ implementation { TMCPRegistry } -class procedure TMCPRegistry.EnsureInitialized; +class constructor TMCPRegistry.Create; begin - if not Assigned(FTools) then - FTools := TDictionary.Create; + FTools := TDictionary.Create; + FResources := TDictionary.Create; +end; - if not Assigned(FResources) then - FResources := TDictionary.Create; +class destructor TMCPRegistry.Destroy; +begin + FreeAndNil(FTools); + FreeAndNil(FResources); end; class procedure TMCPRegistry.RegisterTool(const Name: string; Factory: TMCPToolFactory); begin - EnsureInitialized; - FTools.AddOrSetValue(Name, Factory); TLogger.Info('Registered tool: ' + Name); end; class procedure TMCPRegistry.RegisterResource(const URI: string; Factory: TMCPResourceFactory); begin - EnsureInitialized; - FResources.AddOrSetValue(URI, Factory); TLogger.Info('Registered resource: ' + URI); end; @@ -68,8 +76,6 @@ class function TMCPRegistry.CreateTool(const Name: string): IMCPTool; var Factory: TMCPToolFactory; begin - EnsureInitialized; - if FTools.TryGetValue(Name, Factory) then Result := Factory() else @@ -80,8 +86,6 @@ class function TMCPRegistry.CreateResource(const URI: string): IMCPResource; var Factory: TMCPResourceFactory; begin - EnsureInitialized; - if FResources.TryGetValue(URI, Factory) then Result := Factory() else @@ -90,38 +94,22 @@ class function TMCPRegistry.CreateResource(const URI: string): IMCPResource; class function TMCPRegistry.GetToolNames: TArray; begin - EnsureInitialized; - Result := FTools.Keys.ToArray; end; class function TMCPRegistry.GetResourceURIs: TArray; begin - EnsureInitialized; - Result := FResources.Keys.ToArray; end; class function TMCPRegistry.HasTool(const Name: string): Boolean; begin - EnsureInitialized; - 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; - -end. \ No newline at end of file +end. diff --git a/src/Resources/MCPServer.Resource.Server.pas b/src/Resources/MCPServer.Resource.Server.pas index f627f37..b35051f 100644 --- a/src/Resources/MCPServer.Resource.Server.pas +++ b/src/Resources/MCPServer.Resource.Server.pas @@ -39,9 +39,19 @@ TServerStatusResource = class(TMCPResourceBase) function GetResourceData: TServerStatus; override; public constructor Create; override; + /// Resets the start time and the counters. Runs from the unit + /// initialization and again from MCPServer.dpr before a transport starts. class procedure Initialize; + /// Registers the resource as server://status. The registry is read + /// once, when TMCPResourcesManager is created, so call this before the + /// managers are built (before TMCPIdHTTPServer.Start or + /// TMCPStdioTransport.Run); a later call registers a URI nobody serves. class procedure SetNamePrefix(const Prefix: string); + /// Registers server://status (or the prefixed URI). MCPServer.dpr does not + /// call this; the resource is opt-in for library consumers. class procedure RegisterServerStatusResource; + // The counters are updated from every Indy connection thread, so they + // use atomic operations. class procedure IncrementRequestCount; class procedure ConnectionOpened; class procedure ConnectionClosed; @@ -94,18 +104,25 @@ 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); + // Never below zero, and without a moment in which a reader can see -1. + var Current := AtomicCmpExchange(FActiveConnections, 0, 0); + while Current > 0 do + begin + var Previous := AtomicCmpExchange(FActiveConnections, Current - 1, Current); + if Previous = Current then + Exit; + Current := Previous; + end; end; constructor TServerStatusResource.Create; @@ -136,8 +153,8 @@ 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); diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index c2c5c4e..2b782c7 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -408,8 +408,8 @@ procedure TMCPIdHTTPServer.HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean) function TMCPIdHTTPServer.GetNextEventID: string; begin - Inc(FEventIDCounter); - Result := IntToStr(FEventIDCounter); + // Called from Indy connection threads. + Result := IntToStr(AtomicIncrement(FEventIDCounter)); end; function TMCPIdHTTPServer.AcceptsSSE(const AcceptHeader: string): Boolean; diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas new file mode 100644 index 0000000..743a38f --- /dev/null +++ b/tests/MCPServer.Tests.Registration.pas @@ -0,0 +1,86 @@ +unit MCPServer.Tests.Registration; + +interface + +uses + DUnitX.TestFramework; + +type + /// TMCPRegistry is filled from unit initialization sections; these tests + /// only read it so the golden tests keep seeing the shipped registry. + [TestFixture] + TRegistryTests = class + public + [Test] procedure BuiltInTools_AreRegisteredFromInitialization; + [Test] procedure BuiltInResources_AreRegisteredFromInitialization; + [Test] procedure ServerStatus_IsNotRegisteredByDefault; + [Test] procedure CreateTool_UnknownName_Raises; + [Test] procedure CreateResource_UnknownUri_Raises; + [Test] procedure CreateTool_ReturnsFreshInstances; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Registration, + MCPServer.Tool.Base; + +{ TRegistryTests } + +procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasTool('echo')); + Assert.IsTrue(TMCPRegistry.HasTool('get_time')); + Assert.IsTrue(TMCPRegistry.HasTool('list_files')); + Assert.IsTrue(TMCPRegistry.HasTool('calculate')); + Assert.AreEqual(4, Integer(Length(TMCPRegistry.GetToolNames))); +end; + +procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasResource('project://info')); + Assert.IsTrue(TMCPRegistry.HasResource('project://readme')); + Assert.IsTrue(TMCPRegistry.HasResource('logs://recent')); + Assert.AreEqual(3, Integer(Length(TMCPRegistry.GetResourceURIs))); +end; + +procedure TRegistryTests.ServerStatus_IsNotRegisteredByDefault; +begin + // Documented in tests\golden\README.md: only SetNamePrefix registers it. + Assert.IsFalse(TMCPRegistry.HasResource('server://status')); +end; + +procedure TRegistryTests.CreateTool_UnknownName_Raises; +begin + var Probe: TProc := + procedure + begin + TMCPRegistry.CreateTool('no_such_tool'); + end; + Assert.WillRaise(Probe, Exception); +end; + +procedure TRegistryTests.CreateResource_UnknownUri_Raises; +begin + var Probe: TProc := + procedure + begin + TMCPRegistry.CreateResource('nope://missing'); + end; + Assert.WillRaise(Probe, Exception); +end; + +procedure TRegistryTests.CreateTool_ReturnsFreshInstances; +begin + var First: IMCPTool := TMCPRegistry.CreateTool('echo'); + var Second: IMCPTool := TMCPRegistry.CreateTool('echo'); + + Assert.AreEqual('echo', First.Name); + Assert.AreNotSame(First, Second); +end; + +initialization + TDUnitX.RegisterTestFixture(TRegistryTests); + +end. diff --git a/tests/MCPServer.Tests.ServerStatus.pas b/tests/MCPServer.Tests.ServerStatus.pas new file mode 100644 index 0000000..b710c0a --- /dev/null +++ b/tests/MCPServer.Tests.ServerStatus.pas @@ -0,0 +1,129 @@ +unit MCPServer.Tests.ServerStatus; + +interface + +uses + DUnitX.TestFramework; + +type + /// The counters behind server://status are updated from every Indy + /// connection thread; these tests guard the atomic implementation. + [TestFixture] + TServerStatusResourceTests = class + private + procedure ReadCounters(out RequestCount: Int64; out ActiveConnections: Integer); + public + [Setup] + procedure Setup; + + [Test] procedure Counters_StartAtZero; + [Test] procedure Counters_AreExactUnderConcurrentUpdates; + [Test] procedure ConnectionClosed_NeverGoesBelowZero; + [Test] procedure Read_ProducesJsonWithStatusFields; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + System.JSON, + System.Threading, + MCPServer.Resource.Base, + MCPServer.Resource.Server; + +const + THREAD_COUNT = 8; + ITERATIONS_PER_THREAD = 20000; + +{ TServerStatusResourceTests } + +procedure TServerStatusResourceTests.Setup; +begin + TServerStatusResource.Initialize; +end; + +procedure TServerStatusResourceTests.ReadCounters(out RequestCount: Int64; out ActiveConnections: Integer); +begin + var Resource: IMCPResource := TServerStatusResource.Create; + var Status := TJSONObject.ParseJSONValue(Resource.Read) as TJSONObject; + try + Assert.IsNotNull(Status, 'server://status must return a JSON object'); + RequestCount := Status.GetValue('requestcount'); + ActiveConnections := Status.GetValue('activeconnections'); + finally + Status.Free; + end; +end; + +procedure TServerStatusResourceTests.Counters_StartAtZero; +begin + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(Int64(0), RequestCount); + Assert.AreEqual(0, ActiveConnections); +end; + +procedure TServerStatusResourceTests.Counters_AreExactUnderConcurrentUpdates; +begin + var Tasks: TArray; + SetLength(Tasks, THREAD_COUNT); + for var I := 0 to High(Tasks) do + Tasks[I] := TTask.Run( + procedure + begin + for var J := 1 to ITERATIONS_PER_THREAD do + begin + TServerStatusResource.ConnectionOpened; + TServerStatusResource.IncrementRequestCount; + TServerStatusResource.ConnectionClosed; + end; + end); + TTask.WaitForAll(Tasks); + + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(Int64(THREAD_COUNT) * ITERATIONS_PER_THREAD, RequestCount, 'lost request increments'); + Assert.AreEqual(0, ActiveConnections, 'every opened connection was closed'); +end; + +procedure TServerStatusResourceTests.ConnectionClosed_NeverGoesBelowZero; +begin + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionOpened; + TServerStatusResource.ConnectionClosed; + TServerStatusResource.ConnectionClosed; + + var RequestCount: Int64; + var ActiveConnections: Integer; + ReadCounters(RequestCount, ActiveConnections); + + Assert.AreEqual(0, ActiveConnections); +end; + +procedure TServerStatusResourceTests.Read_ProducesJsonWithStatusFields; +begin + var Resource: IMCPResource := TServerStatusResource.Create; + Assert.AreEqual('server://status', Resource.URI); + Assert.AreEqual('application/json', Resource.MimeType); + + var Status := TJSONObject.ParseJSONValue(Resource.Read) as TJSONObject; + try + Assert.IsNotNull(Status); + Assert.AreEqual('running', Status.GetValue('status')); + Assert.IsNotNull(Status.GetValue('uptime')); + Assert.IsNotNull(Status.GetValue('memoryused')); + finally + Status.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TServerStatusResourceTests); + +end. diff --git a/tests/MCPServer.Tests.dpr b/tests/MCPServer.Tests.dpr index 0f82b5a..cd1144f 100644 --- a/tests/MCPServer.Tests.dpr +++ b/tests/MCPServer.Tests.dpr @@ -34,7 +34,9 @@ uses 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.Constants in 'MCPServer.Tests.Constants.pas', + MCPServer.Tests.ServerStatus in 'MCPServer.Tests.ServerStatus.pas', + MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas'; procedure RunTests; begin diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServer.Tests.dproj index 0236bb1..f3b5891 100644 --- a/tests/MCPServer.Tests.dproj +++ b/tests/MCPServer.Tests.dproj @@ -96,6 +96,8 @@ + + Base From 61f479e995401e43744cfb0d64c74cd4f3547b94 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:11:09 +0200 Subject: [PATCH 04/56] fix: keep stdout clean while the stdio transport runs TMCPStdioTransport.Create now forces TLogger.UseStdErr and sets the new TLogger.StdoutReserved guard. While the guard is set, console logging always goes to stderr and setting UseStdErr back to False is refused with a one-time warning on stderr. Library consumers that create the transport themselves no longer corrupt the MCP channel with log lines. Tests: guard forces stderr, refusal warns once, release restores the previous behaviour, transport constructor sets the guard. --- src/Core/MCPServer.Logger.pas | 67 ++++++++++++-- src/Server/MCPServer.StdioTransport.pas | 5 ++ tests/MCPServer.Tests.Logger.pas | 115 ++++++++++++++++++++++++ tests/MCPServer.Tests.dpr | 4 +- tests/MCPServer.Tests.dproj | 2 + 5 files changed, 185 insertions(+), 8 deletions(-) create mode 100644 tests/MCPServer.Tests.Logger.pas diff --git a/src/Core/MCPServer.Logger.pas b/src/Core/MCPServer.Logger.pas index d5c9d32..e977bf3 100644 --- a/src/Core/MCPServer.Logger.pas +++ b/src/Core/MCPServer.Logger.pas @@ -26,13 +26,16 @@ TLogger = class FMinLogLevel: TLogLevel; FOnLogMessage: TLogMessageProc; FUseStdErr: Boolean; - + FStdoutReserved: Boolean; + FStdoutWarningIssued: Boolean; + class procedure SetLogToConsole(const Value: Boolean); static; class procedure SetLogToFile(const Value: Boolean); static; class procedure SetLogFileName(const Value: string); static; class procedure SetMinLogLevel(const Value: TLogLevel); static; class procedure SetOnLogMessage(const Value: TLogMessageProc); static; class procedure SetUseStdErr(const Value: Boolean); static; + class procedure SetStdoutReserved(const Value: Boolean); static; class function GetLogToConsole: Boolean; static; class function GetLogToFile: Boolean; static; @@ -40,7 +43,8 @@ TLogger = class class function GetMinLogLevel: TLogLevel; static; class function GetOnLogMessage: TLogMessageProc; static; class function GetUseStdErr: Boolean; static; - + class function GetStdoutReserved: Boolean; static; + constructor CreateInstance; procedure DoWriteLog(const Level: TLogLevel; const Message: string); procedure EnsureLogFile; @@ -71,6 +75,11 @@ TLogger = class class property MinLogLevel: TLogLevel read GetMinLogLevel write SetMinLogLevel; class property OnLogMessage: TLogMessageProc read GetOnLogMessage write SetOnLogMessage; class property UseStdErr: Boolean read GetUseStdErr write SetUseStdErr; + /// True while a stdio transport owns stdout. Console logging then always + /// goes to stderr, and setting UseStdErr to False is refused with a + /// one-time warning, because anything on stdout that is not an MCP + /// message corrupts the channel. Set by TMCPStdioTransport.Create. + class property StdoutReserved: Boolean read GetStdoutReserved write SetStdoutReserved; end; implementation @@ -152,29 +161,33 @@ 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 + // Never touch stdout while a stdio transport owns it. + 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); @@ -331,10 +344,50 @@ 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; + + // Refused: stdout belongs to the stdio transport. Warn once, on stderr. + 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/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index da333b7..71c4415 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -32,6 +32,11 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core FManagerRegistry := ManagerRegistry; FCoreManager := CoreManager; FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(ManagerRegistry); + + // stdout carries MCP messages only; every log line must go to stderr, + // also for library consumers that never set UseStdErr themselves. + TLogger.UseStdErr := True; + TLogger.StdoutReserved := True; end; destructor TMCPStdioTransport.Destroy; diff --git a/tests/MCPServer.Tests.Logger.pas b/tests/MCPServer.Tests.Logger.pas new file mode 100644 index 0000000..701dae5 --- /dev/null +++ b/tests/MCPServer.Tests.Logger.pas @@ -0,0 +1,115 @@ +unit MCPServer.Tests.Logger; + +interface + +uses + DUnitX.TestFramework; + +type + /// The stdout guard: while a stdio transport runs, console logging must + /// never reach stdout, whatever a consumer sets on TLogger. + [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; + +initialization + TDUnitX.RegisterTestFixture(TLoggerStdoutGuardTests); + +end. diff --git a/tests/MCPServer.Tests.dpr b/tests/MCPServer.Tests.dpr index cd1144f..a748d9f 100644 --- a/tests/MCPServer.Tests.dpr +++ b/tests/MCPServer.Tests.dpr @@ -21,6 +21,7 @@ uses 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.StdioTransport in '..\src\Server\MCPServer.StdioTransport.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. @@ -36,7 +37,8 @@ uses MCPServer.Tests.Golden.Legacy in 'MCPServer.Tests.Golden.Legacy.pas', MCPServer.Tests.Constants in 'MCPServer.Tests.Constants.pas', MCPServer.Tests.ServerStatus in 'MCPServer.Tests.ServerStatus.pas', - MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas'; + MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas', + MCPServer.Tests.Logger in 'MCPServer.Tests.Logger.pas'; procedure RunTests; begin diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServer.Tests.dproj index f3b5891..52f79d7 100644 --- a/tests/MCPServer.Tests.dproj +++ b/tests/MCPServer.Tests.dproj @@ -85,6 +85,7 @@ + @@ -98,6 +99,7 @@ + Base From 4c18b8b039b43a434e1244e2382f74a93b206d05 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:17:29 +0200 Subject: [PATCH 05/56] test: add conformance, Inspector and stdio smoke scripts with the first baselines scripts/run-conformance.ps1 builds and starts the server and runs the official conformance CLI for the frozen 2026-07-28 and 2025-11-25 requirement sets against the same endpoint. One expected-failures file per set (conformance-baseline-.yml), because a scenario can pass on one wire and fail on the other and a passing baseline entry counts as stale. The baselines record the current state: 36 scored failures for 2026-07-28, 22 for 2025-11-25. scripts/run-inspector-smoke.ps1 lists tools through the Inspector CLI for the legacy, auto and modern eras over HTTP and for stdio (ci-servers.json); legacy, auto and stdio pass, modern fails until server/discover exists. scripts/run-stdio-smoke.ps1 drives --stdio through cmd redirection and checks the framing: one JSON object per line on stdout, logs on stderr. It also records that non-ASCII stdin is decoded with the ANSI code page. package.json pins the Node tooling (conformance 0.2.0-alpha.11 for the --requirements flag, Inspector 2.5.0). --- ci-servers.json | 24 +++++ conformance-baseline-2025-11-25.yml | 27 +++++ conformance-baseline-2026-07-28.yml | 40 +++++++ package.json | 18 ++++ scripts/McpServerProcess.ps1 | 156 ++++++++++++++++++++++++++++ scripts/run-conformance.ps1 | 110 ++++++++++++++++++++ scripts/run-inspector-smoke.ps1 | 118 +++++++++++++++++++++ scripts/run-stdio-smoke.ps1 | 121 +++++++++++++++++++++ 8 files changed, 614 insertions(+) create mode 100644 ci-servers.json create mode 100644 conformance-baseline-2025-11-25.yml create mode 100644 conformance-baseline-2026-07-28.yml create mode 100644 package.json create mode 100644 scripts/McpServerProcess.ps1 create mode 100644 scripts/run-conformance.ps1 create mode 100644 scripts/run-inspector-smoke.ps1 create mode 100644 scripts/run-stdio-smoke.ps1 diff --git a/ci-servers.json b/ci-servers.json new file mode 100644 index 0000000..1094df3 --- /dev/null +++ b/ci-servers.json @@ -0,0 +1,24 @@ +{ + "mcpServers": { + "delphi-legacy": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "legacy" + }, + "delphi-auto": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "auto" + }, + "delphi-modern": { + "type": "http", + "url": "http://127.0.0.1:3000/mcp", + "protocolEra": "modern" + }, + "delphi-stdio": { + "type": "stdio", + "command": "Win64\\Release\\MCPServer.exe", + "args": ["--stdio"] + } + } +} diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml new file mode 100644 index 0000000..9d7034e --- /dev/null +++ b/conformance-baseline-2025-11-25.yml @@ -0,0 +1,27 @@ +# Known conformance failures for --requirements 2025-11-25 +# Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). +# Regenerate after each phase with scripts/run-conformance.ps1 -NoBaseline and prune what passes. +server: + - logging-set-level + - completion-complete + - tools-call-image + - tools-call-audio + - tools-call-embedded-resource + - tools-call-mixed-content + - tools-call-with-logging + - tools-call-with-progress + - tools-call-sampling + - tools-call-elicitation + - elicitation-sep1034-defaults + - elicitation-sep1330-enums + - resources-read-binary + - resources-subscribe + - resources-unsubscribe + - prompts-list + - prompts-get-simple + - prompts-get-with-args + - prompts-get-embedded-resource + - prompts-get-with-image + - dns-rebinding-protection + # only a WARNING check (no session id on the SSE path); the runner counts it as not passed + - server-sse-multiple-streams diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml new file mode 100644 index 0000000..5c21729 --- /dev/null +++ b/conformance-baseline-2026-07-28.yml @@ -0,0 +1,40 @@ +# Known conformance failures for --requirements 2026-07-28 +# Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). +# Regenerate after each phase with scripts/run-conformance.ps1 -NoBaseline and prune what passes. +server: + - server-stateless + - completion-complete + - tools-list + - tools-call-simple-text + - tools-call-image + - tools-call-audio + - tools-call-embedded-resource + - tools-call-mixed-content + - tools-call-error + - tools-call-with-progress + - resources-list + - resources-read-text + - resources-read-binary + - resources-templates-read + - sep-2164-resource-not-found + - prompts-list + - prompts-get-simple + - prompts-get-with-args + - prompts-get-embedded-resource + - prompts-get-with-image + - dns-rebinding-protection + - caching + - input-required-result-basic-elicitation + - input-required-result-basic-sampling + - input-required-result-basic-list-roots + - input-required-result-request-state + - input-required-result-multiple-input-requests + - input-required-result-multi-round + - input-required-result-missing-input-response + - input-required-result-non-tool-request + - input-required-result-result-type + - input-required-result-unsupported-methods + - input-required-result-tampered-state + - input-required-result-capability-check + - input-required-result-ignore-extra-params + - input-required-result-validate-input diff --git a/package.json b/package.json new file mode 100644 index 0000000..2c47523 --- /dev/null +++ b/package.json @@ -0,0 +1,18 @@ +{ + "name": "delphi-mcp-server-tooling", + "version": "0.0.0", + "private": true, + "description": "Pinned Node tooling for the conformance and Inspector smoke runs of the Delphi MCP Server (see scripts/).", + "engines": { + "node": ">=22.19.0" + }, + "scripts": { + "conformance": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-conformance.ps1", + "inspector:smoke": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-inspector-smoke.ps1", + "stdio:smoke": "powershell -NoProfile -ExecutionPolicy Bypass -File scripts/run-stdio-smoke.ps1" + }, + "devDependencies": { + "@modelcontextprotocol/conformance": "0.2.0-alpha.11", + "@modelcontextprotocol/inspector": "2.5.0" + } +} diff --git a/scripts/McpServerProcess.ps1 b/scripts/McpServerProcess.ps1 new file mode 100644 index 0000000..9a94f10 --- /dev/null +++ b/scripts/McpServerProcess.ps1 @@ -0,0 +1,156 @@ +# Helper functions for scripts that need a running server executable. +# Dot-source this file: . "$PSScriptRoot\McpServerProcess.ps1" + +function Get-RepoRoot { + return Split-Path -Parent $PSScriptRoot +} + +function Invoke-ServerBuild { + param( + [Parameter(Mandatory)] [string]$Configuration, + [Parameter(Mandatory)] [string]$Platform + ) + $repoRoot = Get-RepoRoot + Write-Host "Building server ($Configuration $Platform)..." + & cmd.exe /c "cd /d `"$repoRoot`" && .\build.bat $Configuration $Platform" + if ($LASTEXITCODE -ne 0) { + throw "Server build failed with exit code $LASTEXITCODE" + } +} + +function Wait-McpPort { + param( + [Parameter(Mandatory)] [int]$Port, + [int]$TimeoutSeconds = 15 + ) + $deadline = (Get-Date).AddSeconds($TimeoutSeconds) + while ((Get-Date) -lt $deadline) { + $client = New-Object System.Net.Sockets.TcpClient + try { + $client.Connect('127.0.0.1', $Port) + if ($client.Connected) { return $true } + } catch { + } finally { + $client.Dispose() + } + Start-Sleep -Milliseconds 200 + } + return $false +} + +<# +.SYNOPSIS + Starts the server executable on the given port and waits for it. + +.DESCRIPTION + The server reads settings.ini next to its executable, so a temporary one + with the requested port is written. Stop-McpServer restores the original. + Returns a handle object for Stop-McpServer. +#> +function Start-McpServer { + param( + [Parameter(Mandatory)] [string]$ServerExe, + [Parameter(Mandatory)] [int]$Port, + [Parameter(Mandatory)] [string]$LogDir + ) + + $ServerExe = (Resolve-Path $ServerExe).Path + $exeDir = Split-Path -Parent $ServerExe + $settingsFile = Join-Path $exeDir 'settings.ini' + $settingsBackup = $null + if (Test-Path $settingsFile) { + $settingsBackup = Get-Content -Raw $settingsFile + } + + $settingsContent = @" +[Server] +Port=$Port +Host=localhost +Name=delphi-mcp-server +Version=1.0.0 +Endpoint=/mcp + +[CORS] +Enabled=1 +AllowedOrigins=http://localhost,http://127.0.0.1,https://localhost,https://127.0.0.1 + +[SSL] +Enabled=0 +"@ + Set-Content -Path $settingsFile -Value $settingsContent -Encoding ASCII + + New-Item -ItemType Directory -Force -Path $LogDir | Out-Null + $process = Start-Process -FilePath $ServerExe -WorkingDirectory $exeDir -PassThru -NoNewWindow ` + -RedirectStandardOutput (Join-Path $LogDir 'server.log') ` + -RedirectStandardError (Join-Path $LogDir 'server.err.log') + + $handle = [pscustomobject]@{ + Process = $process + SettingsFile = $settingsFile + SettingsBackup = $settingsBackup + Port = $Port + Url = "http://127.0.0.1:$Port/mcp" + } + + if (-not (Wait-McpPort -Port $Port)) { + Stop-McpServer $handle + throw "Server did not open port $Port within the timeout (see $LogDir\server.log)" + } + return $handle +} + +function Stop-McpServer { + param([Parameter(Mandatory)] $Handle) + + if ($Handle.Process -and -not $Handle.Process.HasExited) { + Stop-Process -Id $Handle.Process.Id -Force + $Handle.Process.WaitForExit(5000) | Out-Null + } + if ($null -ne $Handle.SettingsBackup) { + Set-Content -Path $Handle.SettingsFile -Value $Handle.SettingsBackup -NoNewline + } else { + Remove-Item $Handle.SettingsFile -ErrorAction SilentlyContinue + } +} + +<# +.SYNOPSIS + Runs a native command line through cmd.exe with both streams in a log file. + +.DESCRIPTION + Windows PowerShell 5.1 turns stderr lines of native commands into error + records, which aborts scripts that run with ErrorActionPreference Stop. + Writing the command line to a batch file and redirecting inside cmd.exe + keeps the output intact. Returns the exit code. +#> +function Invoke-NativeToLog { + param( + [Parameter(Mandatory)] [string]$CommandLine, + [Parameter(Mandatory)] [string]$LogFile, + [Parameter(Mandatory)] [string]$WorkingDirectory + ) + $batchFile = [System.IO.Path]::ChangeExtension($LogFile, '.cmd') + $content = @( + '@echo off' + "cd /d `"$WorkingDirectory`"" + "$CommandLine > `"$LogFile`" 2>&1" + 'exit /b %ERRORLEVEL%' + ) + Set-Content -Path $batchFile -Value $content -Encoding ASCII + $process = Start-Process -FilePath 'cmd.exe' -ArgumentList @('/c', "`"$batchFile`"") -PassThru -NoNewWindow -Wait + return $process.ExitCode +} + +function Assert-NodeTooling { + $repoRoot = Get-RepoRoot + if (-not (Test-Path (Join-Path $repoRoot 'node_modules\@modelcontextprotocol'))) { + Write-Host 'Installing pinned Node tooling (npm install)...' + Push-Location $repoRoot + try { + & npm.cmd install --no-audit --no-fund + if ($LASTEXITCODE -ne 0) { throw "npm install failed with exit code $LASTEXITCODE" } + } finally { + Pop-Location + } + } +} diff --git a/scripts/run-conformance.ps1 b/scripts/run-conformance.ps1 new file mode 100644 index 0000000..fa45d5e --- /dev/null +++ b/scripts/run-conformance.ps1 @@ -0,0 +1,110 @@ +<# +.SYNOPSIS + Runs the official MCP conformance suite against the built server. + +.DESCRIPTION + Builds the server, starts it, and runs + "npx @modelcontextprotocol/conformance server" once per requirement set + (2026-07-28 and 2025-11-25 by default) against the same endpoint. Known + failures are read from conformance-baseline.yml; the run fails on new + failures and on stale baseline entries. Reports land in + tests\results\conformance\. + + The pinned tool version comes from package.json (the --requirements flag + needs the 0.2.0 line of the conformance package). + +.PARAMETER Configuration + Release (default) or Debug. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER Port + Port to start the server on. Default: 3000. + +.PARAMETER Requirements + Requirement sets to run. Default: 2026-07-28 and 2025-11-25. + +.PARAMETER NoBuild + Use the existing executable. + +.PARAMETER NoBaseline + Run without the expected-failures file (to see the raw result). + +.EXAMPLE + .\scripts\run-conformance.ps1 + .\scripts\run-conformance.ps1 -NoBuild -Requirements 2025-11-25 +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Release', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [int]$Port = 3000, + + [string[]]$Requirements = @('2026-07-28', '2025-11-25'), + + [switch]$NoBuild, + + [switch]$NoBaseline +) + +$ErrorActionPreference = 'Stop' +. "$PSScriptRoot\McpServerProcess.ps1" + +$repoRoot = Get-RepoRoot +$serverExe = Join-Path $repoRoot "$Platform\$Configuration\MCPServer.exe" +$resultsRoot = Join-Path $repoRoot 'tests\results\conformance' +$baseline = Join-Path $repoRoot 'conformance-baseline.yml' + +if (-not $NoBuild) { + Invoke-ServerBuild -Configuration $Configuration -Platform $Platform +} +Assert-NodeTooling + +New-Item -ItemType Directory -Force -Path $resultsRoot | Out-Null +$server = Start-McpServer -ServerExe $serverExe -Port $Port -LogDir $resultsRoot + +$summary = @() +try { + foreach ($revision in $Requirements) { + $outputDir = Join-Path $resultsRoot $revision + $logFile = Join-Path $resultsRoot "$revision.log" + $commandLine = "npx @modelcontextprotocol/conformance server --url $($server.Url) --requirements $revision -o `"$outputDir`"" + # One baseline per requirement set: a scenario can pass on one wire + # and fail on the other, and a listed scenario that passes counts as a + # stale entry. + $baseline = Join-Path $repoRoot "conformance-baseline-$revision.yml" + if (-not $NoBaseline -and (Test-Path $baseline)) { + $commandLine += " --expected-failures `"$baseline`"" + } + + Write-Host '' + Write-Host "=== conformance --requirements $revision ===" + $exitCode = Invoke-NativeToLog -CommandLine $commandLine -LogFile $logFile -WorkingDirectory $repoRoot + + # The per-scenario progress is in the log file; show the summary only. + $logText = [System.IO.File]::ReadAllText($logFile) + $summaryStart = $logText.LastIndexOf('=== SUMMARY ===') + if ($summaryStart -ge 0) { Write-Host $logText.Substring($summaryStart) } else { Write-Host $logText } + $summary += [pscustomobject]@{ Revision = $revision; ExitCode = $exitCode; Log = $logFile } + } +} +finally { + Stop-McpServer $server +} + +Write-Host '' +Write-Host 'Summary:' +$summary | Format-Table -AutoSize | Out-String | Write-Host + +$failed = @($summary | Where-Object { $_.ExitCode -ne 0 }) +if ($failed.Count -gt 0) { + Write-Host "$($failed.Count) requirement set(s) did not match the baseline" + exit 1 +} +Write-Host 'All requirement sets match the baseline' +exit 0 diff --git a/scripts/run-inspector-smoke.ps1 b/scripts/run-inspector-smoke.ps1 new file mode 100644 index 0000000..66317bb --- /dev/null +++ b/scripts/run-inspector-smoke.ps1 @@ -0,0 +1,118 @@ +<# +.SYNOPSIS + Smoke-tests the server with the MCP Inspector CLI in every protocol era. + +.DESCRIPTION + Starts the built server and calls tools/list through + "npx @modelcontextprotocol/inspector --cli" for each entry in + ci-servers.json: delphi-legacy, delphi-auto, delphi-modern over HTTP and + delphi-stdio over a spawned process. The pinned Inspector version comes + from package.json. + + Until the 2026-07-28 work lands, the modern entry is expected to fail; + pass -ExpectModern once it must succeed. The script exits non-zero when + an entry that is expected to work fails, or when the modern entry + unexpectedly passes or fails. + +.PARAMETER Configuration + Release (default) or Debug. The stdio entry in ci-servers.json points at + Win64\Release\MCPServer.exe. + +.PARAMETER Platform + Win64 (default) or Win32. + +.PARAMETER NoBuild + Use the existing executable. + +.PARAMETER ExpectModern + Treat a failing modern entry as an error. + +.EXAMPLE + .\scripts\run-inspector-smoke.ps1 +#> +[CmdletBinding()] +param( + [ValidateSet('Debug', 'Release')] + [string]$Configuration = 'Release', + + [ValidateSet('Win32', 'Win64')] + [string]$Platform = 'Win64', + + [switch]$NoBuild, + + [switch]$ExpectModern +) + +$ErrorActionPreference = 'Stop' +. "$PSScriptRoot\McpServerProcess.ps1" + +$repoRoot = Get-RepoRoot +$serverExe = Join-Path $repoRoot "$Platform\$Configuration\MCPServer.exe" +$resultsDir = Join-Path $repoRoot 'tests\results\inspector' +$config = Join-Path $repoRoot 'ci-servers.json' +$port = 3000 # ci-servers.json points at this port + +if (-not $NoBuild) { + Invoke-ServerBuild -Configuration $Configuration -Platform $Platform +} +Assert-NodeTooling + +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null +$server = Start-McpServer -ServerExe $serverExe -Port $port -LogDir $resultsDir + +$entries = @( + @{ Name = 'delphi-legacy'; ExpectSuccess = $true } + @{ Name = 'delphi-auto'; ExpectSuccess = $true } + @{ Name = 'delphi-modern'; ExpectSuccess = [bool]$ExpectModern } + @{ Name = 'delphi-stdio'; ExpectSuccess = $true } +) + +$rows = @() +try { + foreach ($entry in $entries) { + $logFile = Join-Path $resultsDir "$($entry.Name).log" + $commandLine = "npx @modelcontextprotocol/inspector --cli --config `"$config`" --server $($entry.Name) --method tools/list --format json" + $exitCode = Invoke-NativeToLog -CommandLine $commandLine -LogFile $logFile -WorkingDirectory $repoRoot + $text = [System.IO.File]::ReadAllText($logFile) + + # The JSON result is one line on stdout. A stdio server's stderr log + # lines share the log file and can interleave with it, so locate the + # result object by its prefix and parse up to the end of that line. + $toolCount = $null + $resultStart = $text.LastIndexOf('{"result":') + if ($resultStart -ge 0) { + $resultEnd = $text.IndexOfAny([char[]]@("`r", "`n"), $resultStart) + if ($resultEnd -lt 0) { $resultEnd = $text.Length } + $jsonLine = $text.Substring($resultStart, $resultEnd - $resultStart) + try { + $json = $jsonLine | ConvertFrom-Json + if ($json.result -and $json.result.tools) { $toolCount = @($json.result.tools).Count } + } catch { + } + } + + $succeeded = ($exitCode -eq 0) -and ($null -ne $toolCount) + $asExpected = ($succeeded -eq $entry.ExpectSuccess) + $rows += [pscustomobject]@{ + Server = $entry.Name + ExitCode = $exitCode + Tools = $toolCount + Succeeded = $succeeded + Expected = $entry.ExpectSuccess + AsExpected = $asExpected + } + } +} +finally { + Stop-McpServer $server +} + +$rows | Format-Table -AutoSize | Out-String | Write-Host + +$unexpected = @($rows | Where-Object { -not $_.AsExpected }) +if ($unexpected.Count -gt 0) { + Write-Host "$($unexpected.Count) entr(y/ies) did not behave as expected (see $resultsDir)" + exit 1 +} +Write-Host 'Inspector smoke run behaved as expected' +exit 0 diff --git a/scripts/run-stdio-smoke.ps1 b/scripts/run-stdio-smoke.ps1 new file mode 100644 index 0000000..13afd19 --- /dev/null +++ b/scripts/run-stdio-smoke.ps1 @@ -0,0 +1,121 @@ +<# +.SYNOPSIS + Drives the server over stdio and checks the framing of the channel. + +.DESCRIPTION + Feeds a fixed set of JSON-RPC lines (initialize, initialized, tools/list, + tools/call echo with non-ASCII text) to "MCPServer.exe --stdio" through + cmd.exe redirection, exactly as a client spawning the process would, and + checks: + - stdout holds one JSON object per line and nothing else, + - every request id gets exactly one response, + - all log lines went to stderr. + It also reports whether the non-ASCII text survived the round trip; this + is an observation for the stdio work (Text I/O decodes stdin with the + ANSI code page on Windows) and does not fail the run. + +.PARAMETER ServerExe + Path to the executable. Default: Win64\Release\MCPServer.exe. + +.EXAMPLE + .\scripts\run-stdio-smoke.ps1 +#> +[CmdletBinding()] +param( + [string]$ServerExe +) + +$ErrorActionPreference = 'Stop' + +$repoRoot = Split-Path -Parent $PSScriptRoot +if (-not $ServerExe) { + $ServerExe = Join-Path $repoRoot 'Win64\Release\MCPServer.exe' +} +$ServerExe = (Resolve-Path $ServerExe).Path +$resultsDir = Join-Path $repoRoot 'tests\results\stdio' +New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null + +$inputFile = Join-Path $resultsDir 'input.jsonl' +$stdoutFile = Join-Path $resultsDir 'stdout.txt' +$stderrFile = Join-Path $resultsDir 'stderr.txt' + +$probe = 'h' + [char]0x00E9 + 'llo w' + [char]0x00F6 + 'rld' +$lines = @( + '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"stdio-smoke","version":"1.0.0"}}}' + '{"jsonrpc":"2.0","method":"notifications/initialized"}' + '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' + ('{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"' + $probe + '"}}}') +) +$utf8 = New-Object System.Text.UTF8Encoding($false) +[System.IO.File]::WriteAllBytes($inputFile, $utf8.GetBytes(($lines -join "`n") + "`n")) + +# A batch file keeps the redirections out of PowerShell's argument quoting. +$batchFile = Join-Path $resultsDir 'run.cmd' +$command = "@`"$ServerExe`" --stdio < `"$inputFile`" > `"$stdoutFile`" 2> `"$stderrFile`"" +Set-Content -Path $batchFile -Value $command -Encoding ASCII +$process = Start-Process -FilePath 'cmd.exe' -ArgumentList @('/c', "`"$batchFile`"") -WorkingDirectory (Split-Path -Parent $ServerExe) ` + -PassThru -NoNewWindow -Wait +if ($process.ExitCode -ne 0) { + Write-Host "Server exited with code $($process.ExitCode)" +} + +$stdout = $utf8.GetString([System.IO.File]::ReadAllBytes($stdoutFile)) +$stderr = $utf8.GetString([System.IO.File]::ReadAllBytes($stderrFile)) + +$failures = 0 +$stdoutLines = @($stdout -split "`r?`n" | Where-Object { $_ -ne '' }) + +Write-Host "stdout lines: $($stdoutLines.Count)" +$responses = @{} +foreach ($line in $stdoutLines) { + try { + $message = $line | ConvertFrom-Json + } catch { + Write-Host "NOT JSON on stdout: $line" + $failures++ + continue + } + if ($null -eq $message.jsonrpc) { + Write-Host "stdout line is not a JSON-RPC message: $line" + $failures++ + continue + } + if ($null -ne $message.id) { $responses[[string]$message.id] = $message } +} + +foreach ($id in '1', '2', '3') { + if (-not $responses.ContainsKey($id)) { + Write-Host "missing response for id $id" + $failures++ + } +} +if ($stdoutLines.Count -ne 3) { + Write-Host "expected exactly 3 responses on stdout, got $($stdoutLines.Count)" + $failures++ +} + +if ($stdout -match '\[(INFO|WARN|ERROR|DEBUG)\s*\]') { + Write-Host 'log lines found on stdout' + $failures++ +} +if ($stderr.Trim().Length -eq 0) { + Write-Host 'expected log lines on stderr, found none' + $failures++ +} + +if ($responses.ContainsKey('3')) { + $echoText = $responses['3'].result.content[0].text + if ($echoText -eq "Echo: $probe") { + Write-Host "observation: non-ASCII input survived the stdio round trip" + } else { + Write-Host "observation: non-ASCII input was altered on the stdio round trip: $echoText" + } +} + +Write-Host "stderr: $($stderr.Length) characters (see $stderrFile)" +if ($failures -gt 0) { + Write-Host "$failures check(s) failed" + exit 1 +} +Write-Host 'stdio smoke run passed' +exit 0 From 1a42cf1b6407e379f12e371ba825bbdcc94ba86d Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 12:18:54 +0200 Subject: [PATCH 06/56] docs: add CHANGELOG and document the library rules and the test tooling README: library checklist (register before start, stdout rules for stdio, server://status is opt-in, constants in MCPServer.Types), resource list matching what the executable registers, automated-tests section. CHANGELOG.md starts with the unreleased phase-0 entries. --- CHANGELOG.md | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 29 +++++++++++++++++++++++-- 2 files changed, 88 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.md diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..c13ea21 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,61 @@ +# 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] + +Safety net for the MCP 2026-07-28 work: the legacy wire behaviour is pinned +before any protocol change lands. No client-visible protocol change. + +### Added + +- DUnitX test project `tests\MCPServer.Tests.dpr` (Win32 and Win64) with an + in-process harness that builds the same registry as `MCPServer.dpr` and + drives `TMCPJsonRpcProcessor.ProcessRequest`. +- Golden files that pin today's responses: 37 JSON-RPC cases in + `tests\golden\legacy` and 26 HTTP transport cases (status line, headers, + body) in `tests\golden\http`, recorded from the unchanged 2025-06-18 code. +- `build-tests.bat` and `scripts\run-tests.ps1` (build and run, `-Record` + to re-record goldens), `scripts\capture-http-goldens.ps1`. +- `scripts\run-conformance.ps1` for the official conformance CLI with one + expected-failures baseline per requirement set + (`conformance-baseline-2026-07-28.yml`, `conformance-baseline-2025-11-25.yml`), + `scripts\run-inspector-smoke.ps1` with `ci-servers.json` (legacy, auto and + modern eras plus stdio) and `scripts\run-stdio-smoke.ps1`. +- `package.json` pinning the Node tooling (`@modelcontextprotocol/conformance` + 0.2.0-alpha.11, `@modelcontextprotocol/inspector` 2.5.0). +- Protocol constants in `MCPServer.Types`: revision names and sets + (`MCP_PROTOCOL_VERSION_*`, `MCP_LATEST_PROTOCOL_VERSION`, + `MCP_LEGACY_PROTOCOL_VERSIONS`, `MCP_MODERN_PROTOCOL_VERSIONS`), the MCP + error codes `MCP_ERROR_HEADER_MISMATCH` (-32020), + `MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY` (-32021), + `MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION` (-32022) and + `MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY` (-32002), the reserved `_meta` keys + (`MCP_META_*`) and `MCP_CACHEABLE_METHODS`. +- `TLogger.StdoutReserved`: while set, console logging always goes to stderr + and `UseStdErr := False` is refused with a one-time warning. + +### Changed + +- 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. +- README: library checklist (register before start, stdout rules for stdio, + `server://status` is opt-in), automated-tests section, resource list matches + what the executable registers. + +### Fixed + +- `TServerStatusResource` request and connection counters and the SSE event-id + counter are updated atomically; they were plain increments shared by all + Indy connection threads. diff --git a/README.md b/README.md index 96adf09..b4a8843 100644 --- a/README.md +++ b/README.md @@ -219,6 +219,13 @@ begin end. ``` +#### Library checklist + +- **Register before you start.** `TMCPToolsManager.Create` and `TMCPResourcesManager.Create` read `TMCPRegistry` once. Register your tools and resources (normally from unit `initialization` sections) before the managers are created, which means before `TMCPIdHTTPServer.Start` or `TMCPStdioTransport.Run`. Later registrations are not picked up. +- **STDIO: keep stdout clean.** Everything on stdout must be an MCP message. `TMCPStdioTransport.Create` forces `TLogger.UseStdErr := True` and sets `TLogger.StdoutReserved`, so console logging goes to stderr and an attempt to switch it back is refused with a one-time warning. Never `Writeln` from tools, managers or resources; log through `TLogger`. +- **`server://status` is opt-in.** Call `TServerStatusResource.RegisterServerStatusResource` (or `SetNamePrefix`) before the managers are created if you want it; the shipped executable registers `project://info`, `project://readme` and `logs://recent` only. +- **Error codes and protocol constants** live in `MCPServer.Types` (`JSONRPC_*`, `MCP_ERROR_*`, `MCP_PROTOCOL_VERSION_*`, `MCP_META_*`). The `JSONRPC_*` names in `MCPServer.JsonRpcProcessor` remain as aliases. + ### Creating Custom Tools ```pascal @@ -444,12 +451,15 @@ The Inspector provides a web interface to interact with your MCP server, making ## Available Example resources -The server provides four essential resources accessible via URIs: +The executable registers three resources: - **project://info** - Project information (JSON metadata with collections) - **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 + +A fourth one ships with the library and is opt-in (see the library checklist): + +- **server://status** - Current server status and health information (request and connection counters) ## Configuration @@ -562,6 +572,21 @@ We welcome contributions! Here's how to help: - Open `MCPServer.dproj` or build with `build.bat` - Test with `npx @modelcontextprotocol/inspector` or Claude Code or similar +### Automated tests + +The `tests` folder holds a DUnitX project that drives the JSON-RPC layer in-process and pins the wire behaviour with golden files (`tests\golden`, see the README there). The scripts under `scripts` wrap the build and the external tooling; the Node tools are pinned in `package.json`. + +```powershell +.\scripts\run-tests.ps1 # build tests\MCPServer.Tests.dpr (Win64 Debug) and run it +.\scripts\run-tests.ps1 -Platform Win32 +.\scripts\capture-http-goldens.ps1 # replay the HTTP golden cases with curl against Win64\Debug\MCPServer.exe +.\scripts\run-stdio-smoke.ps1 # drive --stdio and check the framing of stdout/stderr +.\scripts\run-conformance.ps1 # official conformance CLI, 2026-07-28 and 2025-11-25 requirement sets +.\scripts\run-inspector-smoke.ps1 # Inspector CLI tools/list in the legacy, auto and modern eras and over stdio +``` + +Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. `build-tests.bat [Config] [Platform]` compiles the test project on its own. + ## About GDK Software [GDK Software](https://www.gdksoftware.com) is a Delphi specialist: we build, upgrade and maintain Delphi applications worldwide, and offer Delphi and AI consultancy and AI training. From 95b5042ffbd432be02357f2aa340baf7be9384fa Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 13:18:55 +0200 Subject: [PATCH 07/56] fix: repair the built-in resources and the nil dereferences found while recording - logs://recent answered "Invalid pointer operation": the copied entries were owned by two lists and freed twice. - TMCPSerializer wrote TList and TObjectList properties as an object with count and capacity; they are JSON arrays now, so project://info lists its features and logs://recent its entries. - server://status was declared but never registered; the unit registers it by default and SetNamePrefix replaces that registration (TMCPRegistry.UnregisterResource is new). - resources/read without params is handled like a missing uri, and tools/call without arguments hands the tool an empty object, instead of dereferencing nil. Goldens re-recorded for the affected cases (resources-list, resources-read-project-info, resources-read-logs-recent, resources-read-server-status, resources-read-without-params, tools-call-missing-arguments) plus the HTTP resources cases; every other golden is unchanged. --- CHANGELOG.md | 13 +++++ README.md | 7 +-- src/Core/MCPServer.Registration.pas | 12 +++++ src/Managers/MCPServer.ResourcesManager.pas | 14 +++-- src/Managers/MCPServer.ToolsManager.pas | 19 +++++-- src/Protocol/MCPServer.Serializer.pas | 51 +++++++++++++++++- src/Resources/MCPServer.Resource.Logs.pas | 10 +++- src/Resources/MCPServer.Resource.Server.pas | 41 ++++++--------- tests/MCPServer.Tests.Golden.Legacy.pas | 6 +++ tests/MCPServer.Tests.Registration.pas | 13 +++-- tests/golden/README.md | 22 ++++---- tests/golden/http/post-initialize-sse.txt | 2 - tests/golden/http/post-resources-list.txt | 4 +- .../http/post-resources-read-project-info.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 2 - tests/golden/legacy/resources-list.json | 6 +++ .../legacy/resources-read-logs-recent.json | 52 ++++++++++++++++++- .../legacy/resources-read-project-info.json | 2 +- .../legacy/resources-read-server-status.json | 34 ++++++++++++ .../legacy/resources-read-without-params.json | 14 ++--- .../legacy/tools-call-missing-arguments.json | 8 +-- 21 files changed, 257 insertions(+), 79 deletions(-) create mode 100644 tests/golden/legacy/resources-read-server-status.json diff --git a/CHANGELOG.md b/CHANGELOG.md index c13ea21..664592c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -59,3 +59,16 @@ before any protocol change lands. No client-visible protocol change. - `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. diff --git a/README.md b/README.md index b4a8843..558794a 100644 --- a/README.md +++ b/README.md @@ -223,7 +223,7 @@ end. - **Register before you start.** `TMCPToolsManager.Create` and `TMCPResourcesManager.Create` read `TMCPRegistry` once. Register your tools and resources (normally from unit `initialization` sections) before the managers are created, which means before `TMCPIdHTTPServer.Start` or `TMCPStdioTransport.Run`. Later registrations are not picked up. - **STDIO: keep stdout clean.** Everything on stdout must be an MCP message. `TMCPStdioTransport.Create` forces `TLogger.UseStdErr := True` and sets `TLogger.StdoutReserved`, so console logging goes to stderr and an attempt to switch it back is refused with a one-time warning. Never `Writeln` from tools, managers or resources; log through `TLogger`. -- **`server://status` is opt-in.** Call `TServerStatusResource.RegisterServerStatusResource` (or `SetNamePrefix`) before the managers are created if you want it; the shipped executable registers `project://info`, `project://readme` and `logs://recent` only. +- **`server://status` is registered by default** by the unit initialization of `MCPServer.Resource.Server`. `TServerStatusResource.SetNamePrefix('myapp_')` renames it to `server://myapp_status`; call it before the managers are created. - **Error codes and protocol constants** live in `MCPServer.Types` (`JSONRPC_*`, `MCP_ERROR_*`, `MCP_PROTOCOL_VERSION_*`, `MCP_META_*`). The `JSONRPC_*` names in `MCPServer.JsonRpcProcessor` remain as aliases. ### Creating Custom Tools @@ -451,14 +451,11 @@ The Inspector provides a web interface to interact with your MCP server, making ## Available Example resources -The executable registers three resources: +The server provides four resources accessible via URIs: - **project://info** - Project information (JSON metadata with collections) - **project://readme** - This README file (markdown content) - **logs://recent** - Recent log entries from all categories (with thread safety) - -A fourth one ships with the library and is opt-in (see the library checklist): - - **server://status** - Current server status and health information (request and connection counters) ## Configuration diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index 7f8f029..1f28a28 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -33,6 +33,9 @@ TMCPRegistry = class public class procedure RegisterTool(const Name: string; Factory: TMCPToolFactory); class procedure RegisterResource(const URI: string; Factory: TMCPResourceFactory); + /// Removes a registration again (no-op for an unknown URI). Like + /// registration, only meaningful before the managers are created. + class procedure UnregisterResource(const URI: string); class function CreateTool(const Name: string): IMCPTool; class function CreateResource(const URI: string): IMCPResource; @@ -72,6 +75,15 @@ class procedure TMCPRegistry.RegisterResource(const URI: string; Factory: TMCPRe TLogger.Info('Registered resource: ' + URI); end; +class procedure TMCPRegistry.UnregisterResource(const URI: string); +begin + if FResources.ContainsKey(URI) then + begin + FResources.Remove(URI); + TLogger.Info('Unregistered resource: ' + URI); + end; +end; + class function TMCPRegistry.CreateTool(const Name: string): IMCPTool; var Factory: TMCPToolFactory; diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 1c1f529..e0c6de9 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -131,11 +131,15 @@ function TMCPResourcesManager.ReadResource(const Params: System.JSON.TJSONObject URI: string; URIValue: TJSONValue; begin - URIValue := Params.GetValue('uri'); - if Assigned(URIValue) then - URI := URIValue.Value - else - URI := ''; + // Params is nil when the request carries no params object; treat that + // like a missing uri instead of dereferencing nil. + URI := ''; + if Assigned(Params) then + begin + URIValue := Params.GetValue('uri'); + if Assigned(URIValue) then + URI := URIValue.Value; + end; TLogger.Info('MCP ReadResource called for URI: ' + URI); diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index da937bb..c4e46aa 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -230,6 +230,7 @@ function TMCPToolsManager.BuildToolListResponse: TJSONObject; function TMCPToolsManager.CallTool(const Params: System.JSON.TJSONObject): TValue; var Arguments: TJSONObject; + EmptyArguments: TJSONObject; ResultValue: TValue; Tool: IMCPTool; ToolName: string; @@ -242,11 +243,21 @@ function TMCPToolsManager.CallTool(const Params: System.JSON.TJSONObject): TValu TLogger.Info('MCP CallTool called for tool: ' + ToolName); - if FTools.TryGetValue(ToolName, Tool) then - resultValue := ExecuteTool(Tool, Arguments) + if not FTools.TryGetValue(ToolName, Tool) then + ResultValue := TValue.From('Error: Tool not found: ' + ToolName) + else if Assigned(Arguments) then + ResultValue := ExecuteTool(Tool, Arguments) else - ResultValue := TValue.From('Error: Tool not found: ' + ToolName); - + begin + // "arguments" is optional on the wire; a tool always receives an object. + EmptyArguments := TJSONObject.Create; + try + ResultValue := ExecuteTool(Tool, EmptyArguments); + finally + EmptyArguments.Free; + end; + end; + Result := TValue.From(BuildToolCallResponse(ResultValue)); end; diff --git a/src/Protocol/MCPServer.Serializer.pas b/src/Protocol/MCPServer.Serializer.pas index d3ea794..049f2df 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -23,6 +23,7 @@ TMCPSerializer = class class function ConvertJsonToEnum(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; class function GetEnumValueNames(const EnumType: TRttiEnumerationType): string; class function ConvertValueToJson(const Value: TValue; const RttiType: TRttiType): TJSONValue; + class function TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; class function CreateInstanceFromType(const RttiType: TRttiType): TObject; // Array deserialization helpers @@ -364,7 +365,7 @@ 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); @@ -374,6 +375,54 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti end; end; +// Serialises TList and TObjectList (anything with an integer-indexed +// Items property and a Count) as a JSON array of their elements. Without +// this a list came out as an object with count and capacity members. +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; + + // Only integer indexes: TDictionary also has Count and Items. + 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; diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index cb5f02f..cb87fc7 100644 --- a/src/Resources/MCPServer.Resource.Logs.pas +++ b/src/Resources/MCPServer.Resource.Logs.pas @@ -74,6 +74,9 @@ implementation System.Math, MCPServer.Registration; +const + MAX_RECENT_LOG_ENTRIES = 100; + { TLogEntries } constructor TLogEntries.Create; @@ -208,11 +211,14 @@ function TLogsRecentResource.GetResourceData: TLogEntries; // Add access log entry TLogBuffer.Instance.AddLog('INFO', 'Resource accessed: logs://recent', 'ACCESS'); - Logs := TLogBuffer.Instance.GetLogs(100); + Logs := TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES); try - Result.Entries.AddRange(Logs.ToArray); + Result.Entries.AddRange(Logs); Result.TotalCount := Logs.Count; Result.FilteredCount := Logs.Count; + // GetLogs returns copies in an owning list; Result.Entries owns them + // from here on, otherwise they would be freed twice. + Logs.OwnsObjects := False; finally Logs.Free; end; diff --git a/src/Resources/MCPServer.Resource.Server.pas b/src/Resources/MCPServer.Resource.Server.pas index b35051f..3c51c7b 100644 --- a/src/Resources/MCPServer.Resource.Server.pas +++ b/src/Resources/MCPServer.Resource.Server.pas @@ -35,6 +35,7 @@ TServerStatusResource = class(TMCPResourceBase) class var FRequestCount: Int64; class var FActiveConnections: Integer; class var FNamePrefix: string; + class function StatusURI: string; protected function GetResourceData: TServerStatus; override; public @@ -42,13 +43,13 @@ TServerStatusResource = class(TMCPResourceBase) /// Resets the start time and the counters. Runs from the unit /// initialization and again from MCPServer.dpr before a transport starts. class procedure Initialize; - /// Registers the resource as server://status. The registry is read - /// once, when TMCPResourcesManager is created, so call this before the - /// managers are built (before TMCPIdHTTPServer.Start or - /// TMCPStdioTransport.Run); a later call registers a URI nobody serves. + /// Re-registers the resource as server://status and removes the + /// URI registered before. The registry is read once, when + /// TMCPResourcesManager is created, so call this before the managers are + /// built (before TMCPIdHTTPServer.Start or TMCPStdioTransport.Run). class procedure SetNamePrefix(const Prefix: string); - /// Registers server://status (or the prefixed URI). MCPServer.dpr does not - /// call this; the resource is opt-in for library consumers. + /// Registers server://status (or the prefixed URI). The unit + /// initialization does this once, so the resource is available by default. class procedure RegisterServerStatusResource; // The counters are updated from every Indy connection thread, so they // use atomic operations. @@ -79,22 +80,21 @@ class procedure TServerStatusResource.Initialize; FNamePrefix := ''; end; +class function TServerStatusResource.StatusURI: string; +begin + Result := 'server://' + FNamePrefix + 'status'; +end; + class procedure TServerStatusResource.SetNamePrefix(const Prefix: string); begin + TMCPRegistry.UnregisterResource(StatusURI); FNamePrefix := Prefix; RegisterServerStatusResource; end; class procedure TServerStatusResource.RegisterServerStatusResource; -var - URI: string; begin - if FNamePrefix <> '' then - URI := 'server://' + FNamePrefix + 'status' - else - URI := 'server://status'; - - TMCPRegistry.RegisterResource(URI, + TMCPRegistry.RegisterResource(StatusURI, function: IMCPResource begin Result := TServerStatusResource.Create; @@ -128,16 +128,8 @@ class procedure TServerStatusResource.ConnectionClosed; 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; @@ -170,5 +162,6 @@ function TServerStatusResource.GetResourceData: TServerStatus; initialization TServerStatusResource.Initialize; + TServerStatusResource.RegisterServerStatusResource; end. \ No newline at end of file diff --git a/tests/MCPServer.Tests.Golden.Legacy.pas b/tests/MCPServer.Tests.Golden.Legacy.pas index a485455..0783e78 100644 --- a/tests/MCPServer.Tests.Golden.Legacy.pas +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -54,6 +54,7 @@ TLegacyGoldenTests = class [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; @@ -235,6 +236,11 @@ procedure TLegacyGoldenTests.Resources_Read_LogsRecent; 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'); diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index 743a38f..96dfb77 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -13,7 +13,7 @@ TRegistryTests = class public [Test] procedure BuiltInTools_AreRegisteredFromInitialization; [Test] procedure BuiltInResources_AreRegisteredFromInitialization; - [Test] procedure ServerStatus_IsNotRegisteredByDefault; + [Test] procedure ServerStatus_IsRegisteredByDefault; [Test] procedure CreateTool_UnknownName_Raises; [Test] procedure CreateResource_UnknownUri_Raises; [Test] procedure CreateTool_ReturnsFreshInstances; @@ -42,13 +42,16 @@ procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasResource('project://info')); Assert.IsTrue(TMCPRegistry.HasResource('project://readme')); Assert.IsTrue(TMCPRegistry.HasResource('logs://recent')); - Assert.AreEqual(3, Integer(Length(TMCPRegistry.GetResourceURIs))); + Assert.IsTrue(TMCPRegistry.HasResource('server://status')); + Assert.AreEqual(4, Integer(Length(TMCPRegistry.GetResourceURIs))); end; -procedure TRegistryTests.ServerStatus_IsNotRegisteredByDefault; +procedure TRegistryTests.ServerStatus_IsRegisteredByDefault; begin - // Documented in tests\golden\README.md: only SetNamePrefix registers it. - Assert.IsFalse(TMCPRegistry.HasResource('server://status')); + // Registered by the initialization section of MCPServer.Resource.Server. + var Status := TMCPRegistry.CreateResource('server://status'); + Assert.AreEqual('server://status', Status.URI); + Assert.AreEqual('server_status', Status.Name); end; procedure TRegistryTests.CreateTool_UnknownName_Raises; diff --git a/tests/golden/README.md b/tests/golden/README.md index 4826b19..e7f82f6 100644 --- a/tests/golden/README.md +++ b/tests/golden/README.md @@ -62,17 +62,17 @@ formatted `expected` value, so key order and array order matter. ## Notes on the recorded behaviour -- `server://status` is declared in `MCPServer.Resource.Server.pas` but the - executable never registers it (`SetNamePrefix` is the only caller of - `RegisterServerStatusResource`), so `resources/list` returns three resources. -- `resources/read` without `params` dereferences nil and answers `-32603` with - an access-violation message; the message is masked. `tools/call` without - `arguments` fails the same way inside the tool and comes back as an `isError` - text result; that text is masked too. -- `logs://recent` answers "Error reading resource: Invalid pointer operation": - `TLogsRecentResource.GetResourceData` puts the copied entries into a second - owning list, so they are freed twice. The golden pins this current behaviour - until the resource is fixed in a later phase. +- Six cases were re-recorded after defects found during the first recording + were fixed in the same branch (see CHANGELOG): `resources-list` and + `resources-read-server-status` (`server://status` was never registered by + the executable), `resources-read-logs-recent` (the entries were freed twice + and the read failed), `resources-read-project-info` and again + `resources-read-logs-recent` (lists were serialised as an object with + `count` and `capacity`), `resources-read-without-params` and + `tools-call-missing-arguments` (nil dereferences). Every other legacy case + is byte-identical to the 2025-06-18 code. +- `server://status` and `logs://recent` contain timestamps, counters and log + text, so their `text` field is compared by shape. - `tools/call` with `id: null` is treated as a notification and gets no response. - HTTP responses are normalised: `Date` and `Server` headers are dropped, GUIDs diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt index 39074a8..7b2cbb7 100644 --- a/tests/golden/http/post-initialize-sse.txt +++ b/tests/golden/http/post-initialize-sse.txt @@ -14,5 +14,3 @@ X-Accel-Buffering: no id: event: message data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"supportsProgress":false,"supportsCancellation":false},"resources":{"subscribe":false,"listChanged":false}},"sessionId":"","serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} - - diff --git a/tests/golden/http/post-resources-list.txt b/tests/golden/http/post-resources-list.txt index edde8b4..130f0cc 100644 --- a/tests/golden/http/post-resources-list.txt +++ b/tests/golden/http/post-resources-list.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 451 +Content-Length: 591 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, GET, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id @@ -9,4 +9,4 @@ Access-Control-Expose-Headers: Mcp-Session-Id Access-Control-Max-Age: 86400 Connection: keep-alive -{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"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"}]}} +{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"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":"server://status","name":"server_status","description":"Current server status and health information","mimeType":"application/json"}]}} diff --git a/tests/golden/http/post-resources-read-project-info.txt b/tests/golden/http/post-resources-read-project-info.txt index 7ab9ced..4bb1090 100644 --- a/tests/golden/http/post-resources-read-project-info.txt +++ b/tests/golden/http/post-resources-read-project-info.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 547 +Content-Length: 590 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, GET, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id @@ -9,4 +9,4 @@ Access-Control-Expose-Headers: Mcp-Session-Id Access-Control-Max-Age: 86400 Connection: keep-alive -{"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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":{\"capacity\":4,\"count\":4,\"isempty\":false}}"}]}} +{"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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}"}]}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index d158d81..11ec540 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -14,5 +14,3 @@ X-Accel-Buffering: no id: event: message data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} - - diff --git a/tests/golden/legacy/resources-list.json b/tests/golden/legacy/resources-list.json index 4d5c546..50a91f4 100644 --- a/tests/golden/legacy/resources-list.json +++ b/tests/golden/legacy/resources-list.json @@ -26,6 +26,12 @@ "name": "Project Information", "description": "Basic information about the Delphi MCP Server project", "mimeType": "application/json" + }, + { + "uri": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" } ] } diff --git a/tests/golden/legacy/resources-read-logs-recent.json b/tests/golden/legacy/resources-read-logs-recent.json index 973dd4d..0553deb 100644 --- a/tests/golden/legacy/resources-read-logs-recent.json +++ b/tests/golden/legacy/resources-read-logs-recent.json @@ -7,6 +7,9 @@ "uri": "logs://recent" } }, + "shape": [ + "result.contents[0].text" + ], "expected": { "jsonrpc": "2.0", "id": 16, @@ -15,7 +18,54 @@ { "uri": "logs://recent", "mimeType": "application/json", - "text": "Error reading resource: Invalid pointer operation" + "text": { + "entries": [ + { + "timestamp": "number", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "number", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "number", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "number", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "number", + "level": "string", + "message": "string", + "threadid": "number", + "category": "string" + }, + { + "timestamp": "number", + "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 index 4bfcdb5..22d122d 100644 --- a/tests/golden/legacy/resources-read-project-info.json +++ b/tests/golden/legacy/resources-read-project-info.json @@ -15,7 +15,7 @@ { "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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":{\"capacity\":4,\"count\":4,\"isempty\":false}}" + "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 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-server-status.json b/tests/golden/legacy/resources-read-server-status.json new file mode 100644 index 0000000..4dde8a1 --- /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": "number", + "currenttime": "number", + "memoryused": "number", + "requestcount": "number", + "activeconnections": "number" + } + } + ] + } + } +} diff --git a/tests/golden/legacy/resources-read-without-params.json b/tests/golden/legacy/resources-read-without-params.json index 9139997..c5f9daf 100644 --- a/tests/golden/legacy/resources-read-without-params.json +++ b/tests/golden/legacy/resources-read-without-params.json @@ -4,15 +4,17 @@ "id": 18, "method": "resources/read" }, - "mask": [ - "error.message" - ], "expected": { "jsonrpc": "2.0", "id": 18, - "error": { - "code": -32603, - "message": "" + "result": { + "contents": [ + { + "uri": "", + "mimeType": "text/plain", + "text": "Error: Resource not found: " + } + ] } } } diff --git a/tests/golden/legacy/tools-call-missing-arguments.json b/tests/golden/legacy/tools-call-missing-arguments.json index 7794573..afeca94 100644 --- a/tests/golden/legacy/tools-call-missing-arguments.json +++ b/tests/golden/legacy/tools-call-missing-arguments.json @@ -7,9 +7,6 @@ "name": "echo" } }, - "mask": [ - "result.content[0].text" - ], "expected": { "jsonrpc": "2.0", "id": 8, @@ -17,10 +14,9 @@ "content": [ { "type": "text", - "text": "" + "text": "Echo: " } - ], - "isError": true + ] } } } From ba11f666b970d7588c2814599bcd3566c00d70dc Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 13:18:55 +0200 Subject: [PATCH 08/56] chore: tidy .gitignore --- .gitignore | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/.gitignore b/.gitignore index 65f6541..bb9bcf7 100644 --- a/.gitignore +++ b/.gitignore @@ -91,14 +91,10 @@ backup/ *.temp ~$* -# Claude Code specific - # Dependencies +node_modules/ +package-lock.json # Test and conformance output tests/results/ results/ - -# Node tooling for conformance and Inspector runs -node_modules/ -package-lock.json From 60a0db334597e2b9ae7aae5577a33c55f384d57e Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 13:26:07 +0200 Subject: [PATCH 09/56] docs: describe the tests and constants without roadmap references The golden README, the fixture comment, the CHANGELOG and the baseline comments describe what the files are, not when they were made or what comes next. The Inspector smoke script takes the entries that must fail as a parameter instead of assuming a fixed set. --- CHANGELOG.md | 7 ++- README.md | 4 +- conformance-baseline-2025-11-25.yml | 2 +- conformance-baseline-2026-07-28.yml | 2 +- scripts/run-inspector-smoke.ps1 | 25 +++++------ src/Protocol/MCPServer.JsonRpcProcessor.pas | 2 +- src/Protocol/MCPServer.Types.pas | 4 +- tests/MCPServer.Tests.Constants.pas | 2 +- tests/MCPServer.Tests.Golden.Legacy.pas | 4 +- tests/golden/README.md | 50 ++++++++------------- 10 files changed, 44 insertions(+), 58 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 664592c..369e946 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,17 +5,16 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ## [Unreleased] -Safety net for the MCP 2026-07-28 work: the legacy wire behaviour is pinned -before any protocol change lands. No client-visible protocol change. +Test harness, golden files and hygiene. No client-visible protocol change. ### Added - DUnitX test project `tests\MCPServer.Tests.dpr` (Win32 and Win64) with an in-process harness that builds the same registry as `MCPServer.dpr` and drives `TMCPJsonRpcProcessor.ProcessRequest`. -- Golden files that pin today's responses: 37 JSON-RPC cases in +- Golden files that pin the wire behaviour: 38 JSON-RPC cases in `tests\golden\legacy` and 26 HTTP transport cases (status line, headers, - body) in `tests\golden\http`, recorded from the unchanged 2025-06-18 code. + body) in `tests\golden\http`. - `build-tests.bat` and `scripts\run-tests.ps1` (build and run, `-Record` to re-record goldens), `scripts\capture-http-goldens.ps1`. - `scripts\run-conformance.ps1` for the official conformance CLI with one diff --git a/README.md b/README.md index 558794a..714e12a 100644 --- a/README.md +++ b/README.md @@ -579,10 +579,10 @@ The `tests` folder holds a DUnitX project that drives the JSON-RPC layer in-proc .\scripts\capture-http-goldens.ps1 # replay the HTTP golden cases with curl against Win64\Debug\MCPServer.exe .\scripts\run-stdio-smoke.ps1 # drive --stdio and check the framing of stdout/stderr .\scripts\run-conformance.ps1 # official conformance CLI, 2026-07-28 and 2025-11-25 requirement sets -.\scripts\run-inspector-smoke.ps1 # Inspector CLI tools/list in the legacy, auto and modern eras and over stdio +.\scripts\run-inspector-smoke.ps1 -ExpectedFailures delphi-modern # Inspector CLI tools/list per protocol era and over stdio ``` -Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. `build-tests.bat [Config] [Platform]` compiles the test project on its own. +Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. The Inspector smoke run takes the entries that must fail as a parameter (`delphi-modern` as long as the server has no `server/discover`). `build-tests.bat [Config] [Platform]` compiles the test project on its own. ## About GDK Software diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml index 9d7034e..39134ce 100644 --- a/conformance-baseline-2025-11-25.yml +++ b/conformance-baseline-2025-11-25.yml @@ -1,6 +1,6 @@ # Known conformance failures for --requirements 2025-11-25 # Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). -# Regenerate after each phase with scripts/run-conformance.ps1 -NoBaseline and prune what passes. +# Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. server: - logging-set-level - completion-complete diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index 5c21729..42a87ce 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -1,6 +1,6 @@ # Known conformance failures for --requirements 2026-07-28 # Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). -# Regenerate after each phase with scripts/run-conformance.ps1 -NoBaseline and prune what passes. +# Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. server: - server-stateless - completion-complete diff --git a/scripts/run-inspector-smoke.ps1 b/scripts/run-inspector-smoke.ps1 index 66317bb..3ac8f63 100644 --- a/scripts/run-inspector-smoke.ps1 +++ b/scripts/run-inspector-smoke.ps1 @@ -9,10 +9,9 @@ delphi-stdio over a spawned process. The pinned Inspector version comes from package.json. - Until the 2026-07-28 work lands, the modern entry is expected to fail; - pass -ExpectModern once it must succeed. The script exits non-zero when - an entry that is expected to work fails, or when the modern entry - unexpectedly passes or fails. + Every entry is expected to list the tools. Entries named in + -ExpectedFailures are expected to fail instead; the script exits non-zero + when an entry does not behave as expected in either direction. .PARAMETER Configuration Release (default) or Debug. The stdio entry in ci-servers.json points at @@ -24,11 +23,13 @@ .PARAMETER NoBuild Use the existing executable. -.PARAMETER ExpectModern - Treat a failing modern entry as an error. +.PARAMETER ExpectedFailures + Entry names that must fail (for example delphi-modern while the server + does not implement server/discover). .EXAMPLE .\scripts\run-inspector-smoke.ps1 + .\scripts\run-inspector-smoke.ps1 -ExpectedFailures delphi-modern #> [CmdletBinding()] param( @@ -40,7 +41,7 @@ param( [switch]$NoBuild, - [switch]$ExpectModern + [string[]]$ExpectedFailures = @() ) $ErrorActionPreference = 'Stop' @@ -60,12 +61,10 @@ Assert-NodeTooling New-Item -ItemType Directory -Force -Path $resultsDir | Out-Null $server = Start-McpServer -ServerExe $serverExe -Port $port -LogDir $resultsDir -$entries = @( - @{ Name = 'delphi-legacy'; ExpectSuccess = $true } - @{ Name = 'delphi-auto'; ExpectSuccess = $true } - @{ Name = 'delphi-modern'; ExpectSuccess = [bool]$ExpectModern } - @{ Name = 'delphi-stdio'; ExpectSuccess = $true } -) +$entries = @() +foreach ($name in 'delphi-legacy', 'delphi-auto', 'delphi-modern', 'delphi-stdio') { + $entries += @{ Name = $name; ExpectSuccess = ($ExpectedFailures -notcontains $name) } +} $rows = @() try { diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 46bd86a..1e8ae86 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -27,7 +27,7 @@ TMCPJsonRpcProcessor = class const // The JSON-RPC error codes are defined in MCPServer.Types. These aliases // keep consumer code that references MCPServer.JsonRpcProcessor.JSONRPC_* - // compiling for one release. + // compiling. 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; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index e78dccb..b8a2606 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -8,8 +8,8 @@ interface System.Rtti; const - /// Protocol version answered by the legacy initialize handshake today. - /// Kept under its historic name for library consumers. + /// Protocol version answered by the initialize handshake. Kept under its + /// historic name for library consumers. MCP_PROTOCOL_VERSION = '2025-06-18'; // Protocol revisions diff --git a/tests/MCPServer.Tests.Constants.pas b/tests/MCPServer.Tests.Constants.pas index da773a9..57d71f4 100644 --- a/tests/MCPServer.Tests.Constants.pas +++ b/tests/MCPServer.Tests.Constants.pas @@ -56,7 +56,7 @@ procedure TProtocolConstantsTests.McpErrorCodes_HaveSpecValues; procedure TProtocolConstantsTests.ProtocolVersions_AreConsistent; begin - Assert.AreEqual('2025-06-18', MCP_PROTOCOL_VERSION, 'legacy default must not change without the allow-list'); + 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); diff --git a/tests/MCPServer.Tests.Golden.Legacy.pas b/tests/MCPServer.Tests.Golden.Legacy.pas index 0783e78..8eb8865 100644 --- a/tests/MCPServer.Tests.Golden.Legacy.pas +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -12,8 +12,8 @@ interface /// /// Every test replays one file from tests\golden\legacy through a fresh /// harness and compares the normalised response with the recorded one. - /// The only differences allowed after the recording are the items in the - /// allow-list of docs\mcp-2026-07-28-implementation-plan.md, section 4.3. + /// A golden file only changes when the wire behaviour changes on purpose; + /// such a change belongs in the CHANGELOG. [TestFixture] TLegacyGoldenTests = class private diff --git a/tests/golden/README.md b/tests/golden/README.md index e7f82f6..ae1ce66 100644 --- a/tests/golden/README.md +++ b/tests/golden/README.md @@ -1,21 +1,16 @@ # Golden files -The golden files pin the wire behaviour of the server so that every later change -can prove "no regression for existing clients". They were recorded from the -unchanged 2025-06-18 code before the MCP 2026-07-28 work started. After that -recording the only differences allowed on the legacy wire are the items in the -allow-list of `docs/mcp-2026-07-28-implementation-plan.md`, section 4.3. Anything -else that changes a golden file is a bug. +The golden files pin the wire behaviour of the server. A change in a golden +file is a deliberate change of what clients receive and belongs in the +CHANGELOG; an unintended change is a regression. ## Layout | Directory | Layer | Recorded by | Verified by | |---|---|---|---| -| `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr` | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TLegacyGoldenTests`) | +| `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr`, initialize-based protocol revisions | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TLegacyGoldenTests`) | | `http/` | Streamable HTTP transport (`TMCPIdHTTPServer`) of the built executable, captured with curl | `scripts\capture-http-goldens.ps1 -Record` | `scripts\capture-http-goldens.ps1` | -Later phases add `modern/` for 2026-07-28 requests. - ## Legacy case files One JSON file per case in `legacy/`: @@ -33,10 +28,11 @@ One JSON file per case in `legacy/`: - `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, exception text with addresses). + (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` are compared structurally. + 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 @@ -49,31 +45,23 @@ formatted `expected` value, so key order and array order matter. ## Recording procedure -1. Check out the commit whose behaviour must be pinned. -2. `build.bat Debug Win64` and `build-tests.bat Debug Win64`. -3. `.\scripts\run-tests.ps1 -Record -NoBuild` rewrites the `expected` sections - in `legacy/`. -4. `.\scripts\capture-http-goldens.ps1 -Record` starts `Win64\Debug\MCPServer.exe` +1. `build.bat Debug Win64` and `build-tests.bat Debug Win64`. +2. `.\scripts\run-tests.ps1 -Record -NoBuild` rewrites the `expected` sections + in `legacy/`. Use `-Filter` with the fully qualified test names to + re-record single cases. +3. `.\scripts\capture-http-goldens.ps1 -Record` starts `Win64\Debug\MCPServer.exe` on port 3939 and writes `http/*.txt`. -5. Review the diff. Only the intended cases may change, and only within the - allow-list. -6. `.\scripts\run-tests.ps1` and `.\scripts\capture-http-goldens.ps1` must be +4. Review the diff: only the cases whose behaviour changed on purpose may + differ. +5. `.\scripts\run-tests.ps1` and `.\scripts\capture-http-goldens.ps1` must be green before committing. ## Notes on the recorded behaviour -- Six cases were re-recorded after defects found during the first recording - were fixed in the same branch (see CHANGELOG): `resources-list` and - `resources-read-server-status` (`server://status` was never registered by - the executable), `resources-read-logs-recent` (the entries were freed twice - and the read failed), `resources-read-project-info` and again - `resources-read-logs-recent` (lists were serialised as an object with - `count` and `capacity`), `resources-read-without-params` and - `tools-call-missing-arguments` (nil dereferences). Every other legacy case - is byte-identical to the 2025-06-18 code. -- `server://status` and `logs://recent` contain timestamps, counters and log +- `logs://recent` and `server://status` contain timestamps, counters and log text, so their `text` field is compared by shape. -- `tools/call` with `id: null` is treated as a notification and gets no +- A request with `id: null` is treated as a notification and gets no response. - HTTP responses are normalised: `Date` and `Server` headers are dropped, GUIDs - become ``, SSE `id:` lines become `id: `, line endings are LF. + become ``, SSE `id:` lines become `id: `, line endings are LF and + trailing newlines are trimmed. From d6b20c08285aacad468bfbe9ca76fc2a421fa6b0 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:05:29 +0200 Subject: [PATCH 10/56] feat: dual-era JSON-RPC core with server/discover and per-request _meta The processor decides the protocol era per request in BuildRequestContext: initialize is always legacy, a params._meta with io.modelcontextprotocol/protocolVersion is modern, everything else is legacy (negotiated stdio revision, MCP-Protocol-Version header, or 2025-11-25). Modern requests get their _meta validated (-32602), unknown revisions -32022 with the supported list, header/body disagreement -32020, and the legacy-only methods -32601. Modern results carry resultType, _meta.serverInfo and, for the cacheable methods, ttlMs and cacheScope. The HTTP status for each outcome is computed here; the transport still answers 200 for everything. - MCPServer.Errors: EMCPError with code, data, HTTP status and factories - MCPServer.RequestContext: IMCPRequestContext implementation, thread-local Current, TMCPTransportHints - MCPServer.Capabilities: capabilities derived from the registered managers - MCPServer.CoreManager: server/discover; initialize negotiates the revision, drops sessionId and the non-schema capability keys; no session state - MCPServer.Types: era, request id, session slot, new interfaces, version helpers; managers expose IMCPCapabilityProvider; the registry enumerates its managers and injects itself into IMCPRegistryAware managers - Settings: Title, Description, WebsiteUrl, Instructions, LenientModernPing, DiscoverListsLegacyVersions, DiscoverTtlMs - Transports pass hints (header, stdio session) and use ProcessRequestEx; the HTTP server no longer scrapes sessionId from the body --- settings.ini.example | 16 + src/Core/MCPServer.ManagerRegistry.pas | 24 +- src/Core/MCPServer.Settings.pas | 64 +- src/MCPServer.dpr | 4 + src/MCPServer.dproj | 3 + src/Managers/MCPServer.CoreManager.pas | 231 ++++--- src/Managers/MCPServer.ResourcesManager.pas | 17 +- src/Managers/MCPServer.ToolsManager.pas | 12 +- src/Protocol/MCPServer.Capabilities.pas | 62 ++ src/Protocol/MCPServer.Errors.pas | 131 ++++ src/Protocol/MCPServer.JsonRpcProcessor.pas | 640 ++++++++++++++++---- src/Protocol/MCPServer.RequestContext.pas | 262 ++++++++ src/Protocol/MCPServer.Types.pas | 211 ++++++- src/Server/MCPServer.IdHTTPServer.pas | 39 +- src/Server/MCPServer.StdioTransport.pas | 22 +- 15 files changed, 1495 insertions(+), 243 deletions(-) create mode 100644 src/Protocol/MCPServer.Capabilities.pas create mode 100644 src/Protocol/MCPServer.Errors.pas create mode 100644 src/Protocol/MCPServer.RequestContext.pas diff --git a/settings.ini.example b/settings.ini.example index ea0587f..06d6240 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -8,6 +8,22 @@ 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= + +[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 diff --git a/src/Core/MCPServer.ManagerRegistry.pas b/src/Core/MCPServer.ManagerRegistry.pas index e1f90c3..ba46585 100644 --- a/src/Core/MCPServer.ManagerRegistry.pas +++ b/src/Core/MCPServer.ManagerRegistry.pas @@ -8,15 +8,18 @@ interface MCPServer.Types; type - TMCPManagerRegistry = class(TInterfacedObject, IMCPManagerRegistry) + /// Registration-ordered list of capability managers. Managers that + /// implement IMCPRegistryAware receive a reference to this registry. + 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 +40,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 +66,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.Settings.pas b/src/Core/MCPServer.Settings.pas index acb9cbe..ca0b77b 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -22,8 +22,15 @@ TMCPSettings = class FSSLCertFile: string; FSSLKeyFile: string; FSSLRootCertFile: string; + FServerTitle: string; + FServerDescription: string; + FServerWebsiteUrl: string; + FInstructions: string; + FLenientModernPing: Boolean; + FDiscoverListsLegacyVersions: Boolean; + FDiscoverTtlMs: Integer; function GetProtocol: string; - + procedure LoadDefaults; procedure CreateDefaultSettingsFile; public @@ -46,6 +53,22 @@ TMCPSettings = class property SSLCertFile: string read FSSLCertFile write FSSLCertFile; property SSLKeyFile: string read FSSLKeyFile write FSSLKeyFile; property SSLRootCertFile: string read FSSLRootCertFile write FSSLRootCertFile; + + // Optional server identity ([Server] Title, Description, WebsiteUrl, + // Instructions); reported in initialize and server/discover when set. + 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; + + /// [Protocol] LenientModernPing: answer ping for 2026-07-28 requests + /// although the revision removed it. Default off. + property LenientModernPing: Boolean read FLenientModernPing write FLenientModernPing; + /// [Protocol] DiscoverListsLegacyVersions: also list the initialize-based + /// revisions in server/discover and in unsupported-version errors. Default off. + property DiscoverListsLegacyVersions: Boolean read FDiscoverListsLegacyVersions write FDiscoverListsLegacyVersions; + /// [Protocol] DiscoverTtlMs: cache hint on server/discover. Default 0. + property DiscoverTtlMs: Integer read FDiscoverTtlMs write FDiscoverTtlMs; end; implementation @@ -93,6 +116,13 @@ procedure TMCPSettings.LoadDefaults; FSSLCertFile := ''; FSSLKeyFile := ''; FSSLRootCertFile := ''; + FServerTitle := ''; + FServerDescription := ''; + FServerWebsiteUrl := ''; + FInstructions := ''; + FLenientModernPing := False; + FDiscoverListsLegacyVersions := False; + FDiscoverTtlMs := 0; end; function TMCPSettings.GetProtocol: string; @@ -115,7 +145,17 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Server', 'Name', FServerName); IniFile.WriteString('Server', 'Version', FServerVersion); IniFile.WriteString('Server', 'Endpoint', FEndpoint); - + IniFile.WriteString('Server', '; Optional identity reported to clients', ''); + IniFile.WriteString('Server', 'Title', FServerTitle); + IniFile.WriteString('Server', 'Description', FServerDescription); + IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString('Server', 'Instructions', FInstructions); + + IniFile.WriteString('Protocol', '; Protocol options (1 = on, 0 = off)', ''); + IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + IniFile.WriteString('CORS', '; Cross-Origin Resource Sharing configuration', ''); IniFile.WriteBool('CORS', 'Enabled', FCorsEnabled); IniFile.WriteString('CORS', '; Comma-separated list of allowed origins', ''); @@ -145,7 +185,15 @@ procedure TMCPSettings.LoadFromFile; FServerName := IniFile.ReadString('Server', 'Name', FServerName); FServerVersion := IniFile.ReadString('Server', 'Version', FServerVersion); FEndpoint := IniFile.ReadString('Server', 'Endpoint', FEndpoint); - + FServerTitle := IniFile.ReadString('Server', 'Title', FServerTitle); + FServerDescription := IniFile.ReadString('Server', 'Description', FServerDescription); + FServerWebsiteUrl := IniFile.ReadString('Server', 'WebsiteUrl', FServerWebsiteUrl); + FInstructions := IniFile.ReadString('Server', 'Instructions', FInstructions); + + FLenientModernPing := IniFile.ReadBool('Protocol', 'LenientModernPing', FLenientModernPing); + FDiscoverListsLegacyVersions := IniFile.ReadBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + FDiscoverTtlMs := IniFile.ReadInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + FCorsEnabled := IniFile.ReadBool('CORS', 'Enabled', FCorsEnabled); FCorsAllowedOrigins := IniFile.ReadString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); @@ -181,7 +229,15 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteString('Server', 'Name', FServerName); IniFile.WriteString('Server', 'Version', FServerVersion); IniFile.WriteString('Server', 'Endpoint', FEndpoint); - + IniFile.WriteString('Server', 'Title', FServerTitle); + IniFile.WriteString('Server', 'Description', FServerDescription); + IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); + IniFile.WriteString('Server', 'Instructions', FInstructions); + + IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); + IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); + IniFile.WriteInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); + IniFile.WriteBool('CORS', 'Enabled', FCorsEnabled); IniFile.WriteString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 24ddf5b..14ada1b 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -12,6 +12,9 @@ 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.Serializer in 'Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in 'Protocol\MCPServer.Schema.Generator.pas', MCPServer.Logger in 'Core\MCPServer.Logger.pas', @@ -133,6 +136,7 @@ begin StdioTransport := TMCPStdioTransport.Create(ManagerRegistry, CoreManager); try + StdioTransport.Settings := Settings; StdioTransport.Run; finally StdioTransport.Free; diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index ed82f9e..8a906d3 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -129,6 +129,9 @@ MainSource + + + diff --git a/src/Managers/MCPServer.CoreManager.pas b/src/Managers/MCPServer.CoreManager.pas index f73f761..3265c1e 100644 --- a/src/Managers/MCPServer.CoreManager.pas +++ b/src/Managers/MCPServer.CoreManager.pas @@ -6,38 +6,57 @@ interface System.SysUtils, System.JSON, System.Rtti, - System.DateUtils, MCPServer.Types, MCPServer.Settings, MCPServer.Logger; type - TMCPCoreManager = class(TInterfacedObject, IMCPCapabilityManager) + /// Lifecycle methods: server/discover for modern clients, initialize and + /// ping for legacy clients. Holds no per-client state. + 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; + + /// Sessions are no longer minted; always empty. Kept for consumers. + property SessionID: string read GetSessionID; + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; end; implementation +uses + MCPServer.Capabilities, + MCPServer.RequestContext; + +const + CACHE_SCOPE_PUBLIC = 'public'; + { TMCPCoreManager } constructor TMCPCoreManager.Create(ASettings: TMCPSettings); begin inherited Create; FSettings := ASettings; - FSessionID := ''; end; function TMCPCoreManager.GetCapabilityName: string; @@ -45,17 +64,34 @@ function TMCPCoreManager.GetCapabilityName: string; Result := 'core'; end; +function TMCPCoreManager.GetSessionID: string; +begin + Result := ''; +end; + +procedure TMCPCoreManager.SetManagerRegistry(const Registry: IMCPManagerRegistry); +begin + FManagerRegistry := Registry; +end; + function TMCPCoreManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'initialize') or + Result := (Method = 'initialize') or (Method = 'notifications/initialized') or - (Method = 'ping'); + (Method = 'ping') or + (Method = 'server/discover'); end; function TMCPCoreManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPCoreManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'initialize' then - Result := Initialize(Params) + Result := Initialize(Params, Context) else if Method = 'notifications/initialized' then begin TLogger.Info('MCP Initialized notification received'); @@ -63,75 +99,101 @@ function TMCPCoreManager.ExecuteMethod(const Method: string; const Params: TJSON end else if Method = 'ping' then Result := Ping + else if Method = 'server/discover' then + Result := Discover(Context) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; -function TMCPCoreManager.Initialize(const Params: TJSONObject): TValue; +function TMCPCoreManager.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('name', FSettings.ServerName); + Result.AddPair('version', FSettings.ServerVersion); + if FSettings.ServerTitle <> '' then + Result.AddPair('title', FSettings.ServerTitle); + if FSettings.ServerDescription <> '' then + Result.AddPair('description', FSettings.ServerDescription); + if FSettings.ServerWebsiteUrl <> '' then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPCoreManager.BuildCapabilities(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TMCPCapabilityBuilder.Build(FManagerRegistry, Era); +end; + +function TMCPCoreManager.SupportedVersions: TJSONArray; +begin + Result := TJSONArray.Create; + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Result.Add(Version); + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Result.Add(Version); +end; + +procedure TMCPCoreManager.LogClientInfo(const ClientInfo: TJSONValue); +begin + if not (ClientInfo is TJSONObject) then + Exit; + + var ClientName := TJSONObject(ClientInfo).GetValue('name'); + var ClientVersion := TJSONObject(ClientInfo).GetValue('version'); + if Assigned(ClientName) and Assigned(ClientVersion) then + TLogger.Info(Format('Client: %s v%s', [ClientName.Value, ClientVersion.Value])); +end; + +procedure TMCPCoreManager.WarnAboutDeprecatedClientCapabilities(const Capabilities: TJSONValue); +begin + if not (Capabilities is TJSONObject) then + Exit; + + for var Deprecated in ['roots', 'sampling'] do + if Assigned(TJSONObject(Capabilities).GetValue(Deprecated)) then + TLogger.Warning(Format('Client declares the %s capability; this server does not use it (deprecated in MCP 2026-07-28)', [Deprecated])); +end; + +function TMCPCoreManager.Initialize(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; var - Capabilities: TJSONObject; - ClientInfo: TJSONObject; - ClientName: TJSONValue; - ClientVersion: TJSONValue; - ResourcesCap: TJSONObject; - ResultJSON: TJSONObject; - ServerInfo: TJSONObject; - ToolsCap: TJSONObject; + Negotiated: string; begin TLogger.Info('MCP Initialize called'); - - if Assigned(Params) then - begin - ClientInfo := Params.GetValue('clientInfo') as TJSONObject; - if Assigned(ClientInfo) then + if Assigned(Context) then + Negotiated := Context.ProtocolVersion + else + begin + // Called outside the processor: negotiate from the params directly. + var Requested := ''; + if Assigned(Params) then begin - ClientName := ClientInfo.GetValue('name'); - ClientVersion := ClientInfo.GetValue('version'); - - if Assigned(ClientName) and Assigned(ClientVersion) then - TLogger.Info(Format('Client: %s v%s', [ClientName.Value, ClientVersion.Value])); + var RequestedValue := Params.GetValue('protocolVersion'); + if RequestedValue is TJSONString then + Requested := TJSONString(RequestedValue).Value; end; + Negotiated := NegotiateLegacyProtocolVersion(Requested); end; - - FSessionID := TGuid.NewGuid.ToString; - - ResultJSON := TJSONObject.Create; + + if Assigned(Params) then + begin + LogClientInfo(Params.GetValue('clientInfo')); + WarnAboutDeprecatedClientCapabilities(Params.GetValue('capabilities')); + end; + + var ResultJSON := TJSONObject.Create; try - ResultJSON.AddPair('protocolVersion', MCP_PROTOCOL_VERSION); - - Capabilities := TJSONObject.Create; - ResultJSON.AddPair('capabilities', Capabilities); - - ToolsCap := TJSONObject.Create; - Capabilities.AddPair('tools', ToolsCap); -{$IF COMPILERVERSION <= 29} - ToolsCap.AddPair('supportsProgress', TJSONFalse.Create); - ToolsCap.AddPair('supportsCancellation', TJSONFalse.Create); -{$ELSE} - ToolsCap.AddPair('supportsProgress', TJSONBool.Create(False)); - ToolsCap.AddPair('supportsCancellation', TJSONBool.Create(False)); -{$ENDIF} - - ResourcesCap := TJSONObject.Create; - Capabilities.AddPair('resources', ResourcesCap); -{$IF COMPILERVERSION <= 29} - ResourcesCap.AddPair('subscribe', TJSONFalse.Create); - ResourcesCap.AddPair('listChanged', TJSONFalse.Create); -{$ELSE} - ResourcesCap.AddPair('subscribe', TJSONBool.Create(False)); - ResourcesCap.AddPair('listChanged', TJSONBool.Create(False)); -{$ENDIF} - - ResultJSON.AddPair('sessionId', FSessionID); - - ServerInfo := TJSONObject.Create; - ResultJSON.AddPair('serverInfo', ServerInfo); - ServerInfo.AddPair('name', FSettings.ServerName); - ServerInfo.AddPair('version', FSettings.ServerVersion); - - TLogger.Info('Created new MCP session: ' + FSessionID); - + ResultJSON.AddPair('protocolVersion', Negotiated); + ResultJSON.AddPair('capabilities', BuildCapabilities(TMCPProtocolEra.Legacy)); + ResultJSON.AddPair('serverInfo', BuildServerInfo); + if FSettings.Instructions <> '' then + ResultJSON.AddPair('instructions', FSettings.Instructions); + + // stdio remembers the negotiated revision for later legacy requests. + 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 +201,25 @@ function TMCPCoreManager.Initialize(const Params: TJSONObject): TValue; end; end; -function TMCPCoreManager.Ping: TValue; -var - ResultJSON: TJSONObject; +function TMCPCoreManager.Discover(const Context: IMCPRequestContext): TValue; begin - TLogger.Info('MCP Ping called'); - - ResultJSON := TJSONObject.Create; + TLogger.Info('MCP Discover called'); + + var ResultJSON := TJSONObject.Create; try + ResultJSON.AddPair('resultType', 'complete'); + ResultJSON.AddPair('supportedVersions', SupportedVersions); + ResultJSON.AddPair('capabilities', BuildCapabilities(TMCPProtocolEra.Modern)); + + var Meta := TJSONObject.Create; + ResultJSON.AddPair('_meta', Meta); + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); + + if FSettings.Instructions <> '' then + ResultJSON.AddPair('instructions', FSettings.Instructions); + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FSettings.DiscoverTtlMs)); + ResultJSON.AddPair('cacheScope', CACHE_SCOPE_PUBLIC); + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -154,4 +227,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.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index e0c6de9..25375d9 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -13,7 +13,7 @@ interface MCPServer.Resource.Base; type - TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager) + TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityProvider) private FResources: TDictionary; procedure RegisterResource(const Resource: IMCPResource); @@ -25,7 +25,8 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager) function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; - + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + function ListResources: TValue; function ReadResource(const Params: System.JSON.TJSONObject): TValue; function ListResourceTemplates: TValue; @@ -58,11 +59,19 @@ function TMCPResourcesManager.GetCapabilityName: string; function TMCPResourcesManager.HandlesMethod(const Method: string): Boolean; begin - Result := (Method = 'resources/list') or - (Method = 'resources/read') or + Result := (Method = 'resources/list') or + (Method = 'resources/read') or (Method = 'resources/templates/list'); end; +procedure TMCPResourcesManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Resources := TJSONObject.Create; + Resources.AddPair('subscribe', TJSONBool.Create(False)); + Resources.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('resources', Resources); +end; + function TMCPResourcesManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; begin if Method = 'resources/list' then diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index c4e46aa..21fdc4a 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -13,7 +13,7 @@ interface MCPServer.Tool.Base; type - TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager) + TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, 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; @@ -31,7 +31,8 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager) function GetCapabilityName: string; function HandlesMethod(const Method: string): Boolean; function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; - + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + function ListTools: TValue; function CallTool(const Params: System.JSON.TJSONObject): TValue; end; @@ -66,6 +67,13 @@ function TMCPToolsManager.HandlesMethod(const Method: string): Boolean; Result := (Method = 'tools/list') or (Method = 'tools/call'); end; +procedure TMCPToolsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Tools := TJSONObject.Create; + Tools.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('tools', Tools); +end; + function TMCPToolsManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; begin if Method = 'tools/list' then diff --git a/src/Protocol/MCPServer.Capabilities.pas b/src/Protocol/MCPServer.Capabilities.pas new file mode 100644 index 0000000..1f7ca03 --- /dev/null +++ b/src/Protocol/MCPServer.Capabilities.pas @@ -0,0 +1,62 @@ +unit MCPServer.Capabilities; + +interface + +uses + System.JSON, + MCPServer.Types; + +type + /// Derives the server capabilities from the registered managers. + /// + /// Every manager that implements IMCPCapabilityProvider adds its own entry. + /// A registry that cannot enumerate its managers yields the built-in + /// defaults (tools and resources). The logging capability is never emitted. + TMCPCapabilityBuilder = class + public + class function Build(const Registry: IMCPManagerRegistry; Era: TMCPProtocolEra): TJSONObject; + class procedure AddDefaultCapabilities(const Capabilities: TJSONObject); + end; + +implementation + +uses + System.SysUtils; + +{ TMCPCapabilityBuilder } + +class procedure TMCPCapabilityBuilder.AddDefaultCapabilities(const Capabilities: TJSONObject); +begin + var Tools := TJSONObject.Create; + Tools.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('tools', Tools); + + var Resources := TJSONObject.Create; + Resources.AddPair('subscribe', TJSONBool.Create(False)); + Resources.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('resources', Resources); +end; + +class function TMCPCapabilityBuilder.Build(const Registry: IMCPManagerRegistry; Era: TMCPProtocolEra): TJSONObject; +var + Enumerator: IMCPManagerEnumerator; + Provider: IMCPCapabilityProvider; +begin + Result := TJSONObject.Create; + try + if not Supports(Registry, IMCPManagerEnumerator, Enumerator) then + begin + AddDefaultCapabilities(Result); + Exit; + end; + + for var Manager in Enumerator.GetManagers do + if Supports(Manager, IMCPCapabilityProvider, Provider) then + Provider.DescribeCapabilities(Result, Era); + except + Result.Free; + raise; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas new file mode 100644 index 0000000..17f1317 --- /dev/null +++ b/src/Protocol/MCPServer.Errors.pas @@ -0,0 +1,131 @@ +unit MCPServer.Errors; + +interface + +uses + System.SysUtils, + System.JSON; + +type + /// A JSON-RPC error a handler or the processor wants to send back. + /// + /// Code and Message become the error object; Data (owned, optional) becomes + /// error.data. HttpStatus is the status a modern HTTP response must carry; + /// 0 leaves the decision to the processor's status policy. + 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; + + /// Hands the data object to the caller; the exception no longer owns it. + 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; + /// -32020 (HTTP 400): headers missing or different from the body. + class function HeaderMismatch(const AMessage: string): EMCPError; + /// -32021 (HTTP 400): the client did not declare a capability the request needs. + class function MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; + /// -32022 (HTTP 400): the requested revision is not served. + class function UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; + + property Code: Integer read FCode; + property Data: TJSONValue read FData; + property HttpStatus: Integer read FHttpStatus write FHttpStatus; + end; + +const + HTTP_STATUS_OK = 200; + HTTP_STATUS_ACCEPTED = 202; + HTTP_STATUS_BAD_REQUEST = 400; + HTTP_STATUS_NOT_FOUND = 404; + +implementation + +uses + MCPServer.Types; + +{ EMCPError } + +constructor EMCPError.Create(ACode: Integer; const AMessage: string; AData: TJSONValue; AHttpStatus: Integer); +begin + inherited Create(AMessage); + FCode := ACode; + FData := AData; + FHttpStatus := AHttpStatus; +end; + +destructor EMCPError.Destroy; +begin + FData.Free; + inherited; +end; + +function EMCPError.DetachData: TJSONValue; +begin + Result := FData; + FData := nil; +end; + +class function EMCPError.ParseError(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_PARSE_ERROR, AMessage); +end; + +class function EMCPError.InvalidRequest(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INVALID_REQUEST, AMessage); +end; + +class function EMCPError.MethodNotFound(const Method: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, + Format('Method [%s] not found. The method does not exist or is not available.', [Method])); +end; + +class function EMCPError.InvalidParams(const AMessage: string; AData: TJSONValue): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, AMessage, AData); +end; + +class function EMCPError.InternalError(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(JSONRPC_INTERNAL_ERROR, AMessage); +end; + +class function EMCPError.HeaderMismatch(const AMessage: string): EMCPError; +begin + Result := EMCPError.Create(MCP_ERROR_HEADER_MISMATCH, AMessage, nil, HTTP_STATUS_BAD_REQUEST); +end; + +class function EMCPError.MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('requiredCapabilities', RequiredCapabilities); + Result := EMCPError.Create(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, + 'Missing required client capability', Data, HTTP_STATUS_BAD_REQUEST); +end; + +class function EMCPError.UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; +begin + var SupportedArray := TJSONArray.Create; + for var Version in Supported do + SupportedArray.Add(Version); + + var Data := TJSONObject.Create; + Data.AddPair('supported', SupportedArray); + Data.AddPair('requested', Requested); + + Result := EMCPError.Create(MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION, + 'Unsupported protocol version', Data, HTTP_STATUS_BAD_REQUEST); +end; + +end. diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 1e8ae86..3392891 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -7,21 +7,70 @@ interface System.JSON, System.Rtti, MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.Errors, MCPServer.Logger; type + /// Outcome of one JSON-RPC message. Body is empty when nothing must be + /// sent back (notifications, client responses). HttpStatus is the status + /// a Streamable HTTP transport should answer with. + TMCPProcessResult = record + Body: string; + HttpStatus: Integer; + Era: TMCPProtocolEra; + IsNotification: Boolean; + end; + + /// Transport-independent JSON-RPC pipeline: parse, validate the message + /// shape, detect the protocol era, dispatch to the owning manager, shape + /// the result for the era and decide the HTTP status. 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; + 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 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); + function ProcessNotification(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): 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; + + /// Plain JSON-RPC layer without transport hints; returns the response body. function ProcessRequest(const RequestBody: string; const SessionID: string): string; + function ProcessRequestEx(const RequestBody: string; const Hints: TMCPTransportHints): TMCPProcessResult; overload; + /// Message is the already parsed body (nil when parsing failed); the + /// caller keeps ownership. + function ProcessRequestEx(const Message: TJSONValue; const Hints: TMCPTransportHints): TMCPProcessResult; overload; + + /// Decides the era of a request and validates the modern _meta fields. + /// Raises EMCPError with the HTTP status a modern transport must use. + function BuildRequestContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; + + property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; + /// Server identity and protocol options. A processor created without + /// settings uses the defaults (settings.ini next to the executable when present). + property Settings: TMCPSettings read FSettings write SetSettings; end; const @@ -36,193 +85,528 @@ TMCPJsonRpcProcessor = class implementation +const + JSONRPC_VERSION = '2.0'; + RESULT_TYPE_COMPLETE = 'complete'; + CACHE_SCOPE_PRIVATE = 'private'; + + /// Methods that only exist in the initialize-based revisions. + LEGACY_ONLY_METHODS: array[0..4] of string = ( + 'ping', 'initialize', 'logging/setLevel', 'resources/subscribe', 'resources/unsubscribe'); + /// Methods that only exist with per-request _meta. + MODERN_ONLY_METHODS: array[0..1] of string = ('server/discover', 'subscriptions/listen'); + LOG_LEVELS: array[0..7] of string = ( + 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); + +function InArray(const Value: string; const Values: array of string): Boolean; +begin + for var Item in Values do + if Item = Value then + Exit(True); + Result := False; +end; + { TMCPJsonRpcProcessor } constructor TMCPJsonRpcProcessor.Create(ManagerRegistry: IMCPManagerRegistry); +begin + Create(ManagerRegistry, nil); +end; + +constructor TMCPJsonRpcProcessor.Create(ManagerRegistry: IMCPManagerRegistry; Settings: TMCPSettings); begin inherited Create; FManagerRegistry := ManagerRegistry; + SetSettings(Settings); end; -class function TMCPJsonRpcProcessor.ParseJSONRequest(const RequestBody: string): TJSONObject; -var - ParsedValue: TJSONValue; +destructor TMCPJsonRpcProcessor.Destroy; +begin + if FOwnsSettings then + FSettings.Free; + inherited; +end; + +procedure TMCPJsonRpcProcessor.SetSettings(const Value: TMCPSettings); begin - ParsedValue := TJSONObject.ParseJSONValue(RequestBody); - if not Assigned(ParsedValue) then - raise Exception.Create('Invalid JSON'); + if FOwnsSettings then + FreeAndNil(FSettings); + FOwnsSettings := False; - if not (ParsedValue is TJSONObject) then + if Assigned(Value) then + FSettings := Value + else begin - ParsedValue.Free; - raise Exception.Create('JSON-RPC request must be an object'); + FSettings := TMCPSettings.Create('', False); + FOwnsSettings := True; end; +end; - Result := ParsedValue as TJSONObject; +function TMCPJsonRpcProcessor.SupportedModernVersions: TArray; +begin + Result := nil; + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Result := Result + [Version]; + if FSettings.DiscoverListsLegacyVersions then + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Result := Result + [Version]; +end; + +function TMCPJsonRpcProcessor.BuildServerInfo: TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('name', FSettings.ServerName); + Result.AddPair('version', FSettings.ServerVersion); + if FSettings.ServerTitle <> '' then + Result.AddPair('title', FSettings.ServerTitle); + if FSettings.ServerDescription <> '' then + Result.AddPair('description', FSettings.ServerDescription); + if FSettings.ServerWebsiteUrl <> '' then + Result.AddPair('websiteUrl', FSettings.ServerWebsiteUrl); +end; + +function TMCPJsonRpcProcessor.IsLegacyOnlyMethod(const Method: string): Boolean; +begin + Result := InArray(Method, LEGACY_ONLY_METHODS); + if Result and (Method = 'ping') and FSettings.LenientModernPing then + Result := False; end; -class function TMCPJsonRpcProcessor.ExtractRequestID(JSONRequest: TJSONObject): TValue; +function TMCPJsonRpcProcessor.IsModernOnlyMethod(const Method: string): Boolean; +begin + Result := InArray(Method, MODERN_ONLY_METHODS); +end; + +function TMCPJsonRpcProcessor.IsCacheableMethod(const Method: string): Boolean; +begin + Result := InArray(Method, MCP_CACHEABLE_METHODS); +end; + +function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; +begin + // Before the body is understood only the header can tell the era apart. + if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader + and IsModernProtocolVersion(Hints.ProtocolVersionHeader) then + Result := TMCPProtocolEra.Modern + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPJsonRpcProcessor.EraFromMessage(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProtocolEra; +begin + // The era that decides the status of a rejected request: a body that + // names a protocol version in _meta is modern even when it fails validation. + Result := EraFromHeaders(Hints); + if (Result = TMCPProtocolEra.Modern) or (Method = 'initialize') or not Assigned(Params) then + Exit; + + var MetaValue := Params.GetValue('_meta'); + if (MetaValue is TJSONObject) and (TJSONObject(MetaValue).GetValue(MCP_META_PROTOCOL_VERSION) is TJSONString) then + Result := TMCPProtocolEra.Modern; +end; + +function TMCPJsonRpcProcessor.ExtractMeta(const Params: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var MetaValue := Params.GetValue('_meta'); + if not Assigned(MetaValue) then + Exit; + if not (MetaValue is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, 'params._meta must be an object', nil, HTTP_STATUS_BAD_REQUEST); + Result := TJSONObject(MetaValue); +end; + +procedure TMCPJsonRpcProcessor.ValidateModernMeta(const Meta: TJSONObject); +begin + var Capabilities := Meta.GetValue(MCP_META_CLIENT_CAPABILITIES); + if not (Capabilities is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_CLIENT_CAPABILITIES + ' is required and must be an object', + nil, HTTP_STATUS_BAD_REQUEST); + + var ClientInfo := Meta.GetValue(MCP_META_CLIENT_INFO); + if Assigned(ClientInfo) and not (ClientInfo is TJSONObject) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_CLIENT_INFO + ' must be an object', nil, HTTP_STATUS_BAD_REQUEST); + + var LogLevel := Meta.GetValue(MCP_META_LOG_LEVEL); + if Assigned(LogLevel) and (not (LogLevel is TJSONString) or not InArray(TJSONString(LogLevel).Value, LOG_LEVELS)) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + 'params._meta.' + MCP_META_LOG_LEVEL + ' must be one of debug, info, notice, warning, error, critical, alert, emergency', + nil, HTTP_STATUS_BAD_REQUEST); +end; + +function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Params: TJSONObject; + const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; var - IdValue: TJSONValue; + Version: string; begin - // JSONRequest is nil when the request body failed to parse; there is no id - // to extract. Without this guard the nil dereference surfaces as - // "Access violation ... Read of address 0000000000000010" for any - // syntactically invalid request. - if not Assigned(JSONRequest) then + var Meta := ExtractMeta(Params); + + // 1. initialize always selects the legacy era, whatever _meta says. + if Method = 'initialize' then begin - Result := TValue.Empty; - Exit; + var Requested := ''; + if Assigned(Params) then + begin + var RequestedValue := Params.GetValue('protocolVersion'); + if RequestedValue is TJSONString then + Requested := TJSONString(RequestedValue).Value; + end; + Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), + Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry)); end; - IdValue := JSONRequest.GetValue('id'); - if not Assigned(IdValue) then + // 2. A protocol version in _meta makes the request modern. + var VersionValue: TJSONValue := nil; + if Assigned(Meta) then + VersionValue := Meta.GetValue(MCP_META_PROTOCOL_VERSION); + + if VersionValue is TJSONString then begin - Result := TValue.Empty; + Version := TJSONString(VersionValue).Value; + + if Hints.HasHeaderLayer then + begin + if not Hints.HasProtocolVersionHeader then + raise EMCPError.HeaderMismatch('MCP-Protocol-Version header is missing'); + if Hints.ProtocolVersionHeader <> Version then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: MCP-Protocol-Version header value ''%s'' does not match body value ''%s''', + [Hints.ProtocolVersionHeader, Version])); + end; + + if not IsModernProtocolVersion(Version) then + raise EMCPError.UnsupportedProtocolVersion(Version, SupportedModernVersions); + + ValidateModernMeta(Meta); + + if IsLegacyOnlyMethod(Method) then + begin + var NotFound := EMCPError.MethodNotFound(Method); + NotFound.HttpStatus := HTTP_STATUS_NOT_FOUND; + raise NotFound; + end; + + Exit(TMCPRequestContext.Create(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, + Hints.LegacySession, FManagerRegistry)); + end; + + // 3. A modern-only method without _meta is a malformed modern request. + if IsModernOnlyMethod(Method) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('%s requires params._meta.%s', [Method, MCP_META_PROTOCOL_VERSION]), nil, HTTP_STATUS_BAD_REQUEST); + + // 4. On HTTP the header alone can still name the revision. + if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader then + begin + var Header := Hints.ProtocolVersionHeader; + if IsModernProtocolVersion(Header) then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, + Format('MCP-Protocol-Version %s requires params._meta.%s', [Header, MCP_META_PROTOCOL_VERSION]), + nil, HTTP_STATUS_BAD_REQUEST); + if not IsLegacyProtocolVersion(Header) and (Header <> MCP_PROTOCOL_VERSION_2025_03_26) then + raise EMCPError.Create(JSONRPC_INVALID_REQUEST, + 'Unsupported MCP-Protocol-Version header: ' + Header, nil, HTTP_STATUS_BAD_REQUEST); + + Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, + Hints.LegacySession, FManagerRegistry)); + end; + + // 5. Legacy, with the version negotiated on this process when known. + Version := ''; + if Assigned(Hints.LegacySession) then + Version := Hints.LegacySession.ProtocolVersion; + if Version = '' then + Version := MCP_LATEST_LEGACY_PROTOCOL_VERSION; + + Result := TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Version, Method, RequestId, Meta, + Hints.LegacySession, FManagerRegistry); +end; + +function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TMCPProcessResult; +begin + Result.Body := ''; + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := EraFromHeaders(Hints); + Result.IsNotification := True; + + TLogger.Info('Notification received: ' + Method); + + 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; - 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; +function TMCPJsonRpcProcessor.DispatchRequest(const Context: IMCPRequestContext; const Params: TJSONObject): TValue; +var + ManagerEx: IMCPCapabilityManagerEx; +begin + if not Assigned(FManagerRegistry) then + raise EMCPError.InternalError('Manager registry not initialized'); + + var Manager := FManagerRegistry.GetManagerForMethod(Context.Method); + if not Assigned(Manager) then + raise EMCPError.MethodNotFound(Context.Method); + + TMCPRequestContext.SetCurrent(Context); + try + if Supports(Manager, IMCPCapabilityManagerEx, ManagerEx) then + Result := ManagerEx.ExecuteMethodWithContext(Context.Method, Params, Context) + else + Result := Manager.ExecuteMethod(Context.Method, Params); + finally + TMCPRequestContext.SetCurrent(nil); + end; end; -class function TMCPJsonRpcProcessor.CreateJSONResponse(const RequestID: TValue): TJSONObject; +procedure TMCPJsonRpcProcessor.ApplyModernEnvelope(const ResultObject: TJSONObject; const Method: string); begin - Result := TJSONObject.Create; - Result.AddPair('jsonrpc', '2.0'); - AddRequestIDToResponse(Result, RequestID); + if not Assigned(ResultObject.GetValue('resultType')) then + ResultObject.AddPair('resultType', RESULT_TYPE_COMPLETE); + + var MetaValue := ResultObject.GetValue('_meta'); + var Meta: TJSONObject := nil; + if MetaValue is TJSONObject then + Meta := TJSONObject(MetaValue) + else if not Assigned(MetaValue) then + begin + Meta := TJSONObject.Create; + ResultObject.AddPair('_meta', Meta); + end; + if Assigned(Meta) and not Assigned(Meta.GetValue(MCP_META_SERVER_INFO)) then + Meta.AddPair(MCP_META_SERVER_INFO, BuildServerInfo); + + var ResultType := ResultObject.GetValue('resultType'); + if IsCacheableMethod(Method) and (ResultType is TJSONString) + and (TJSONString(ResultType).Value = RESULT_TYPE_COMPLETE) then + begin + if not Assigned(ResultObject.GetValue('ttlMs')) then + ResultObject.AddPair('ttlMs', TJSONNumber.Create(0)); + if not Assigned(ResultObject.GetValue('cacheScope')) then + ResultObject.AddPair('cacheScope', CACHE_SCOPE_PRIVATE); + end; end; -class procedure TMCPJsonRpcProcessor.AddRequestIDToResponse(Response: TJSONObject; const RequestID: TValue); +function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: IMCPRequestContext): TJSONValue; begin - if RequestID.IsEmpty then + if Context.Era = TMCPProtocolEra.Legacy then begin - Response.AddPair('id', TJSONNull.Create); + // Byte-for-byte what the initialize-based revisions always received. + if Value.IsEmpty then + Result := nil + else if Value.IsType then + Result := Value.AsType + else if Value.IsType then + Result := TJSONString.Create(Value.AsString) + else + Result := TJSONString.Create(Value.ToString); Exit; end; - 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)) + // Modern results are always objects with a resultType. + var ResultObject: TJSONObject; + if Value.IsType then + ResultObject := Value.AsType else - Response.AddPair('id', TJSONNull.Create); + begin + ResultObject := TJSONObject.Create; + if not Value.IsEmpty then + ResultObject.AddPair('value', Value.ToString); + end; + + ApplyModernEnvelope(ResultObject, Context.Method); + Result := ResultObject; end; -class function TMCPJsonRpcProcessor.ExecuteMethodCall(ManagerRegistry: IMCPManagerRegistry; - const MethodName: string; Params: TJSONObject): TValue; -var - Manager: IMCPCapabilityManager; +function TMCPJsonRpcProcessor.StatusForError(Era: TMCPProtocolEra; const Error: EMCPError): Integer; +begin + // Legacy clients read 404 as "session terminated"; they always get 200. + if Era = TMCPProtocolEra.Legacy then + Exit(HTTP_STATUS_OK); + + 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 - if not Assigned(ManagerRegistry) then - raise Exception.Create('Manager registry not initialized'); + TLogger.Error('Error processing request: ' + Error.Message); - Manager := ManagerRegistry.GetManagerForMethod(MethodName); - if not Assigned(Manager) then - raise Exception.CreateFmt('Method [%s] not found. The method does not exist or is not available.', [MethodName]); + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', RequestId.ToJson); + + var ErrorObject := TJSONObject.Create; + Response.AddPair('error', ErrorObject); + ErrorObject.AddPair('code', TJSONNumber.Create(Error.Code)); + ErrorObject.AddPair('message', Error.Message); + if Assigned(Error.Data) then + ErrorObject.AddPair('data', Error.DetachData); + + Result.Body := Response.ToJSON; + finally + Response.Free; + end; - Result := Manager.ExecuteMethod(MethodName, Params); + Result.HttpStatus := StatusForError(Era, Error); + Result.Era := Era; + Result.IsNotification := False; end; -class function TMCPJsonRpcProcessor.CreateErrorResponse(const RequestID: TValue; - ErrorCode: Integer; const ErrorMessage: string): string; -var - ErrorObj: TJSONObject; - JSONResponse: TJSONObject; +function TMCPJsonRpcProcessor.ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; +begin + // The text heuristic predates typed errors; legacy answers keep it. + if (Era = TMCPProtocolEra.Legacy) and (Pos('not found', E.Message) > 0) then + Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, E.Message) + else + Result := EMCPError.InternalError(E.Message); +end; + +function TMCPJsonRpcProcessor.ProcessRequest(const RequestBody: string; const SessionID: string): string; begin - JSONResponse := CreateJSONResponse(RequestID); + Result := ProcessRequestEx(RequestBody, TMCPTransportHints.None).Body; +end; + +function TMCPJsonRpcProcessor.ProcessRequestEx(const RequestBody: string; + const Hints: TMCPTransportHints): TMCPProcessResult; +begin + var Message := TJSONObject.ParseJSONValue(RequestBody); try - ErrorObj := TJSONObject.Create; - JSONResponse.AddPair('error', ErrorObj); - ErrorObj.AddPair('code', TJSONNumber.Create(ErrorCode)); - ErrorObj.AddPair('message', ErrorMessage); - Result := JSONResponse.ToJSON; + Result := ProcessRequestEx(Message, Hints); finally - JSONResponse.Free; + Message.Free; end; end; -function TMCPJsonRpcProcessor.ProcessRequest(const RequestBody: string; const SessionID: string): string; +function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; + const Hints: TMCPTransportHints): TMCPProcessResult; var - ErrorCode: Integer; - ExecuteResult: TValue; - JSONRequest: TJSONObject; - JSONResponse: TJSONObject; - MethodName: string; - MethodValue: TJSONValue; - Params: TJSONObject; - ParamsValue: TJSONValue; - RequestID: TValue; -begin - Result := ''; - JSONRequest := nil; - JSONResponse := nil; + RequestId: TMCPRequestId; + Era: TMCPProtocolEra; + Context: IMCPRequestContext; +begin + RequestId := TMCPRequestId.FromJson(nil); + Era := EraFromHeaders(Hints); + Context := nil; try try - JSONRequest := ParseJSONRequest(RequestBody); - - RequestID := ExtractRequestID(JSONRequest); - - MethodValue := JSONRequest.GetValue('method'); - MethodName := ''; - if Assigned(MethodValue) then - MethodName := MethodValue.Value; - - // Notifications (requests without id) should not have a response - if RequestID.IsEmpty then + if not Assigned(Message) then + raise EMCPError.ParseError('Invalid JSON'); + if Message is TJSONArray then + raise EMCPError.InvalidRequest('JSON-RPC batch requests are not supported'); + if not (Message is TJSONObject) then + raise EMCPError.InvalidRequest('JSON-RPC message must be an object'); + + var Request := TJSONObject(Message); + + RequestId := TMCPRequestId.FromJson(Request.GetValue('id')); + if RequestId.Kind = TMCPRequestIdKind.Null then + raise EMCPError.InvalidRequest('id must not be null'); + if RequestId.Kind = TMCPRequestIdKind.Invalid then begin - if MethodName = 'notifications/initialized' then - TLogger.Info('MCP Initialized notification received') - else - TLogger.Info('Notification received: ' + MethodName); - Exit; + RequestId := TMCPRequestId.FromJson(nil); + raise EMCPError.InvalidRequest('id must be a string or an integer'); end; - JSONResponse := CreateJSONResponse(RequestID); + var JsonRpc := Request.GetValue('jsonrpc'); + if not (JsonRpc is TJSONString) or (TJSONString(JsonRpc).Value <> JSONRPC_VERSION) then + raise EMCPError.InvalidRequest('jsonrpc must be "2.0"'); - ParamsValue := JSONRequest.GetValue('params'); - Params := nil; - if Assigned(ParamsValue) and (ParamsValue is TJSONObject) then - Params := ParamsValue as TJSONObject; - - ExecuteResult := ExecuteMethodCall(FManagerRegistry, MethodName, Params); - - if not ExecuteResult.IsEmpty then + var MethodValue := Request.GetValue('method'); + if not (MethodValue is TJSONString) 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); + // A message with result or error is a response sent by the client; + // it is never answered. + if Assigned(Request.GetValue('result')) or Assigned(Request.GetValue('error')) then + begin + if Era = TMCPProtocolEra.Modern then + raise EMCPError.InvalidRequest('JSON-RPC responses are not accepted'); + Result.Body := ''; + Result.HttpStatus := HTTP_STATUS_ACCEPTED; + Result.Era := Era; + Result.IsNotification := True; + Exit; + end; + raise EMCPError.InvalidRequest('method must be a string'); end; + var Method := TJSONString(MethodValue).Value; - Result := JSONResponse.ToJSON; + var ParamsValue := Request.GetValue('params'); + var Params: TJSONObject := nil; + if Assigned(ParamsValue) then + begin + if not (ParamsValue is TJSONObject) then + raise EMCPError.InvalidParams('params must be an object'); + Params := TJSONObject(ParamsValue); + end; + if RequestId.Kind = TMCPRequestIdKind.None then + Exit(ProcessNotification(Method, Params, Hints)); + + Era := EraFromMessage(Method, Params, Hints); + Context := BuildRequestContext(Method, Params, RequestId, Hints); + Era := Context.Era; + + var ExecuteResult := DispatchRequest(Context, Params); + + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', RequestId.ToJson); + var ResultJson := ResultToJson(ExecuteResult, Context); + if Assigned(ResultJson) then + Response.AddPair('result', ResultJson); + Result.Body := Response.ToJSON; + finally + Response.Free; + end; + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Era; + Result.IsNotification := False; except + on E: 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.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas new file mode 100644 index 0000000..206b6ac --- /dev/null +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -0,0 +1,262 @@ +unit MCPServer.RequestContext; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +type + /// What the transport knows about a request before the processor sees it. + TMCPTransportHints = record + /// True when the transport carries HTTP headers (Streamable HTTP). + HasHeaderLayer: Boolean; + HasProtocolVersionHeader: Boolean; + ProtocolVersionHeader: string; + HasMethodHeader: Boolean; + MethodHeader: string; + HasNameHeader: Boolean; + NameHeader: string; + RemoteAddress: string; + /// Per-process legacy state (stdio); nil for stateless transports. + LegacySession: TMCPLegacySession; + + /// No headers, no session: the plain JSON-RPC layer. + class function None: TMCPTransportHints; static; + /// stdio: no headers, one session slot per process. + class function ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; static; + /// HTTP: the MCP-Protocol-Version header, empty and HasHeader False when absent. + class function ForHttp(const HasVersionHeader: Boolean; const VersionHeader: string): TMCPTransportHints; static; + end; + + /// Default IMCPRequestContext implementation and the thread-local Current. + TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) + private + FEra: TMCPProtocolEra; + FProtocolVersion: string; + FMethod: string; + FRequestId: TMCPRequestId; + FMeta: TJSONObject; + FLegacySession: TMCPLegacySession; + FManagerRegistry: IMCPManagerRegistry; + function MetaObject(const Key: string): TJSONObject; + public + /// Meta is cloned; the context owns its copy. + constructor Create(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; + const ARequestId: TMCPRequestId; const AMeta: TJSONObject; + const ALegacySession: TMCPLegacySession; const AManagerRegistry: IMCPManagerRegistry); + 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 HasClientCapability(const Path: string): Boolean; + procedure RequireClientCapability(const Path: string); + function IsCancelled: Boolean; + procedure CheckCancelled; + + /// The context of the request the calling thread is serving, or nil. + class function Current: IMCPRequestContext; + /// Set by the processor around a handler call; nil clears it. + class procedure SetCurrent(const Value: IMCPRequestContext); + end; + +implementation + +uses + MCPServer.Errors; + +threadvar + // Raw pointer with manual reference counting: a managed threadvar is not + // finalised when a thread ends. + 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.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(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; + const ARequestId: TMCPRequestId; const AMeta: TJSONObject; const ALegacySession: TMCPLegacySession; + const AManagerRegistry: IMCPManagerRegistry); +begin + inherited Create; + FEra := AEra; + FProtocolVersion := AProtocolVersion; + FMethod := AMethod; + FRequestId := ARequestId; + if Assigned(AMeta) then + FMeta := TJSONObject(AMeta.Clone); + FLegacySession := ALegacySession; + FManagerRegistry := AManagerRegistry; +end; + +destructor TMCPRequestContext.Destroy; +begin + FMeta.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 Value is TJSONString 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.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; + + // Rebuild the dotted path as nested objects: 'elicitation.form' becomes + // {"elicitation": {"form": {}}}. + var Required := TJSONObject.Create; + var Node := Required; + for var Segment in Path.Split(['.']) do + begin + var Child := TJSONObject.Create; + Node.AddPair(Segment, Child); + Node := Child; + end; + raise EMCPError.MissingRequiredClientCapability(Required); +end; + +function TMCPRequestContext.IsCancelled: Boolean; +begin + Result := False; +end; + +procedure TMCPRequestContext.CheckCancelled; +begin + // Cancellation is not wired to a transport yet; nothing to check. +end; + +class function TMCPRequestContext.Current: IMCPRequestContext; +begin + Result := IMCPRequestContext(CurrentContextPointer); +end; + +class procedure TMCPRequestContext.SetCurrent(const Value: IMCPRequestContext); +begin + if Assigned(CurrentContextPointer) then + IMCPRequestContext(CurrentContextPointer)._Release; + + CurrentContextPointer := Pointer(Value); + if Assigned(Value) then + Value._AddRef; +end; + +end. diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index b8a2606..5620b16 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -65,6 +65,12 @@ interface 'resources/read' ); +function IsLegacyProtocolVersion(const Version: string): Boolean; +function IsModernProtocolVersion(const Version: string): Boolean; +/// The revision answered to an initialize request: the requested one when it +/// is served, otherwise the newest legacy revision. +function NegotiateLegacyProtocolVersion(const Requested: string): string; + type OptionalAttribute = class(TCustomAttribute) end; @@ -103,7 +109,111 @@ TMCPToolsCapability = class; procedure RegisterManager(const Manager: IMCPCapabilityManager); function GetManagerForMethod(const Method: string): IMCPCapabilityManager; end; - + + /// Optional view on a manager registry that can list its managers, used to + /// derive the server capabilities. Probed with Supports(). + IMCPManagerEnumerator = interface + ['{6D1F0B2C-3A4E-4F5B-8C7D-9E0F1A2B3C4D}'] + function GetManagers: TArray; + end; + + /// Implemented by managers that want a reference to the registry they are + /// registered in (TMCPManagerRegistry injects it). Keep the reference weak. + IMCPRegistryAware = interface + ['{2B7C9D1E-4F6A-4B8C-9D0E-1F2A3B4C5D6E}'] + procedure SetManagerRegistry(const Registry: IMCPManagerRegistry); + end; + + {$SCOPEDENUMS ON} + /// Legacy: initialize-based revisions (2025-11-25 and earlier). + /// Modern: per-request _meta revisions (2026-07-28 and later). + TMCPProtocolEra = (Legacy, Modern); + + TMCPRequestIdKind = (None, Null, Text, Number, Invalid); + {$SCOPEDENUMS OFF} + + /// The JSON-RPC id of a message. None means the member is absent + /// (notification); Invalid covers booleans, objects, arrays and fractions. + 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; + /// True for a string or integer id (a request that must be answered). + function IsPresent: Boolean; + /// JSON value for the response; null when the id is absent or invalid. + function ToJson: TJSONValue; + function AsText: string; + end; + + /// Per-process legacy state for stdio: the protocol version negotiated by + /// the last initialize. Empty until an initialize has been answered. + TMCPLegacySession = class + private + FProtocolVersion: string; + public + property ProtocolVersion: string read FProtocolVersion write FProtocolVersion; + end; + + /// What a handler may know about the request it is serving. Built once + /// per request by the JSON-RPC processor and reachable through + /// TMCPRequestContext.Current while the handler runs. + 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; + + /// True when the client declared the capability, given as a dotted path + /// such as 'elicitation' or 'elicitation.form'. Always False for legacy + /// requests (their capabilities are not carried per request). + function HasClientCapability(const Path: string): Boolean; + /// Raises EMCPError -32021 when the capability was not declared. + procedure RequireClientCapability(const Path: string); + function IsCancelled: Boolean; + procedure CheckCancelled; + + property Era: TMCPProtocolEra read GetEra; + property ProtocolVersion: string read GetProtocolVersion; + property Method: string read GetMethod; + property RequestId: TMCPRequestId read GetRequestId; + /// The request's _meta object (nil when absent). Owned by the context. + property Meta: TJSONObject read GetMeta; + /// io.modelcontextprotocol/clientCapabilities (never nil for modern + /// requests, nil for legacy requests). + 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; + end; + + /// Managers that want the request context receive it through this + /// interface; the processor falls back to IMCPCapabilityManager.ExecuteMethod. + IMCPCapabilityManagerEx = interface + ['{9F4B2D6A-1C3E-4E5F-A7B8-C9D0E1F2A3B4}'] + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + end; + + /// Managers that contribute an entry to the server capabilities + /// (for example "tools": {"listChanged": false}). + IMCPCapabilityProvider = interface + ['{C5D7E9F1-2A4B-4C6D-8E0F-1A2B3C4D5E6F}'] + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + end; + TMCPCapabilities = class private FTools: TMCPToolsCapability; @@ -167,6 +277,105 @@ TMCPToolsResponse = class implementation +function IsLegacyProtocolVersion(const Version: string): Boolean; +begin + for var Known in MCP_LEGACY_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +function IsModernProtocolVersion(const Version: string): Boolean; +begin + for var Known in MCP_MODERN_PROTOCOL_VERSIONS do + if Known = Version then + Exit(True); + Result := False; +end; + +function NegotiateLegacyProtocolVersion(const Requested: string): string; +begin + if IsLegacyProtocolVersion(Requested) then + Result := Requested + else + Result := MCP_LATEST_LEGACY_PROTOCOL_VERSION; +end; + +{ TMCPRequestId } + +class function TMCPRequestId.FromJson(const Value: TJSONValue): TMCPRequestId; +begin + Result.Text := ''; + Result.Number := 0; + + if not Assigned(Value) then + Result.Kind := TMCPRequestIdKind.None + else if Value is TJSONNull then + Result.Kind := TMCPRequestIdKind.Null + else if Value is TJSONNumber then + begin + // Only integers are valid ids; a fraction is not. + 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); diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 2b782c7..2b217a6 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -26,6 +26,7 @@ interface IdServerIOHandler, MCPServer.Types, MCPServer.Settings, + MCPServer.RequestContext, MCPServer.JsonRpcProcessor; type @@ -54,6 +55,7 @@ TMCPIdHTTPServer = class(TComponent) 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 BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; function AcceptsSSE(const AcceptHeader: string): Boolean; function IsRequestOnlyNotificationsOrResponses(JSONRequest: TJSONValue): Boolean; public @@ -134,7 +136,7 @@ procedure TMCPIdHTTPServer.Start; if not Assigned(FManagerRegistry) then raise Exception.Create('Manager registry not assigned'); - FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry); + FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry, FSettings); if Assigned(FSettings) then begin @@ -412,6 +414,16 @@ function TMCPIdHTTPServer.GetNextEventID: string; Result := IntToStr(AtomicIncrement(FEventIDCounter)); end; +function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; +const + PROTOCOL_VERSION_HEADER = 'MCP-Protocol-Version'; +begin + // Header names are matched case-insensitively by TIdHeaderList. + var HasHeader := RequestInfo.RawHeaders.IndexOfName(PROTOCOL_VERSION_HEADER) >= 0; + Result := TMCPTransportHints.ForHttp(HasHeader, Trim(RequestInfo.RawHeaders.Values[PROTOCOL_VERSION_HEADER])); + Result.RemoteAddress := RequestInfo.RemoteIP; +end; + function TMCPIdHTTPServer.AcceptsSSE(const AcceptHeader: string): Boolean; begin Result := Pos('text/event-stream', AcceptHeader) > 0; @@ -478,7 +490,7 @@ procedure TMCPIdHTTPServer.HandlePostRequestSSE(RequestInfo: TIdHTTPRequestInfo; if SessionID <> '' then ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; - JSONResponse := FJsonRpcProcessor.ProcessRequest(RequestBody, SessionID); + JSONResponse := FJsonRpcProcessor.ProcessRequestEx(RequestBody, BuildTransportHints(RequestInfo)).Body; if JSONResponse <> '' then begin @@ -506,13 +518,10 @@ procedure TMCPIdHTTPServer.HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); var ResponseBody: string; - ResponseJSON: TJSONObject; - ResultObj: TJSONObject; - SessionValue: TJSONValue; begin TLogger.Info('Handling POST request with JSON response'); - ResponseBody := FJsonRpcProcessor.ProcessRequest(RequestBody, SessionID); + ResponseBody := FJsonRpcProcessor.ProcessRequestEx(RequestBody, BuildTransportHints(RequestInfo)).Body; if ResponseBody = '' then begin @@ -523,22 +532,8 @@ procedure TMCPIdHTTPServer.HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo ResponseInfo.ContentType := 'application/json'; ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - if (SessionID = '') and (Pos('"sessionId"', ResponseBody) > 0) 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 + // Sessions are never minted; an incoming id is echoed back unchanged. + if SessionID <> '' then ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; ResponseInfo.ContentStream := TStringStream.Create(ResponseBody, TEncoding.UTF8); diff --git a/src/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index 71c4415..d790337 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -7,6 +7,8 @@ interface System.Classes, System.JSON, MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, MCPServer.JsonRpcProcessor, MCPServer.Logger; @@ -16,10 +18,16 @@ TMCPStdioTransport = class FManagerRegistry: IMCPManagerRegistry; FCoreManager: IMCPCapabilityManager; FJsonRpcProcessor: TMCPJsonRpcProcessor; + FLegacySession: TMCPLegacySession; + function GetSettings: TMCPSettings; + procedure SetSettings(const Value: TMCPSettings); public constructor Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); destructor Destroy; override; procedure Run; + /// Server identity and protocol options; assign before Run. Without it the + /// processor uses the defaults (settings.ini next to the executable). + property Settings: TMCPSettings read GetSettings write SetSettings; end; implementation @@ -32,6 +40,7 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core FManagerRegistry := ManagerRegistry; FCoreManager := CoreManager; FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(ManagerRegistry); + FLegacySession := TMCPLegacySession.Create; // stdout carries MCP messages only; every log line must go to stderr, // also for library consumers that never set UseStdErr themselves. @@ -42,9 +51,20 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core destructor TMCPStdioTransport.Destroy; begin FJsonRpcProcessor.Free; + FLegacySession.Free; inherited; end; +function TMCPStdioTransport.GetSettings: TMCPSettings; +begin + Result := FJsonRpcProcessor.Settings; +end; + +procedure TMCPStdioTransport.SetSettings(const Value: TMCPSettings); +begin + FJsonRpcProcessor.Settings := Value; +end; + procedure TMCPStdioTransport.Run; var ErrorJson: TJSONObject; @@ -66,7 +86,7 @@ procedure TMCPStdioTransport.Run; TLogger.Info('Received: ' + InputLine); - Response := FJsonRpcProcessor.ProcessRequest(InputLine, ''); + Response := FJsonRpcProcessor.ProcessRequestEx(InputLine, TMCPTransportHints.ForStdio(FLegacySession)).Body; if Response <> '' then begin From bcc56bc2ae4a9405a096820b5e55a8301908f656 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:05:29 +0200 Subject: [PATCH 11/56] test: era detection, processor, capability builder and modern goldens - TRequestContextTests: one test per branch of BuildRequestContext - TProcessorTests: status policy, modern envelope, discover, client responses, error data, thread-local context, 50 concurrent initializes - TCapabilityBuilderTests - tests/golden/modern: 16 cases replayed through the JSON-RPC layer; TGoldenRunner shared by the legacy and modern fixtures - Legacy goldens re-recorded where the wire changed on purpose: initialize (negotiated revision, cleaned capabilities, no sessionId), batch arrays, id null, missing method or jsonrpc, params not an object, server/discover without _meta - HTTP goldens: six modern cases added; initialize no longer carries an Mcp-Session-Id header - Conformance baselines regenerated: 2026-07-28 goes from 32 to 87 passed checks; the Inspector smoke run now succeeds in the modern era as well --- conformance-baseline-2026-07-28.yml | 11 +- scripts/capture-http-goldens.ps1 | 8 + tests/MCPServer.Tests.Capabilities.pas | 100 +++++ tests/MCPServer.Tests.Golden.Legacy.pas | 26 +- tests/MCPServer.Tests.Golden.Modern.pas | 163 ++++++++ tests/MCPServer.Tests.Golden.pas | 42 ++ tests/MCPServer.Tests.Processor.pas | 369 ++++++++++++++++++ tests/MCPServer.Tests.RequestContext.pas | 332 ++++++++++++++++ tests/MCPServer.Tests.dpr | 9 +- tests/MCPServer.Tests.dproj | 7 + tests/golden/README.md | 1 + tests/golden/http/modern-discover.txt | 12 + .../modern-missing-client-capabilities.txt | 12 + .../http/modern-missing-version-header.txt | 12 + tests/golden/http/modern-tools-list.txt | 12 + tests/golden/http/modern-unknown-method.txt | 12 + .../http/modern-unsupported-version.txt | 12 + tests/golden/http/post-batch-requests.txt | 4 +- tests/golden/http/post-initialize-sse.txt | 4 +- tests/golden/http/post-initialize.txt | 5 +- tests/golden/legacy/id-null.json | 9 +- .../golden/legacy/initialize-2025-03-26.json | 6 +- .../golden/legacy/initialize-2025-06-18.json | 4 +- .../golden/legacy/initialize-2025-11-25.json | 6 +- .../legacy/initialize-unknown-version.json | 6 +- .../legacy/initialize-without-params.json | 6 +- .../golden/legacy/missing-jsonrpc-field.json | 4 +- tests/golden/legacy/missing-method.json | 4 +- tests/golden/legacy/params-not-an-object.json | 11 +- .../golden/legacy/request-not-an-object.json | 4 +- .../legacy/server-discover-without-meta.json | 4 +- tests/golden/modern/id-null.json | 26 ++ .../modern/initialize-with-modern-meta.json | 45 +++ tests/golden/modern/invalid-log-level.json | 23 ++ .../modern/missing-client-capabilities.json | 20 + .../golden/modern/missing-jsonrpc-field.json | 25 ++ tests/golden/modern/ping.json | 26 ++ tests/golden/modern/resources-list.json | 59 +++ .../modern/resources-read-project-info.json | 41 ++ .../modern/resources-templates-list.json | 35 ++ .../modern/server-discover-without-meta.json | 15 + tests/golden/modern/server-discover.json | 45 +++ tests/golden/modern/tools-call-echo.json | 41 ++ .../modern/tools-call-unknown-tool.json | 41 ++ tests/golden/modern/tools-list.json | 112 ++++++ tests/golden/modern/unknown-method.json | 26 ++ .../modern/unknown-protocol-version.json | 28 ++ 47 files changed, 1751 insertions(+), 74 deletions(-) create mode 100644 tests/MCPServer.Tests.Capabilities.pas create mode 100644 tests/MCPServer.Tests.Golden.Modern.pas create mode 100644 tests/MCPServer.Tests.Processor.pas create mode 100644 tests/MCPServer.Tests.RequestContext.pas create mode 100644 tests/golden/http/modern-discover.txt create mode 100644 tests/golden/http/modern-missing-client-capabilities.txt create mode 100644 tests/golden/http/modern-missing-version-header.txt create mode 100644 tests/golden/http/modern-tools-list.txt create mode 100644 tests/golden/http/modern-unknown-method.txt create mode 100644 tests/golden/http/modern-unsupported-version.txt create mode 100644 tests/golden/modern/id-null.json create mode 100644 tests/golden/modern/initialize-with-modern-meta.json create mode 100644 tests/golden/modern/invalid-log-level.json create mode 100644 tests/golden/modern/missing-client-capabilities.json create mode 100644 tests/golden/modern/missing-jsonrpc-field.json create mode 100644 tests/golden/modern/ping.json create mode 100644 tests/golden/modern/resources-list.json create mode 100644 tests/golden/modern/resources-read-project-info.json create mode 100644 tests/golden/modern/resources-templates-list.json create mode 100644 tests/golden/modern/server-discover-without-meta.json create mode 100644 tests/golden/modern/server-discover.json create mode 100644 tests/golden/modern/tools-call-echo.json create mode 100644 tests/golden/modern/tools-call-unknown-tool.json create mode 100644 tests/golden/modern/tools-list.json create mode 100644 tests/golden/modern/unknown-method.json create mode 100644 tests/golden/modern/unknown-protocol-version.json diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index 42a87ce..5caf2bb 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -4,18 +4,12 @@ server: - server-stateless - completion-complete - - tools-list - - tools-call-simple-text - tools-call-image - tools-call-audio - tools-call-embedded-resource - tools-call-mixed-content - - tools-call-error - tools-call-with-progress - - resources-list - - resources-read-text - resources-read-binary - - resources-templates-read - sep-2164-resource-not-found - prompts-list - prompts-get-simple @@ -30,11 +24,10 @@ server: - input-required-result-request-state - input-required-result-multiple-input-requests - input-required-result-multi-round - - input-required-result-missing-input-response - input-required-result-non-tool-request - input-required-result-result-type - - input-required-result-unsupported-methods - input-required-result-tampered-state - input-required-result-capability-check - - input-required-result-ignore-extra-params + # only WARNING checks (MRTR is not implemented); the runner counts them as not passed + - input-required-result-missing-input-response - input-required-result-validate-input diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 index 89ca750..549e92f 100644 --- a/scripts/capture-http-goldens.ps1 +++ b/scripts/capture-http-goldens.ps1 @@ -113,8 +113,16 @@ try { $sseAccept = 'Accept: application/json, text/event-stream' $jsonType = 'Content-Type: application/json' $initialize = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"golden-client","version":"1.0.0"}}}' + $modernHeader = 'MCP-Protocol-Version: 2026-07-28' + $modernMeta = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},"io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0.0"}}' $cases = @( + @{ Name = 'modern-discover'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":"d1","method":"server/discover","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":20,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":21,"method":"prompts/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-missing-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-unsupported-version'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 1900-01-01'); Body = '{"jsonrpc":"2.0","id":23,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}' } + @{ Name = 'modern-missing-client-capabilities'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":24,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}' } @{ Name = 'post-initialize'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = $initialize } @{ Name = 'post-initialize-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = $initialize } @{ Name = 'post-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } diff --git a/tests/MCPServer.Tests.Capabilities.pas b/tests/MCPServer.Tests.Capabilities.pas new file mode 100644 index 0000000..8d5d318 --- /dev/null +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -0,0 +1,100 @@ +unit MCPServer.Tests.Capabilities; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TCapabilityBuilderTests = class + public + [Test] procedure Registry_YieldsToolsAndResourcesInRegistrationOrder; + [Test] procedure Registry_NeverEmitsLogging; + [Test] procedure RegistryWithoutEnumeration_YieldsDefaults; + end; + +implementation + +uses + System.SysUtils, + System.Generics.Collections, + System.JSON, + MCPServer.Types, + MCPServer.Capabilities, + MCPServer.Tests.Harness; + +type + /// A registry that cannot list its managers (a consumer's own implementation). + 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_YieldsToolsAndResourcesInRegistrationOrder; +begin + var Harness := TMCPTestHarness.Create; + try + var Capabilities := TMCPCapabilityBuilder.Build(Harness.ManagerRegistry, TMCPProtocolEra.Modern); + try + Assert.AreEqual(2, Capabilities.Count); + Assert.AreEqual('tools', Capabilities.Pairs[0].JsonString.Value); + Assert.AreEqual('resources', Capabilities.Pairs[1].JsonString.Value); + Assert.IsFalse(Capabilities.GetValue('tools.listChanged')); + Assert.IsFalse(Capabilities.GetValue('resources.subscribe')); + Assert.IsFalse(Capabilities.GetValue('resources.listChanged')); + 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; + +initialization + TDUnitX.RegisterTestFixture(TCapabilityBuilderTests); + +end. diff --git a/tests/MCPServer.Tests.Golden.Legacy.pas b/tests/MCPServer.Tests.Golden.Legacy.pas index 8eb8865..156ebca 100644 --- a/tests/MCPServer.Tests.Golden.Legacy.pas +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -91,29 +91,11 @@ procedure TLegacyGoldenTests.TearDown; procedure TLegacyGoldenTests.CheckGolden(const CaseName: string); begin - var GoldenCase := TGoldenCase.Create(TGoldenFiles.CaseFile(TGoldenFiles.LEGACY_SUITE, CaseName)); - try - var Response: string; - var SavedDirectory := GetCurrentDir; - if GoldenCase.WorkingDirectory <> '' then - SetCurrentDir(GoldenCase.WorkingDirectory); - try - Response := FHarness.Process(GoldenCase.RequestBody); - finally - SetCurrentDir(SavedDirectory); - end; - - if TGoldenFiles.RecordMode then + TGoldenRunner.Check(TGoldenFiles.LEGACY_SUITE, CaseName, + function(const RequestBody: string): string begin - GoldenCase.RecordExpected(Response); - Exit; - end; - - Assert.AreEqual(GoldenCase.ExpectedText, GoldenCase.NormalizeResponse(Response), - 'Golden mismatch for ' + CaseName); - finally - GoldenCase.Free; - end; + Result := FHarness.Process(RequestBody); + end); end; procedure TLegacyGoldenTests.Initialize_2025_06_18; diff --git a/tests/MCPServer.Tests.Golden.Modern.pas b/tests/MCPServer.Tests.Golden.Modern.pas new file mode 100644 index 0000000..645c16e --- /dev/null +++ b/tests/MCPServer.Tests.Golden.Modern.pas @@ -0,0 +1,163 @@ +unit MCPServer.Tests.Golden.Modern; + +interface + +uses + DUnitX.TestFramework, + MCPServer.Tests.Harness, + MCPServer.Tests.Golden; + +type + /// Pins the wire behaviour for requests that carry per-request _meta + /// (MCP 2026-07-28), replayed through the plain JSON-RPC layer. + [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_IsLegacy; + [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 + // A legacy handshake on the same process must not latch the server. + 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_IsLegacy; +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; + +initialization + TDUnitX.RegisterTestFixture(TModernGoldenTests); + +end. diff --git a/tests/MCPServer.Tests.Golden.pas b/tests/MCPServer.Tests.Golden.pas index 6785178..21f0f3d 100644 --- a/tests/MCPServer.Tests.Golden.pas +++ b/tests/MCPServer.Tests.Golden.pas @@ -23,6 +23,7 @@ TGoldenFiles = class 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; @@ -97,6 +98,15 @@ TGoldenCase = class property HasExpected: Boolean read GetHasExpected; end; + TGoldenProcessFunc = reference to function(const RequestBody: string): string; + + /// Replays one golden case through the given processing function and + /// compares (or records) the response. + TGoldenRunner = class + public + class procedure Check(const Suite, CaseName: string; const Process: TGoldenProcessFunc); + end; + implementation uses @@ -403,4 +413,36 @@ procedure TGoldenCase.Save; TFile.WriteAllBytes(FFileName, TEncoding.UTF8.GetBytes(Text)); end; +{ TGoldenRunner } + +class procedure TGoldenRunner.Check(const Suite, CaseName: string; const Process: TGoldenProcessFunc); +begin + var GoldenCase := TGoldenCase.Create(TGoldenFiles.CaseFile(Suite, CaseName)); + try + var Response: string; + var SavedDirectory := GetCurrentDir; + if GoldenCase.WorkingDirectory <> '' then + SetCurrentDir(GoldenCase.WorkingDirectory); + try + Response := Process(GoldenCase.RequestBody); + finally + SetCurrentDir(SavedDirectory); + end; + + if TGoldenFiles.RecordMode then + begin + GoldenCase.RecordExpected(Response); + Exit; + end; + + var Expected := GoldenCase.ExpectedText; + var Actual := GoldenCase.NormalizeResponse(Response); + if Expected <> Actual then + raise EGoldenError.CreateFmt('Golden mismatch for %s/%s'#13#10'--- expected ---'#13#10'%s'#13#10'--- actual ---'#13#10'%s', + [Suite, CaseName, Expected, Actual]); + finally + GoldenCase.Free; + end; +end; + end. diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas new file mode 100644 index 0000000..6af9cac --- /dev/null +++ b/tests/MCPServer.Tests.Processor.pas @@ -0,0 +1,369 @@ +unit MCPServer.Tests.Processor; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + System.JSON, + System.Rtti, + MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + /// A manager that records the context it was called with. + TProbeManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx) + public + SeenContext: IMCPRequestContext; + SeenCurrent: IMCPRequestContext; + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + end; + + /// Status policy, result envelope and dispatch through ProcessRequestEx. + [TestFixture] + TProcessorTests = class + private + FHarness: TMCPTestHarness; + FSettings: TMCPSettings; + FProcessor: TMCPJsonRpcProcessor; + function Run(const RequestJson: string; const Hints: TMCPTransportHints): TMCPProcessResult; + function Parse(const Body: string): TJSONObject; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Modern_UnknownMethod_Is404; + [Test] procedure Legacy_UnknownMethod_Is200; + [Test] procedure ParseError_ModernHeader_Is400_LegacyIs200; + [Test] procedure Modern_MetaValidationError_Is400; + [Test] procedure Modern_ApplicationInvalidParams_Is200; + [Test] procedure Modern_ToolsList_HasEnvelopeAndCacheHints; + [Test] procedure Modern_ToolsCall_HasResultTypeButNoCacheHints; + [Test] procedure Modern_Discover_ListsModernVersionsAndCapabilities; + [Test] procedure Modern_Discover_ListsLegacyVersions_WhenConfigured; + [Test] procedure Modern_ServerInfo_UsesSettings; + [Test] procedure Legacy_Initialize_NegotiatesAndDeclaresCapabilities; + [Test] procedure Legacy_Result_IsUntouched; + [Test] procedure Notification_Returns202WithoutBody; + [Test] procedure ClientResponse_Legacy_IsIgnored_Modern_IsRejected; + [Test] procedure ErrorData_IsEmitted; + [Test] procedure Current_IsSetDuringDispatch_AndClearedAfter; + [Test] procedure Concurrent_Initialize_AllSucceed; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + System.Threading, + MCPServer.ManagerRegistry, + MCPServer.Errors; + +const + META = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + +{ TProbeManager } + +function TProbeManager.GetCapabilityName: string; +begin + Result := 'probe'; +end; + +function TProbeManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = 'probe/run'; +end; + +function TProbeManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, nil); +end; + +function TProbeManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + SeenContext := Context; + SeenCurrent := TMCPRequestContext.Current; + Result := TValue.From(TJSONObject.Create); +end; + +{ TProcessorTests } + +procedure TProcessorTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + // One settings instance for the managers and the processor. + 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":"prompts/list","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":"prompts/list"}', 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 + // An error a manager raises without an explicit status stays application level. + 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.IsFalse(Response.GetValue('result.capabilities.tools.listChanged')); + Assert.IsFalse(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; + +initialization + TDUnitX.RegisterTestFixture(TProcessorTests); + +end. diff --git a/tests/MCPServer.Tests.RequestContext.pas b/tests/MCPServer.Tests.RequestContext.pas new file mode 100644 index 0000000..82357a2 --- /dev/null +++ b/tests/MCPServer.Tests.RequestContext.pas @@ -0,0 +1,332 @@ +unit MCPServer.Tests.RequestContext; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + System.JSON, + MCPServer.Types, + MCPServer.Settings, + MCPServer.RequestContext, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + /// Era detection, one branch per test, straight against BuildRequestContext. + [TestFixture] + TRequestContextTests = class + private + FHarness: TMCPTestHarness; + FSettings: TMCPSettings; + FProcessor: TMCPJsonRpcProcessor; + FSession: TMCPLegacySession; + function Build(const RequestJson: string; const Hints: TMCPTransportHints): IMCPRequestContext; + procedure ExpectError(const RequestJson: string; const Hints: TMCPTransportHints; + ExpectedCode, ExpectedStatus: Integer; const Because: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Initialize_IsLegacy_EvenWithModernMeta; + [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_UnknownVersion_ListsSupported; + [Test] procedure ModernMeta_MissingClientCapabilities_IsInvalidParams; + [Test] procedure ModernMeta_ClientInfoNotObject_IsInvalidParams; + [Test] procedure ModernMeta_InvalidLogLevel_IsInvalidParams; + [Test] procedure ModernMeta_Ping_IsMethodNotFound; + [Test] procedure ModernMeta_Ping_LenientSetting_Allows; + [Test] procedure ModernMeta_LegacyOnlyMethods_AreNotFound; + [Test] procedure ModernOnlyMethod_WithoutMeta_IsInvalidParams; + [Test] procedure Http_ModernHeader_WithoutMeta_IsInvalidParams; + [Test] procedure Http_UnknownHeaderVersion_IsInvalidRequest; + [Test] procedure Http_LegacyHeader_IsLegacyWithHeaderVersion; + [Test] procedure Http_NoHeader_NoMeta_IsLegacy; + [Test] procedure Stdio_SessionVersion_IsUsedForLegacyRequests; + [Test] procedure Stdio_NoSessionVersion_IsLatestLegacy; + [Test] procedure LegacyMeta_WithProgressTokenOnly_IsLegacy; + [Test] procedure Meta_NotAnObject_IsInvalidParams; + [Test] procedure ClientCapabilities_AreReadable; + [Test] procedure RequireClientCapability_RaisesMissingCapability; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors; + +const + META_MODERN = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28",' + + '"io.modelcontextprotocol/clientCapabilities":{"elicitation":{"form":{}}},' + + '"io.modelcontextprotocol/clientInfo":{"name":"ctx-client","version":"2.0"},' + + '"io.modelcontextprotocol/logLevel":"info"}'; + +function Request(const Method: string; const ParamsJson: string = ''): string; +begin + if ParamsJson = '' then + Result := Format('{"jsonrpc":"2.0","id":1,"method":"%s"}', [Method]) + else + Result := Format('{"jsonrpc":"2.0","id":1,"method":"%s","params":%s}', [Method, ParamsJson]); +end; + +{ TRequestContextTests } + +procedure TRequestContextTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FSettings := FHarness.Settings; + FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FSettings); + FSession := TMCPLegacySession.Create; +end; + +procedure TRequestContextTests.TearDown; +begin + FSession.Free; + FProcessor.Free; + FHarness.Free; +end; + +function TRequestContextTests.Build(const RequestJson: string; const Hints: TMCPTransportHints): IMCPRequestContext; +begin + var Message := TJSONObject.ParseJSONValue(RequestJson) as TJSONObject; + try + var Method := Message.GetValue('method').Value; + var Params := Message.GetValue('params') as TJSONObject; + var RequestId := TMCPRequestId.FromJson(Message.GetValue('id')); + Result := FProcessor.BuildRequestContext(Method, Params, RequestId, Hints); + finally + Message.Free; + end; +end; + +procedure TRequestContextTests.ExpectError(const RequestJson: string; const Hints: TMCPTransportHints; + ExpectedCode, ExpectedStatus: Integer; const Because: string); +begin + try + Build(RequestJson, Hints); + Assert.Fail('expected EMCPError ' + ExpectedCode.ToString + ': ' + Because); + except + on E: EMCPError do + begin + Assert.AreEqual(ExpectedCode, E.Code, Because + ' (code)'); + Assert.AreEqual(ExpectedStatus, E.HttpStatus, Because + ' (http status)'); + end; + end; +end; + +procedure TRequestContextTests.Initialize_IsLegacy_EvenWithModernMeta; +begin + var Context := Build(Request('initialize', '{"protocolVersion":"2025-11-25",' + META_MODERN + '}'), 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 Context := Build(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.ForHttp(True, '2026-07-28')); + Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); +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; + +initialization + TDUnitX.RegisterTestFixture(TRequestContextTests); + +end. diff --git a/tests/MCPServer.Tests.dpr b/tests/MCPServer.Tests.dpr index a748d9f..deeae9b 100644 --- a/tests/MCPServer.Tests.dpr +++ b/tests/MCPServer.Tests.dpr @@ -9,6 +9,9 @@ uses 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.Serializer in '..\src\Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in '..\src\Protocol\MCPServer.Schema.Generator.pas', MCPServer.Logger in '..\src\Core\MCPServer.Logger.pas', @@ -38,7 +41,11 @@ uses MCPServer.Tests.Constants in 'MCPServer.Tests.Constants.pas', MCPServer.Tests.ServerStatus in 'MCPServer.Tests.ServerStatus.pas', MCPServer.Tests.Registration in 'MCPServer.Tests.Registration.pas', - MCPServer.Tests.Logger in 'MCPServer.Tests.Logger.pas'; + MCPServer.Tests.Logger in 'MCPServer.Tests.Logger.pas', + MCPServer.Tests.RequestContext in 'MCPServer.Tests.RequestContext.pas', + MCPServer.Tests.Processor in 'MCPServer.Tests.Processor.pas', + MCPServer.Tests.Capabilities in 'MCPServer.Tests.Capabilities.pas', + MCPServer.Tests.Golden.Modern in 'MCPServer.Tests.Golden.Modern.pas'; procedure RunTests; begin diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServer.Tests.dproj index 52f79d7..efde742 100644 --- a/tests/MCPServer.Tests.dproj +++ b/tests/MCPServer.Tests.dproj @@ -73,6 +73,9 @@ MainSource + + + @@ -100,6 +103,10 @@ + + + + Base diff --git a/tests/golden/README.md b/tests/golden/README.md index ae1ce66..680b7d0 100644 --- a/tests/golden/README.md +++ b/tests/golden/README.md @@ -9,6 +9,7 @@ CHANGELOG; an unintended change is a regression. | Directory | Layer | Recorded by | Verified by | |---|---|---|---| | `legacy/` | JSON-RPC processor (`TMCPJsonRpcProcessor.ProcessRequest`) with the same registry as `MCPServer.dpr`, initialize-based protocol revisions | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TLegacyGoldenTests`) | +| `modern/` | The same layer for requests that carry per-request `_meta` (MCP 2026-07-28), including the rejected shapes | `scripts\run-tests.ps1 -Record` | `scripts\run-tests.ps1` (DUnitX fixture `TModernGoldenTests`) | | `http/` | Streamable HTTP transport (`TMCPIdHTTPServer`) of the built executable, captured with curl | `scripts\capture-http-goldens.ps1 -Record` | `scripts\capture-http-goldens.ps1` | ## Legacy case files diff --git a/tests/golden/http/modern-discover.txt b/tests/golden/http/modern-discover.txt new file mode 100644 index 0000000..e2d6942 --- /dev/null +++ b/tests/golden/http/modern-discover.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 322 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} diff --git a/tests/golden/http/modern-missing-client-capabilities.txt b/tests/golden/http/modern-missing-client-capabilities.txt new file mode 100644 index 0000000..c82e75a --- /dev/null +++ b/tests/golden/http/modern-missing-client-capabilities.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 151 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":24,"error":{"code":-32602,"message":"params._meta.io.modelcontextprotocol/clientCapabilities is required and must be an object"}} diff --git a/tests/golden/http/modern-missing-version-header.txt b/tests/golden/http/modern-missing-version-header.txt new file mode 100644 index 0000000..825eb74 --- /dev/null +++ b/tests/golden/http/modern-missing-version-header.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 100 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":22,"error":{"code":-32020,"message":"MCP-Protocol-Version header is missing"}} diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt new file mode 100644 index 0000000..0808def --- /dev/null +++ b/tests/golden/http/modern-tools-list.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 1208 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}],"resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"private"}} diff --git a/tests/golden/http/modern-unknown-method.txt b/tests/golden/http/modern-unknown-method.txt new file mode 100644 index 0000000..226cb60 --- /dev/null +++ b/tests/golden/http/modern-unknown-method.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 141 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":21,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/modern-unsupported-version.txt b/tests/golden/http/modern-unsupported-version.txt new file mode 100644 index 0000000..174f76b --- /dev/null +++ b/tests/golden/http/modern-unsupported-version.txt @@ -0,0 +1,12 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 151 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, GET, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id +Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Max-Age: 86400 +Connection: keep-alive + +{"jsonrpc":"2.0","id":23,"error":{"code":-32022,"message":"Unsupported protocol version","data":{"supported":["2026-07-28"],"requested":"1900-01-01"}}} diff --git a/tests/golden/http/post-batch-requests.txt b/tests/golden/http/post-batch-requests.txt index 1562083..56df616 100644 --- a/tests/golden/http/post-batch-requests.txt +++ b/tests/golden/http/post-batch-requests.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 98 +Content-Length: 105 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, GET, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id @@ -9,4 +9,4 @@ Access-Control-Expose-Headers: Mcp-Session-Id Access-Control-Max-Age: 86400 Connection: keep-alive -{"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"JSON-RPC request must be an object"}} +{"jsonrpc":"2.0","id":null,"error":{"code":-32600,"message":"JSON-RPC batch requests are not supported"}} diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt index 7b2cbb7..1dc5400 100644 --- a/tests/golden/http/post-initialize-sse.txt +++ b/tests/golden/http/post-initialize-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 341 +Content-Length: 254 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, GET, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id @@ -13,4 +13,4 @@ X-Accel-Buffering: no id: event: message -data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"supportsProgress":false,"supportsCancellation":false},"resources":{"subscribe":false,"listChanged":false}},"sessionId":"","serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} +data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-initialize.txt b/tests/golden/http/post-initialize.txt index 999bab2..b0e39c6 100644 --- a/tests/golden/http/post-initialize.txt +++ b/tests/golden/http/post-initialize.txt @@ -1,13 +1,12 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 312 +Content-Length: 225 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, GET, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id Access-Control-Expose-Headers: Mcp-Session-Id Access-Control-Max-Age: 86400 Connection: keep-alive -Mcp-Session-Id: -{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"supportsProgress":false,"supportsCancellation":false},"resources":{"subscribe":false,"listChanged":false}},"sessionId":"","serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} +{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/legacy/id-null.json b/tests/golden/legacy/id-null.json index 2ee796b..5f7e085 100644 --- a/tests/golden/legacy/id-null.json +++ b/tests/golden/legacy/id-null.json @@ -4,5 +4,12 @@ "id": null, "method": "ping" }, - "expectedText": "" + "expected": { + "jsonrpc": "2.0", + "id": null, + "error": { + "code": -32600, + "message": "id must not be null" + } + } } diff --git a/tests/golden/legacy/initialize-2025-03-26.json b/tests/golden/legacy/initialize-2025-03-26.json index dbeb4af..89c4d50 100644 --- a/tests/golden/legacy/initialize-2025-03-26.json +++ b/tests/golden/legacy/initialize-2025-03-26.json @@ -20,18 +20,16 @@ "jsonrpc": "2.0", "id": 1, "result": { - "protocolVersion": "2025-06-18", + "protocolVersion": "2025-11-25", "capabilities": { "tools": { - "supportsProgress": false, - "supportsCancellation": false + "listChanged": false }, "resources": { "subscribe": false, "listChanged": false } }, - "sessionId": "", "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 index 02d1a61..278630d 100644 --- a/tests/golden/legacy/initialize-2025-06-18.json +++ b/tests/golden/legacy/initialize-2025-06-18.json @@ -23,15 +23,13 @@ "protocolVersion": "2025-06-18", "capabilities": { "tools": { - "supportsProgress": false, - "supportsCancellation": false + "listChanged": false }, "resources": { "subscribe": false, "listChanged": false } }, - "sessionId": "", "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 index 8b71a55..c535848 100644 --- a/tests/golden/legacy/initialize-2025-11-25.json +++ b/tests/golden/legacy/initialize-2025-11-25.json @@ -20,18 +20,16 @@ "jsonrpc": "2.0", "id": 1, "result": { - "protocolVersion": "2025-06-18", + "protocolVersion": "2025-11-25", "capabilities": { "tools": { - "supportsProgress": false, - "supportsCancellation": false + "listChanged": false }, "resources": { "subscribe": false, "listChanged": false } }, - "sessionId": "", "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 index 6459de9..563f783 100644 --- a/tests/golden/legacy/initialize-unknown-version.json +++ b/tests/golden/legacy/initialize-unknown-version.json @@ -20,18 +20,16 @@ "jsonrpc": "2.0", "id": 1, "result": { - "protocolVersion": "2025-06-18", + "protocolVersion": "2025-11-25", "capabilities": { "tools": { - "supportsProgress": false, - "supportsCancellation": false + "listChanged": false }, "resources": { "subscribe": false, "listChanged": false } }, - "sessionId": "", "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 index 4262720..d356655 100644 --- a/tests/golden/legacy/initialize-without-params.json +++ b/tests/golden/legacy/initialize-without-params.json @@ -11,18 +11,16 @@ "jsonrpc": "2.0", "id": 1, "result": { - "protocolVersion": "2025-06-18", + "protocolVersion": "2025-11-25", "capabilities": { "tools": { - "supportsProgress": false, - "supportsCancellation": false + "listChanged": false }, "resources": { "subscribe": false, "listChanged": false } }, - "sessionId": "", "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 index 5f8921e..6bb1b4d 100644 --- a/tests/golden/legacy/missing-jsonrpc-field.json +++ b/tests/golden/legacy/missing-jsonrpc-field.json @@ -6,7 +6,9 @@ "expected": { "jsonrpc": "2.0", "id": 25, - "result": { + "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 index 9afc9c8..aef6c0f 100644 --- a/tests/golden/legacy/missing-method.json +++ b/tests/golden/legacy/missing-method.json @@ -7,8 +7,8 @@ "jsonrpc": "2.0", "id": 26, "error": { - "code": -32601, - "message": "Method [] not found. The method does not exist or is not available." + "code": -32600, + "message": "method must be a string" } } } diff --git a/tests/golden/legacy/params-not-an-object.json b/tests/golden/legacy/params-not-an-object.json index 6f00ce1..ce32538 100644 --- a/tests/golden/legacy/params-not-an-object.json +++ b/tests/golden/legacy/params-not-an-object.json @@ -11,14 +11,9 @@ "expected": { "jsonrpc": "2.0", "id": 27, - "result": { - "content": [ - { - "type": "text", - "text": "Error: Invalid tool parameters" - } - ], - "isError": true + "error": { + "code": -32602, + "message": "params must be an object" } } } diff --git a/tests/golden/legacy/request-not-an-object.json b/tests/golden/legacy/request-not-an-object.json index 3d94870..389d3e7 100644 --- a/tests/golden/legacy/request-not-an-object.json +++ b/tests/golden/legacy/request-not-an-object.json @@ -4,8 +4,8 @@ "jsonrpc": "2.0", "id": null, "error": { - "code": -32700, - "message": "JSON-RPC request must be an object" + "code": -32600, + "message": "JSON-RPC batch requests are not supported" } } } diff --git a/tests/golden/legacy/server-discover-without-meta.json b/tests/golden/legacy/server-discover-without-meta.json index fc72266..1f6f1e2 100644 --- a/tests/golden/legacy/server-discover-without-meta.json +++ b/tests/golden/legacy/server-discover-without-meta.json @@ -8,8 +8,8 @@ "jsonrpc": "2.0", "id": 21, "error": { - "code": -32601, - "message": "Method [server/discover] not found. The method does not exist or is not available." + "code": -32602, + "message": "server/discover requires params._meta.io.modelcontextprotocol/protocolVersion" } } } 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..e8d7500 --- /dev/null +++ b/tests/golden/modern/initialize-with-modern-meta.json @@ -0,0 +1,45 @@ +{ + "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, + "result": { + "protocolVersion": "2025-11-25", + "capabilities": { + "tools": { + "listChanged": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } +} 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..ce79da0 --- /dev/null +++ b/tests/golden/modern/resources-list.json @@ -0,0 +1,59 @@ +{ + "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": "project://readme", + "name": "Project README", + "description": "README.md file contents", + "mimeType": "text/markdown" + }, + { + "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": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" + } + ], + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + }, + "ttlMs": 0, + "cacheScope": "private" + } + } +} 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..320b30e --- /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 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\"]}" + } + ], + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + }, + "ttlMs": 0, + "cacheScope": "private" + } + } +} diff --git a/tests/golden/modern/resources-templates-list.json b/tests/golden/modern/resources-templates-list.json new file mode 100644 index 0000000..d53e717 --- /dev/null +++ b/tests/golden/modern/resources-templates-list.json @@ -0,0 +1,35 @@ +{ + "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": [ + ], + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + }, + "ttlMs": 0, + "cacheScope": "private" + } + } +} 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..62e591d --- /dev/null +++ b/tests/golden/modern/server-discover.json @@ -0,0 +1,45 @@ +{ + "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": false + }, + "resources": { + "subscribe": false, + "listChanged": false + } + }, + "_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..b517254 --- /dev/null +++ b/tests/golden/modern/tools-call-unknown-tool.json @@ -0,0 +1,41 @@ +{ + "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, + "result": { + "content": [ + { + "type": "text", + "text": "Error: Tool not found: no_such_tool" + } + ], + "isError": true, + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + } + } + } +} diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json new file mode 100644 index 0000000..d77f6f6 --- /dev/null +++ b/tests/golden/modern/tools-list.json @@ -0,0 +1,112 @@ +{ + "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": "get_time", + "description": "Get the current server time in ISO format", + "inputSchema": { + "type": "object", + "properties": { + } + } + }, + { + "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": "echo", + "description": "Echo a message back to the user", + "inputSchema": { + "type": "object", + "properties": { + "message": { + "type": "string", + "description": "Message to echo back" + } + }, + "required": [ + "message" + ] + } + }, + { + "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" + ] + } + } + ], + "resultType": "complete", + "_meta": { + "io.modelcontextprotocol/serverInfo": { + "name": "delphi-mcp-server", + "version": "1.0.0" + } + }, + "ttlMs": 0, + "cacheScope": "private" + } + } +} diff --git a/tests/golden/modern/unknown-method.json b/tests/golden/modern/unknown-method.json new file mode 100644 index 0000000..4795ecf --- /dev/null +++ b/tests/golden/modern/unknown-method.json @@ -0,0 +1,26 @@ +{ + "request": { + "jsonrpc": "2.0", + "id": 8, + "method": "prompts/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": 8, + "error": { + "code": -32601, + "message": "Method [prompts/list] 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" + } + } + } +} From f358dd5bc89b52f60e833db10e50881ac4222786 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:05:29 +0200 Subject: [PATCH 12/56] docs: describe the protocol eras and the new settings README: dual-era badge, feature line and the section "Protocol Versions and Dual-Era Behaviour"; CHANGELOG entries for the protocol core. --- CHANGELOG.md | 58 ++++++++++++++++++++++++++++++++++++++++++++-------- README.md | 28 +++++++++++++++++++++---- 2 files changed, 73 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 369e946..ef0ce14 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,16 +5,43 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ## [Unreleased] -Test harness, golden files and hygiene. No client-visible protocol change. - ### Added +- 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\MCPServer.Tests.dpr` (Win32 and Win64) with an in-process harness that builds the same registry as `MCPServer.dpr` and - drives `TMCPJsonRpcProcessor.ProcessRequest`. -- Golden files that pin the wire behaviour: 38 JSON-RPC cases in - `tests\golden\legacy` and 26 HTTP transport cases (status line, headers, - body) in `tests\golden\http`. + drives the JSON-RPC processor; era-detection, processor, capability-builder + and concurrency tests. +- Golden files that pin the wire behaviour: JSON-RPC cases for the legacy and + the modern era in `tests\golden\legacy` and `tests\golden\modern`, and HTTP + transport cases (status line, headers, body) in `tests\golden\http`. - `build-tests.bat` and `scripts\run-tests.ps1` (build and run, `-Record` to re-record goldens), `scripts\capture-http-goldens.ps1`. - `scripts\run-conformance.ps1` for the official conformance CLI with one @@ -34,9 +61,25 @@ Test harness, golden files and hygiene. No client-visible protocol change. (`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". ### Changed +- `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 @@ -49,9 +92,6 @@ Test harness, golden files and hygiene. No client-visible protocol change. `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. -- README: library checklist (register before start, stdout rules for stdio, - `server://status` is opt-in), automated-tests section, resource list matches - what the executable registers. ### Fixed diff --git a/README.md b/README.md index 714e12a..5fd2d1a 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ ![Delphi](https://img.shields.io/badge/Delphi-12%2B-red) ![Platform](https://img.shields.io/badge/platform-Windows%20%7C%20Linux-lightgrey) ![License](https://img.shields.io/badge/license-MIT-blue) -![MCP](https://img.shields.io/badge/MCP-2025--06--18-green) +![MCP](https://img.shields.io/badge/MCP-2026--07--28%20(dual--era)-green) A Model Context Protocol (MCP) server implementation in Delphi, designed to integrate with Claude Code, Codex, and other MCP-compatible clients for AI-powered Delphi development workflows. @@ -13,6 +13,7 @@ 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) @@ -27,7 +28,7 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte ## Features -- **Full MCP Protocol Support**: Implements MCP specification 2025-06-18 with Streamable HTTP and SSE +- **Dual-era MCP**: Serves MCP 2026-07-28 (per-request `_meta`, `server/discover`) and the initialize-based revisions 2025-06-18 and 2025-11-25 on the same endpoint and the same stdio process; see [Protocol versions](#protocol-versions-and-dual-era-behaviour) - **Dual Transport Support**: HTTP (Streamable HTTP with SSE) and STDIO (stdin/stdout) - **Dual Response Mode**: Supports both JSON-RPC and Server-Sent Events in the same server - **Tool System**: Extensible tool system with RTTI-based discovery and execution @@ -129,6 +130,25 @@ The server will: **Supported flag variants:** `--stdio`, `-stdio`, `/stdio` +## 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 | +|---|---|---| +| `initialize` | 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. | +| `params._meta` with `io.modelcontextprotocol/protocolVersion` | modern | `2026-07-28`. `clientCapabilities` is required (`-32602`); an unknown revision gets `-32022` with the supported list; `ping`, `logging/setLevel` and `resources/subscribe` do not exist in this era (`-32601`). | +| `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. + +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. @@ -579,10 +599,10 @@ The `tests` folder holds a DUnitX project that drives the JSON-RPC layer in-proc .\scripts\capture-http-goldens.ps1 # replay the HTTP golden cases with curl against Win64\Debug\MCPServer.exe .\scripts\run-stdio-smoke.ps1 # drive --stdio and check the framing of stdout/stderr .\scripts\run-conformance.ps1 # official conformance CLI, 2026-07-28 and 2025-11-25 requirement sets -.\scripts\run-inspector-smoke.ps1 -ExpectedFailures delphi-modern # Inspector CLI tools/list per protocol era and over stdio +.\scripts\run-inspector-smoke.ps1 # Inspector CLI tools/list per protocol era (legacy, auto, modern) and over stdio ``` -Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. The Inspector smoke run takes the entries that must fail as a parameter (`delphi-modern` as long as the server has no `server/discover`). `build-tests.bat [Config] [Platform]` compiles the test project on its own. +Known conformance failures are listed per requirement set in `conformance-baseline-.yml`; the conformance run fails on new failures and on entries that started to pass. The Inspector smoke run takes entries that are expected to fail as `-ExpectedFailures`. `build-tests.bat [Config] [Platform]` compiles the test project on its own. ## About GDK Software From 96321c7a79d6ce3134cf382545445fd53302f52a Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:31:38 +0200 Subject: [PATCH 13/56] feat: dual-era Streamable HTTP with Origin check, status codes and mirrored headers TMCPIdHTTPServer now runs the pipeline the transport spec describes: Origin validation on every request (403 with a JSON-RPC body and Vary: Origin; loopback origins on any port pass, the allow-list comes from [Security] AllowedOrigins or [CORS] AllowedOrigins, null is refused), CORS headers only when enabled, 404 for other paths, 204 for OPTIONS, 405 with Allow for anything but POST, then the processor's HTTP status is answered. Notifications and client responses get 202 with an empty body, 4xx answers carry a JSON-RPC error body, SSE responses lose the id: line. The server binds to loopback when Host is loopback (both 127.0.0.1 and ::1 when IPv6 is available) and to every interface otherwise; BindAddress overrides. MaxRequestBodyBytes (413), MaxJsonDepth (400), MaxConnections and an optional EndpointInfoPath are new settings. The OpenSSL 1.0.2 handler offers TLS 1.2 only. USE_TAURUS_TLS lives in src\MCPServer.inc. Modern requests must mirror method and name into Mcp-Method and Mcp-Name (MCPServer.HttpHeaders decodes the Base64 sentinel form strictly); a missing or different header is -32020 with 400. A legacy request with an unknown MCP-Protocol-Version header gets 400. An initialize that carries modern _meta is a modern request and therefore an unknown method (404), as a modern client probing the server expects. Bodies are logged at Debug level through TLogger.RedactJson. --- build.bat | 4 +- settings.ini.example | 27 +- src/Core/MCPServer.Logger.pas | 53 +- src/Core/MCPServer.Settings.pas | 66 ++ src/MCPServer.dpr | 1 + src/MCPServer.dproj | 1 + src/MCPServer.inc | 7 + src/Protocol/MCPServer.JsonRpcProcessor.pas | 89 ++- src/Server/MCPServer.HttpHeaders.pas | 256 +++++++ src/Server/MCPServer.IdHTTPServer.pas | 632 +++++++++--------- ...MCPServer.Tests.dpr => MCPServerTests.dpr} | 0 ...erver.Tests.dproj => MCPServerTests.dproj} | 0 12 files changed, 804 insertions(+), 332 deletions(-) create mode 100644 src/MCPServer.inc create mode 100644 src/Server/MCPServer.HttpHeaders.pas rename tests/{MCPServer.Tests.dpr => MCPServerTests.dpr} (100%) rename tests/{MCPServer.Tests.dproj => MCPServerTests.dproj} (100%) diff --git a/build.bat b/build.bat index ab09d36..b4ceb4c 100644 --- a/build.bat +++ b/build.bat @@ -70,10 +70,10 @@ if not "!TAURUS_PATH!"=="" ( ) if "%PLATFORM%"=="Win32" ( - !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -I!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Win64" ( - !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -I!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Linux64" ( REM Use MSBuild for Linux64 diff --git a/settings.ini.example b/settings.ini.example index 06d6240..5f6225f 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -14,6 +14,25 @@ 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 + +[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= [Protocol] ; Boolean values: use 1 (true) or 0 (false) @@ -26,13 +45,13 @@ DiscoverListsLegacyVersions=0 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.Logger.pas b/src/Core/MCPServer.Logger.pas index e977bf3..5a492dd 100644 --- a/src/Core/MCPServer.Logger.pas +++ b/src/Core/MCPServer.Logger.pas @@ -5,6 +5,7 @@ interface uses System.SysUtils, System.Classes, + System.JSON, System.SyncObjs; type @@ -68,7 +69,12 @@ TLogger = class 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; - + + /// Returns the JSON text with the values of _meta, requestState, + /// inputResponses and token-like members replaced, for logging. Text + /// that is not JSON is described by its length only. + 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; @@ -256,6 +262,51 @@ class procedure TLogger.Error(const Exception: Exception); Instance.DoWriteLog(TLogLevel.Error, System.SysUtils.Format('%s: %s', [Exception.ClassName, Exception.Message])); end; +function IsSensitiveKey(const Key: string): Boolean; +const + EXACT_KEYS: array[0..2] of string = ('_meta', 'requestState', 'inputResponses'); + PARTIAL_KEYS: array[0..5] of string = ('token', 'secret', 'password', 'authorization', 'apikey', 'api_key'); +begin + for var Exact in EXACT_KEYS do + if Key = Exact then + Exit(True); + + var Lower := Key.ToLower; + for var Partial in PARTIAL_KEYS do + if Lower.Contains(Partial) then + Exit(True); + Result := False; +end; + +procedure RedactValue(const Value: TJSONValue); +begin + if Value is TJSONObject then + begin + for var Pair in TJSONObject(Value) do + if IsSensitiveKey(Pair.JsonString.Value) then + Pair.JsonValue := TJSONString.Create('') + else + RedactValue(Pair.JsonValue); + end + else if Value is TJSONArray then + for var Item in TJSONArray(Value) do + RedactValue(Item); +end; + +class function TLogger.RedactJson(const Json: string): string; +begin + var Parsed := TJSONObject.ParseJSONValue(Json); + if not Assigned(Parsed) then + Exit(Format('<%d characters, not JSON>', [Length(Json)])); + + try + RedactValue(Parsed); + Result := Parsed.ToJSON; + finally + Parsed.Free; + end; +end; + class function TLogger.GetLogToConsole: Boolean; begin Result := Instance.FLogToConsole; diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index ca0b77b..ce9096b 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -29,7 +29,14 @@ TMCPSettings = class FLenientModernPing: Boolean; FDiscoverListsLegacyVersions: Boolean; FDiscoverTtlMs: Integer; + FBindAddress: string; + FEndpointInfoPath: string; + FMaxRequestBodyBytes: Integer; + FMaxJsonDepth: Integer; + FMaxConnections: Integer; + FSecurityAllowedOrigins: string; function GetProtocol: string; + function GetAllowedOrigins: string; procedure LoadDefaults; procedure CreateDefaultSettingsFile; @@ -69,6 +76,28 @@ TMCPSettings = class property DiscoverListsLegacyVersions: Boolean read FDiscoverListsLegacyVersions write FDiscoverListsLegacyVersions; /// [Protocol] DiscoverTtlMs: cache hint on server/discover. Default 0. property DiscoverTtlMs: Integer read FDiscoverTtlMs write FDiscoverTtlMs; + + /// [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. + property BindAddress: string read FBindAddress write FBindAddress; + /// [Server] EndpointInfoPath: optional GET path that answers a small JSON + /// document with the endpoint URL and the protocol versions. Empty = off. + property EndpointInfoPath: string read FEndpointInfoPath write FEndpointInfoPath; + /// [Server] MaxRequestBodyBytes: larger POST bodies get 413. Default 4 MB. + property MaxRequestBodyBytes: Integer read FMaxRequestBodyBytes write FMaxRequestBodyBytes; + /// [Server] MaxJsonDepth: deeper nesting gets 400. Default 64. + property MaxJsonDepth: Integer read FMaxJsonDepth write FMaxJsonDepth; + /// [Server] MaxConnections: Indy connection limit; 0 = unlimited. + property MaxConnections: Integer read FMaxConnections write FMaxConnections; + /// [Security] AllowedOrigins: origins that pass the Origin check next to + /// the loopback origins. Falls back to [CORS] AllowedOrigins when empty. + property SecurityAllowedOrigins: string read FSecurityAllowedOrigins write FSecurityAllowedOrigins; + /// The effective allow-list for the Origin check. + property AllowedOrigins: string read GetAllowedOrigins; + + const DEFAULT_MAX_REQUEST_BODY_BYTES = 4 * 1024 * 1024; + const DEFAULT_MAX_JSON_DEPTH = 64; end; implementation @@ -123,6 +152,20 @@ procedure TMCPSettings.LoadDefaults; FLenientModernPing := False; FDiscoverListsLegacyVersions := False; FDiscoverTtlMs := 0; + FBindAddress := ''; + FEndpointInfoPath := ''; + FMaxRequestBodyBytes := DEFAULT_MAX_REQUEST_BODY_BYTES; + FMaxJsonDepth := DEFAULT_MAX_JSON_DEPTH; + FMaxConnections := 0; + FSecurityAllowedOrigins := ''; +end; + +function TMCPSettings.GetAllowedOrigins: string; +begin + if FSecurityAllowedOrigins.Trim <> '' then + Result := FSecurityAllowedOrigins + else + Result := FCorsAllowedOrigins; end; function TMCPSettings.GetProtocol: string; @@ -150,6 +193,15 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Server', 'Description', FServerDescription); IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); IniFile.WriteString('Server', 'Instructions', FInstructions); + IniFile.WriteString('Server', '; Network: BindAddress empty = derived from Host (loopback for localhost)', ''); + IniFile.WriteString('Server', 'BindAddress', FBindAddress); + IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + + IniFile.WriteString('Security', '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); + IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); IniFile.WriteString('Protocol', '; Protocol options (1 = on, 0 = off)', ''); IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); @@ -189,6 +241,13 @@ procedure TMCPSettings.LoadFromFile; FServerDescription := IniFile.ReadString('Server', 'Description', FServerDescription); FServerWebsiteUrl := IniFile.ReadString('Server', 'WebsiteUrl', FServerWebsiteUrl); FInstructions := IniFile.ReadString('Server', 'Instructions', FInstructions); + FBindAddress := IniFile.ReadString('Server', 'BindAddress', FBindAddress); + FEndpointInfoPath := IniFile.ReadString('Server', 'EndpointInfoPath', FEndpointInfoPath); + FMaxRequestBodyBytes := IniFile.ReadInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + FMaxJsonDepth := IniFile.ReadInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + FMaxConnections := IniFile.ReadInteger('Server', 'MaxConnections', FMaxConnections); + + FSecurityAllowedOrigins := IniFile.ReadString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); FLenientModernPing := IniFile.ReadBool('Protocol', 'LenientModernPing', FLenientModernPing); FDiscoverListsLegacyVersions := IniFile.ReadBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); @@ -233,6 +292,13 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteString('Server', 'Description', FServerDescription); IniFile.WriteString('Server', 'WebsiteUrl', FServerWebsiteUrl); IniFile.WriteString('Server', 'Instructions', FInstructions); + IniFile.WriteString('Server', 'BindAddress', FBindAddress); + IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); + IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); + IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + + IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 14ada1b..485e6a2 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -15,6 +15,7 @@ uses 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.Serializer in 'Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in 'Protocol\MCPServer.Schema.Generator.pas', MCPServer.Logger in 'Core\MCPServer.Logger.pas', diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index 8a906d3..d61c4c4 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -132,6 +132,7 @@ + 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/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 3392891..2b4b4b6 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -10,6 +10,7 @@ interface MCPServer.Settings, MCPServer.RequestContext, MCPServer.Errors, + MCPServer.HttpHeaders, MCPServer.Logger; type @@ -42,6 +43,8 @@ TMCPJsonRpcProcessor = class 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; function DispatchRequest(const Context: IMCPRequestContext; const Params: TJSONObject): TValue; @@ -198,7 +201,7 @@ function TMCPJsonRpcProcessor.EraFromMessage(const Method: string; const Params: // The era that decides the status of a rejected request: a body that // names a protocol version in _meta is modern even when it fails validation. Result := EraFromHeaders(Hints); - if (Result = TMCPProtocolEra.Modern) or (Method = 'initialize') or not Assigned(Params) then + if (Result = TMCPProtocolEra.Modern) or not Assigned(Params) then Exit; var MetaValue := Params.GetValue('_meta'); @@ -240,6 +243,46 @@ procedure TMCPJsonRpcProcessor.ValidateModernMeta(const Meta: TJSONObject); nil, HTTP_STATUS_BAD_REQUEST); end; +procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints); +var + Decoded: string; +begin + // Mcp-Method mirrors the method on every modern POST. + if not Hints.HasMethodHeader then + raise EMCPError.HeaderMismatch('Mcp-Method header is missing'); + if Hints.MethodHeader <> Method then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: Mcp-Method header value ''%s'' does not match body value ''%s''', + [Hints.MethodHeader, Method])); + + // Mcp-Name mirrors params.name (tools/call, prompts/get) or params.uri (resources/read). + var SourceField := ''; + if (Method = 'tools/call') or (Method = 'prompts/get') then + SourceField := 'name' + else if Method = 'resources/read' then + SourceField := 'uri'; + if SourceField = '' then + Exit; + + if not Hints.HasNameHeader then + raise EMCPError.HeaderMismatch('Mcp-Name header is missing'); + if not TMCPHeaderValue.TryDecode(Hints.NameHeader, Decoded) then + raise EMCPError.HeaderMismatch('Mcp-Name header value is not a valid header value'); + + var BodyValue := ''; + if Assigned(Params) then + begin + var Source := Params.GetValue(SourceField); + if Source is TJSONString then + BodyValue := TJSONString(Source).Value; + end; + if Decoded <> BodyValue then + raise EMCPError.HeaderMismatch(Format( + 'Header mismatch: Mcp-Name header value ''%s'' does not match body value ''%s''', + [Decoded, BodyValue])); +end; + function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Params: TJSONObject; const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; var @@ -247,21 +290,9 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa begin var Meta := ExtractMeta(Params); - // 1. initialize always selects the legacy era, whatever _meta says. - if Method = 'initialize' then - begin - var Requested := ''; - if Assigned(Params) then - begin - var RequestedValue := Params.GetValue('protocolVersion'); - if RequestedValue is TJSONString then - Requested := TJSONString(RequestedValue).Value; - end; - Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), - Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry)); - end; - - // 2. A protocol version in _meta makes the request modern. + // 1. A protocol version in _meta makes the request modern, initialize + // included: in that era it is an unknown method, which is what a + // modern client probing the server expects. var VersionValue: TJSONValue := nil; if Assigned(Meta) then VersionValue := Meta.GetValue(MCP_META_PROTOCOL_VERSION); @@ -283,6 +314,9 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa if not IsModernProtocolVersion(Version) then raise EMCPError.UnsupportedProtocolVersion(Version, SupportedModernVersions); + if Hints.HasHeaderLayer then + ValidateMirroredHeaders(Method, Params, Hints); + ValidateModernMeta(Meta); if IsLegacyOnlyMethod(Method) then @@ -296,6 +330,21 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa Hints.LegacySession, FManagerRegistry)); end; + // 2. initialize without modern _meta selects the legacy era and negotiates + // the revision. + if Method = 'initialize' then + begin + var Requested := ''; + if Assigned(Params) then + begin + var RequestedValue := Params.GetValue('protocolVersion'); + if RequestedValue is TJSONString then + Requested := TJSONString(RequestedValue).Value; + end; + Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), + Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry)); + end; + // 3. A modern-only method without _meta is a malformed modern request. if IsModernOnlyMethod(Method) then raise EMCPError.Create(JSONRPC_INVALID_PARAMS, @@ -435,9 +484,15 @@ function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: I function TMCPJsonRpcProcessor.StatusForError(Era: TMCPProtocolEra; const Error: EMCPError): Integer; begin - // Legacy clients read 404 as "session terminated"; they always get 200. + // Legacy clients read 404 as "session terminated". They get 200 for every + // JSON-RPC error; the one 4xx their revisions define is 400 for a bad + // MCP-Protocol-Version header, which arrives with the status set. if Era = TMCPProtocolEra.Legacy then + begin + if Error.HttpStatus = HTTP_STATUS_BAD_REQUEST then + Exit(HTTP_STATUS_BAD_REQUEST); Exit(HTTP_STATUS_OK); + end; if Error.HttpStatus <> 0 then Exit(Error.HttpStatus); diff --git a/src/Server/MCPServer.HttpHeaders.pas b/src/Server/MCPServer.HttpHeaders.pas new file mode 100644 index 0000000..c11de8a --- /dev/null +++ b/src/Server/MCPServer.HttpHeaders.pas @@ -0,0 +1,256 @@ +unit MCPServer.HttpHeaders; + +interface + +uses + System.SysUtils; + +type + /// Values of the headers the Streamable HTTP transport mirrors from the + /// body (Mcp-Name, Mcp-Param-*). Header values are visible ASCII; anything + /// else travels Base64-encoded between the sentinels =?base64? and ?=. + TMCPHeaderValue = record + const SENTINEL_PREFIX = '=?base64?'; + const SENTINEL_SUFFIX = '?='; + + /// Visible ASCII (0x21 to 0x7E), space and horizontal tab only. + class function IsHeaderSafe(const Value: string): Boolean; static; + class function IsSentinel(const Value: string): Boolean; static; + /// Strict Base64: alphabet, length a multiple of four, padding only at + /// the end. Returns False on any deviation. + class function TryDecodeBase64(const Text: string; out Bytes: TBytes): Boolean; static; + /// Decodes a header value to the string it stands for. A sentinel value + /// is Base64-decoded as UTF-8; a plain value must be header-safe. + class function TryDecode(const Value: string; out Decoded: string): Boolean; static; + end; + + TMCPAcceptHeader = record + /// True when one of the comma-separated entries names the media type + /// (parameters ignored, case-insensitive). + class function Accepts(const AcceptHeader, MediaType: string): Boolean; static; + end; + + /// Origin validation for DNS-rebinding protection. + TMCPOriginPolicy = record + const ALLOW_ALL = '*'; + + /// An origin whose host is localhost, 127.0.0.1 or [::1], any port. + class function IsLoopback(const Origin: string): Boolean; static; + /// Absent origins and loopback origins pass. Otherwise the origin must be + /// in the allow-list: scheme://host[:port], compared case-insensitively; + /// a ':*' port allows any port; '*' allows everything. 'null' never passes. + class function IsAllowed(const Origin: string; const AllowList: TArray): Boolean; static; + class function Matches(const Origin, Pattern: string): Boolean; static; + end; + + TMCPJsonLimits = record + /// Nesting depth of objects and arrays in a JSON text, ignoring the + /// contents of strings. Zero for a scalar. + class function NestingDepth(const Json: string): Integer; static; + end; + +implementation + +uses + System.NetEncoding; + +{ TMCPHeaderValue } + +class function TMCPHeaderValue.IsHeaderSafe(const Value: string): Boolean; +begin + for var C in Value do + if not ((C = #9) or ((C >= #$20) and (C <= #$7E))) then + Exit(False); + Result := True; +end; + +class function TMCPHeaderValue.IsSentinel(const Value: string): Boolean; +begin + // The markers are case-sensitive and must appear exactly as shown. + 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 } + +procedure SplitOrigin(const Origin: string; out Scheme, Host, Port: string); +begin + Scheme := ''; + Host := ''; + Port := ''; + + var Rest := Origin.Trim; + var SchemeEnd := Rest.IndexOf('://'); + if SchemeEnd < 0 then + Exit; + Scheme := Rest.Substring(0, SchemeEnd).ToLower; + Rest := Rest.Substring(SchemeEnd + 3); + + // IPv6 hosts are bracketed; the port follows the closing bracket. + var PortStart: Integer; + if Rest.StartsWith('[') then + begin + var BracketEnd := Rest.IndexOf(']'); + if BracketEnd < 0 then + Exit; + Host := Rest.Substring(0, BracketEnd + 1).ToLower; + PortStart := Rest.IndexOf(':', BracketEnd); + end + else + begin + PortStart := Rest.IndexOf(':'); + if PortStart >= 0 then + Host := Rest.Substring(0, PortStart).ToLower + else + Host := Rest.ToLower; + end; + + if PortStart >= 0 then + Port := Rest.Substring(PortStart + 1); +end; + +class function TMCPOriginPolicy.IsLoopback(const Origin: string): Boolean; +var + Scheme, Host, Port: string; +begin + SplitOrigin(Origin, Scheme, Host, Port); + Result := ((Scheme = 'http') or (Scheme = 'https')) + and ((Host = 'localhost') or (Host = '127.0.0.1') or (Host = '[::1]')); +end; + +class function TMCPOriginPolicy.Matches(const Origin, Pattern: string): Boolean; +var + OriginScheme, OriginHost, OriginPort: string; + PatternScheme, PatternHost, PatternPort: string; +begin + if Pattern.Trim = ALLOW_ALL then + Exit(True); + + SplitOrigin(Origin, OriginScheme, OriginHost, OriginPort); + SplitOrigin(Pattern, PatternScheme, PatternHost, PatternPort); + if (OriginScheme = '') or (PatternScheme = '') then + Exit(False); + + Result := (OriginScheme = PatternScheme) and (OriginHost = PatternHost) + and ((PatternPort = '*') or (OriginPort = PatternPort)); +end; + +class function TMCPOriginPolicy.IsAllowed(const Origin: string; const AllowList: TArray): Boolean; +begin + var Value := Origin.Trim; + if Value = '' then + Exit(True); + if SameText(Value, 'null') then + Exit(False); + if IsLoopback(Value) then + Exit(True); + + for var Pattern in AllowList do + if Matches(Value, Pattern) then + Exit(True); + Result := False; +end; + +{ 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.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 2b217a6..fcc709e 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -2,9 +2,7 @@ interface -// TaurusTLS provides OpenSSL 3.x/4.x support with modern ECDHE cipher suites -// Install via GetIt Package Manager: Search for "TaurusTLS" or get from https://github.com/TaurusTLS-Developers/TaurusTLS -{$DEFINE USE_TAURUS_TLS} // Comment this line to use standard Indy SSL (OpenSSL 1.0.2) +{$I MCPServer.inc} uses System.SysUtils, @@ -18,6 +16,8 @@ interface IdCustomHTTPServer, IdGlobal, IdGlobalProtocols, + IdSocketHandle, + IdStack, {$IFDEF USE_TAURUS_TLS} TaurusTLS, {$ELSE} @@ -30,6 +30,10 @@ interface MCPServer.JsonRpcProcessor; type + /// Streamable HTTP transport on Indy. The request pipeline is: + /// Origin check (403), CORS headers, endpoint check (404), OPTIONS (204), + /// any verb but POST (405), then the JSON-RPC processor decides body and + /// status. Notifications are answered with 202 and an empty body. TMCPIdHTTPServer = class(TComponent) private FHTTPServer: TIdHTTPServer; @@ -44,25 +48,33 @@ TMCPIdHTTPServer = class(TComponent) FPort: Word; FActive: Boolean; FSettings: TMCPSettings; - FEventIDCounter: Int64; procedure ConfigureSSL; + procedure ConfigureBindings; + procedure AddBinding(const IP: string; IPVersion: TIdIPVersion); procedure HandleQuerySSLPort(APort: Word; var VUseSSL: 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); + function AllowedOrigins: TArray; + function ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; + procedure ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); + procedure HandleEndpointInfo(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 BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; - function AcceptsSSE(const AcceptHeader: string): Boolean; - function IsRequestOnlyNotificationsOrResponses(JSONRequest: TJSONValue): Boolean; + 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; + function HeaderValue(RequestInfo: TIdHTTPRequestInfo; const Name: string): string; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Start; procedure Stop; + /// Addresses the server listens on after Start ("ip:port"). + function BoundAddresses: TArray; + /// Port after Start; a Settings port of 0 lets the system choose one. property Port: Word read FPort write FPort; property Active: Boolean read FActive; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry write FManagerRegistry; @@ -74,31 +86,43 @@ implementation uses MCPServer.Resource.Server, - MCPServer.CoreManager, + MCPServer.Errors, + MCPServer.HttpHeaders, MCPServer.Logger; const - KEEP_ALIVE_TIMEOUT = 300; DEFAULT_MCP_PORT = 3000; - // HTTP Status Codes - HTTP_OK = 200; - HTTP_ACCEPTED = 202; HTTP_NO_CONTENT = 204; - HTTP_NOT_FOUND = 404; - HTTP_METHOD_NOT_ALLOWED = 405; - HTTP_NOT_ACCEPTABLE = 406; HTTP_FORBIDDEN = 403; + HTTP_METHOD_NOT_ALLOWED = 405; + HTTP_PAYLOAD_TOO_LARGE = 413; - // CORS Max Age (24 hours in seconds) CORS_MAX_AGE = 86400; + CORS_ALLOW_METHODS = 'POST, OPTIONS'; + CORS_ALLOW_HEADERS = 'Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID'; + CORS_EXPOSE_HEADERS = 'Mcp-Session-Id, WWW-Authenticate'; + ALLOW_HEADER = 'POST, OPTIONS'; + + HEADER_ORIGIN = 'Origin'; + HEADER_ACCEPT = 'Accept'; + HEADER_SESSION_ID = 'Mcp-Session-Id'; + HEADER_PROTOCOL_VERSION = 'MCP-Protocol-Version'; + HEADER_METHOD = 'Mcp-Method'; + HEADER_NAME = 'Mcp-Name'; + + MEDIA_TYPE_JSON = 'application/json'; + MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; - // SSE Message Format SSE_EVENT_PREFIX = 'event: '; SSE_DATA_PREFIX = 'data: '; - SSE_ID_PREFIX = 'id: '; SSE_MESSAGE_TERMINATOR = #10#10; + LOOPBACK_IPV4 = '127.0.0.1'; + LOOPBACK_IPV6 = '::1'; + ANY_IPV4 = '0.0.0.0'; + ANY_IPV6 = '::'; + { TMCPIdHTTPServer } constructor TMCPIdHTTPServer.Create(Owner: TComponent); @@ -106,7 +130,6 @@ constructor TMCPIdHTTPServer.Create(Owner: TComponent); inherited Create(Owner); FPort := DEFAULT_MCP_PORT; FActive := False; - FEventIDCounter := 0; FJsonRpcProcessor := nil; FHTTPServer := TIdHTTPServer.Create(Self); @@ -136,265 +159,135 @@ procedure TMCPIdHTTPServer.Start; if not Assigned(FManagerRegistry) then raise Exception.Create('Manager registry not assigned'); + 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; 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.Stop; begin if not FActive then Exit; - + 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) - else - begin - ResponseInfo.ResponseNo := HTTP_METHOD_NOT_ALLOWED; - ResponseInfo.ResponseText := 'Method Not Allowed'; - end; - finally - TServerStatusResource.ConnectionClosed; - end; -end; - -function TMCPIdHTTPServer.VerifyAndSetCORSHeaders(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo): Boolean; -var - AllowedOrigin: string; - CurrentOrigin: string; - Found: Boolean; - Origin: string; - OriginsList: TStringList; -begin - Result := True; - - if not Assigned(FSettings) or not FSettings.CorsEnabled then - Exit; - - Origin := RequestInfo.RawHeaders.Values['Origin']; - AllowedOrigin := '*'; - - if (FSettings.CorsAllowedOrigins <> '*') and (Origin <> '') then + Result := nil; + for var I := 0 to FHTTPServer.Bindings.Count - 1 do begin - OriginsList := TStringList.Create; - try - OriginsList.CommaText := FSettings.CorsAllowedOrigins; - Found := False; - - for CurrentOrigin in OriginsList do - begin - if SameText(Trim(CurrentOrigin), Origin) then - begin - AllowedOrigin := Origin; - Found := True; - Break; - end; - end; - - if not Found then - begin - Result := False; - ResponseInfo.ResponseNo := HTTP_FORBIDDEN; - ResponseInfo.ResponseText := 'Forbidden - Origin not allowed'; - TLogger.Info('CORS blocked origin: ' + Origin); - Exit; - end; - finally - OriginsList.Free; - end; + var Binding := FHTTPServer.Bindings[I]; + if Binding.IPVersion = Id_IPv6 then + Result := Result + [Format('[%s]:%d', [Binding.IP, Binding.Port])] + else + Result := Result + [Format('%s:%d', [Binding.IP, Binding.Port])]; end; - - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := AllowedOrigin; - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Methods'] := 'POST, GET, OPTIONS'; - ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Headers'] := - 'Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id'; - ResponseInfo.CustomHeaders.Values['Access-Control-Expose-Headers'] := 'Mcp-Session-Id'; - ResponseInfo.CustomHeaders.Values['Access-Control-Max-Age'] := CORS_MAX_AGE.ToString; end; -procedure TMCPIdHTTPServer.HandleOptionsRequest(ResponseInfo: TIdHTTPResponseInfo); +procedure TMCPIdHTTPServer.AddBinding(const IP: string; IPVersion: TIdIPVersion); begin - ResponseInfo.ResponseNo := HTTP_OK; - ResponseInfo.ResponseText := 'OK'; + var Binding := FHTTPServer.Bindings.Add; + Binding.IP := IP; + Binding.Port := FPort; + Binding.IPVersion := IPVersion; end; -procedure TMCPIdHTTPServer.HandleGetRequest(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); -var - AcceptHeader: string; - SessionID: string; +procedure TMCPIdHTTPServer.ConfigureBindings; begin - AcceptHeader := RequestInfo.RawHeaders.Values['Accept']; - - 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 := 'localhost'; + if Assigned(FSettings) then begin - TLogger.Info('Received GET request - returning endpoint info'); - - ResponseInfo.ContentType := 'application/json'; - ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - - ResponseInfo.ContentText := '{"url": "' + FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort) + - FSettings.Endpoint + '", "transport": "' + FSettings.Protocol + '"}'; - - ResponseInfo.ResponseNo := HTTP_OK; + Address := FSettings.BindAddress.Trim; + Host := FSettings.Host.Trim; end; -end; -procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); -var - AcceptHeader: string; - JSONRequest: TJSONValue; - RequestBody: string; - SessionID: string; -begin - RequestBody := ''; - if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > 0) then + if Address <> '' then begin - RequestInfo.PostStream.Position := 0; - RequestBody := ReadStringFromStream(RequestInfo.PostStream, -1, IndyTextEncoding_UTF8); - end; - - TLogger.Info('Request: ' + RequestBody); - - SessionID := RequestInfo.RawHeaders.Values['Mcp-Session-Id']; - if SessionID <> '' then - TLogger.Info('Session ID from header: ' + SessionID); - - AcceptHeader := RequestInfo.RawHeaders.Values['Accept']; - - JSONRequest := nil; - try - JSONRequest := TJSONObject.ParseJSONValue(RequestBody); - - if Assigned(JSONRequest) and IsRequestOnlyNotificationsOrResponses(JSONRequest) then - begin - TLogger.Info('Request contains only notifications/responses, returning 202 Accepted'); - ResponseInfo.ResponseNo := HTTP_ACCEPTED; - - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; - - Exit; - end; - - if AcceptsSSE(AcceptHeader) then - HandlePostRequestSSE(RequestInfo, ResponseInfo, RequestBody, SessionID) + if (Address = ANY_IPV4) or (Address = ANY_IPV6) then + TLogger.Warning('BindAddress ' + Address + ': the server is reachable from every network interface'); + if Address.Contains(':') then + AddBinding(Address, Id_IPv6) else - HandlePostRequestJSON(RequestInfo, ResponseInfo, RequestBody, SessionID); + AddBinding(Address, Id_IPv4); + Exit; + end; - finally - JSONRequest.Free; + // No BindAddress: a loopback Host means a local server, anything else is + // reachable at the address the host name resolves to. + if SameText(Host, 'localhost') or (Host = LOOPBACK_IPV4) or (Host = LOOPBACK_IPV6) then + begin + AddBinding(LOOPBACK_IPV4, Id_IPv4); + if GStack.SupportsIPv6 then + AddBinding(LOOPBACK_IPV6, Id_IPv6); + end + else + begin + TLogger.Info('Host ' + Host + ' is not loopback; listening on every network interface (set BindAddress to narrow this)'); + AddBinding(ANY_IPV4, Id_IPv4); + if GStack.SupportsIPv6 then + AddBinding(ANY_IPV6, Id_IPv6); end; end; procedure TMCPIdHTTPServer.ConfigureSSL; begin - // Check if certificate files exist if not TFile.Exists(FSettings.SSLCertFile) then begin TLogger.Error('SSL Certificate file not found: ' + FSettings.SSLCertFile); raise Exception.Create('SSL Certificate file not found: ' + FSettings.SSLCertFile); end; - + if not TFile.Exists(FSettings.SSLKeyFile) then begin TLogger.Error('SSL Key file not found: ' + FSettings.SSLKeyFile); raise Exception.Create('SSL Key file not found: ' + FSettings.SSLKeyFile); end; - - // Create and configure SSL handler + {$IFDEF USE_TAURUS_TLS} // TaurusTLS with OpenSSL 3.x/4.x support FSSLHandler := TTaurusTLSServerIOHandler.Create(Self); FSSLHandler.DefaultCert.PublicKey := FSettings.SSLCertFile; FSSLHandler.DefaultCert.PrivateKey := FSettings.SSLKeyFile; {$ELSE} - // Standard Indy SSL with OpenSSL 1.0.2 + // Standard Indy SSL with OpenSSL 1.0.2; TLS 1.2 is the only version offered. 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); @@ -404,143 +297,266 @@ procedure TMCPIdHTTPServer.ConfigureSSL; 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 - // Called from Indy connection threads. - Result := IntToStr(AtomicIncrement(FEventIDCounter)); + // TIdHeaderList matches names case-insensitively. + Result := RequestInfo.RawHeaders.IndexOfName(Name) >= 0; end; -function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; -const - PROTOCOL_VERSION_HEADER = 'MCP-Protocol-Version'; +function TMCPIdHTTPServer.HeaderValue(RequestInfo: TIdHTTPRequestInfo; const Name: string): string; begin - // Header names are matched case-insensitively by TIdHeaderList. - var HasHeader := RequestInfo.RawHeaders.IndexOfName(PROTOCOL_VERSION_HEADER) >= 0; - Result := TMCPTransportHints.ForHttp(HasHeader, Trim(RequestInfo.RawHeaders.Values[PROTOCOL_VERSION_HEADER])); - Result.RemoteAddress := RequestInfo.RemoteIP; + Result := Trim(RequestInfo.RawHeaders.Values[Name]); end; -function TMCPIdHTTPServer.AcceptsSSE(const AcceptHeader: string): Boolean; +procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; + RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); begin - Result := Pos('text/event-stream', AcceptHeader) > 0; -end; + TServerStatusResource.ConnectionOpened; + try + TServerStatusResource.IncrementRequestCount; -function TMCPIdHTTPServer.IsRequestOnlyNotificationsOrResponses(JSONRequest: TJSONValue): Boolean; -var - Arr: TJSONArray; - ErrorValue: TJSONValue; - I: Integer; - IdValue: TJSONValue; - MethodValue: TJSONValue; - Obj: TJSONObject; - ResultValue: TJSONValue; -begin - if JSONRequest is TJSONObject then - begin - Obj := JSONRequest as TJSONObject; - MethodValue := Obj.GetValue('method'); - IdValue := Obj.GetValue('id'); - ResultValue := Obj.GetValue('result'); - ErrorValue := Obj.GetValue('error'); + if not ValidateOrigin(RequestInfo, ResponseInfo) then + Exit; + + ApplyCorsHeaders(RequestInfo, ResponseInfo); - if Assigned(MethodValue) and not Assigned(IdValue) then - Exit(True); + var Endpoint := '/mcp'; + var EndpointInfoPath := ''; + if Assigned(FSettings) then + begin + Endpoint := FSettings.Endpoint; + EndpointInfoPath := FSettings.EndpointInfoPath; + end; - if Assigned(ResultValue) or Assigned(ErrorValue) then - Exit(True); + if (EndpointInfoPath <> '') and (RequestInfo.Document = EndpointInfoPath) and (RequestInfo.CommandType = hcGET) then + begin + HandleEndpointInfo(ResponseInfo); + Exit; + 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 + if RequestInfo.Document <> Endpoint then begin - if not IsRequestOnlyNotificationsOrResponses(Arr.Items[I]) then - begin - Result := False; - Break; - end; + SendEmpty(ResponseInfo, HTTP_STATUS_NOT_FOUND); + Exit; end; - end - else - Result := False; + + if RequestInfo.Command = 'OPTIONS' then + SendEmpty(ResponseInfo, HTTP_NO_CONTENT) + else if RequestInfo.CommandType = hcPOST then + HandlePostRequest(RequestInfo, ResponseInfo) + else + SendMethodNotAllowed(ResponseInfo); + finally + TServerStatusResource.ConnectionClosed; + end; end; -procedure TMCPIdHTTPServer.HandlePostRequestSSE(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); -var - EventID: string; - JSONResponse: string; - SSEMessage: string; +function TMCPIdHTTPServer.AllowedOrigins: TArray; begin - TLogger.Info('Handling POST request with SSE stream'); + Result := nil; + if not Assigned(FSettings) then + Exit; - ResponseInfo.ContentType := 'text/event-stream'; - ResponseInfo.CharSet := 'utf-8'; - ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; - ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + var List := FSettings.AllowedOrigins; + if List.Trim = '' then + Exit; - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; + for var Entry in List.Split([',']) do + if Entry.Trim <> '' then + Result := Result + [Entry.Trim]; +end; - JSONResponse := FJsonRpcProcessor.ProcessRequestEx(RequestBody, BuildTransportHints(RequestInfo)).Body; +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 +procedure TMCPIdHTTPServer.ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + if not Assigned(FSettings) or not FSettings.CorsEnabled then + Exit; + + var Origin := HeaderValue(RequestInfo, HEADER_ORIGIN); + var AllowAll := False; + for var Entry in AllowedOrigins do + if Entry = TMCPOriginPolicy.ALLOW_ALL then + AllowAll := True; + + if (Origin = '') or AllowAll then + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := TMCPOriginPolicy.ALLOW_ALL else + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := Origin; + + var AllowHeaders := CORS_ALLOW_HEADERS; + // Reflect what a preflight asks for, so Mcp-Param-* headers pass as well. + for var Requested in HeaderValue(RequestInfo, 'Access-Control-Request-Headers').Split([',']) do begin - ResponseInfo.ContentText := ''; + var Name := Requested.Trim; + if (Name <> '') and (Pos(LowerCase(Name), LowerCase(AllowHeaders)) = 0) then + AllowHeaders := AllowHeaders + ', ' + Name; end; - ResponseInfo.ResponseNo := HTTP_OK; + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Methods'] := CORS_ALLOW_METHODS; + ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Headers'] := AllowHeaders; + ResponseInfo.CustomHeaders.Values['Access-Control-Expose-Headers'] := CORS_EXPOSE_HEADERS; + ResponseInfo.CustomHeaders.Values['Access-Control-Max-Age'] := CORS_MAX_AGE.ToString; end; -procedure TMCPIdHTTPServer.HandlePostRequestJSON(RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo; const RequestBody: string; const SessionID: string); -var - ResponseBody: string; +procedure TMCPIdHTTPServer.HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo); begin - TLogger.Info('Handling POST request with JSON response'); + var Info := TJSONObject.Create; + try + Info.AddPair('url', FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort) + FSettings.Endpoint); + Info.AddPair('transport', 'streamable-http'); + Info.AddPair('protocolVersions', TJSONArray.Create + .Add(MCP_LATEST_PROTOCOL_VERSION).Add(MCP_PROTOCOL_VERSION_2025_11_25).Add(MCP_PROTOCOL_VERSION_2025_06_18)); + SendJson(ResponseInfo, HTTP_STATUS_OK, Info.ToJSON); + finally + Info.Free; + end; +end; - ResponseBody := FJsonRpcProcessor.ProcessRequestEx(RequestBody, BuildTransportHints(RequestInfo)).Body; +function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; +begin + Result := TMCPTransportHints.ForHttp( + HeaderPresent(RequestInfo, HEADER_PROTOCOL_VERSION), HeaderValue(RequestInfo, HEADER_PROTOCOL_VERSION)); + Result.HasMethodHeader := HeaderPresent(RequestInfo, HEADER_METHOD); + Result.MethodHeader := HeaderValue(RequestInfo, HEADER_METHOD); + Result.HasNameHeader := HeaderPresent(RequestInfo, HEADER_NAME); + Result.NameHeader := HeaderValue(RequestInfo, HEADER_NAME); + Result.RemoteAddress := RequestInfo.RemoteIP; +end; - if ResponseBody = '' then +procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + // Never minted; an incoming id is handed back unchanged when it is a + // plausible header value. + var SessionId := HeaderValue(RequestInfo, HEADER_SESSION_ID); + if (SessionId <> '') and TMCPHeaderValue.IsHeaderSafe(SessionId) and not SessionId.Contains(' ') then + ResponseInfo.CustomHeaders.Values[HEADER_SESSION_ID] := SessionId; +end; + +procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +begin + var MaxBodyBytes: Integer := TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES; + var MaxDepth: Integer := TMCPSettings.DEFAULT_MAX_JSON_DEPTH; + if Assigned(FSettings) then + begin + MaxBodyBytes := FSettings.MaxRequestBodyBytes; + MaxDepth := FSettings.MaxJsonDepth; + end; + + if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > MaxBodyBytes) then + begin + SendJsonRpcError(ResponseInfo, HTTP_PAYLOAD_TOO_LARGE, JSONRPC_INVALID_REQUEST, + Format('Request body exceeds %d bytes', [MaxBodyBytes])); + Exit; + end; + + var RequestBody := ''; + if Assigned(RequestInfo.PostStream) and (RequestInfo.PostStream.Size > 0) then + begin + RequestInfo.PostStream.Position := 0; + RequestBody := ReadStringFromStream(RequestInfo.PostStream, -1, IndyTextEncoding_UTF8); + end; + + TLogger.Debug('Request: ' + TLogger.RedactJson(RequestBody)); + + if TMCPJsonLimits.NestingDepth(RequestBody) > MaxDepth then + begin + SendJsonRpcError(ResponseInfo, HTTP_STATUS_BAD_REQUEST, JSONRPC_PARSE_ERROR, + Format('JSON nesting exceeds %d levels', [MaxDepth])); + Exit; + end; + + var Outcome: TMCPProcessResult; + var Message := TJSONObject.ParseJSONValue(RequestBody); + try + Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, BuildTransportHints(RequestInfo)); + finally + Message.Free; + end; + + if Outcome.Era = TMCPProtocolEra.Legacy then + EchoLegacySessionId(RequestInfo, ResponseInfo); + + if Outcome.Body = '' then begin - ResponseInfo.ResponseNo := HTTP_NO_CONTENT; + SendEmpty(ResponseInfo, Outcome.HttpStatus); Exit; end; - ResponseInfo.ContentType := 'application/json'; - ResponseInfo.CustomHeaders.Values['Connection'] := 'keep-alive'; + TLogger.Debug('Response: ' + TLogger.RedactJson(Outcome.Body)); + + if (Outcome.HttpStatus = HTTP_STATUS_OK) + and TMCPAcceptHeader.Accepts(HeaderValue(RequestInfo, HEADER_ACCEPT), MEDIA_TYPE_EVENT_STREAM) then + SendSse(ResponseInfo, Outcome.Body) + else + SendJson(ResponseInfo, Outcome.HttpStatus, Outcome.Body); +end; - // Sessions are never minted; an incoming id is echoed back unchanged. - if SessionID <> '' then - ResponseInfo.CustomHeaders.Values['Mcp-Session-Id'] := SessionID; +procedure TMCPIdHTTPServer.SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); +begin + // An assigned, empty stream keeps Indy from writing its default HTML body. + 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 := 'utf-8'; + ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; + ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + ResponseInfo.ContentStream := TStringStream.Create( + SSE_EVENT_PREFIX + 'message' + #10 + SSE_DATA_PREFIX + Body + SSE_MESSAGE_TERMINATOR, TEncoding.UTF8); + ResponseInfo.FreeContentStream := True; +end; + +procedure TMCPIdHTTPServer.SendJsonRpcError(ResponseInfo: TIdHTTPResponseInfo; Status, Code: Integer; const Message: string); +begin + // Transport-level rejections carry an error body without an id. + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', '2.0'); + var Error := TJSONObject.Create; + Response.AddPair('error', Error); + Error.AddPair('code', TJSONNumber.Create(Code)); + Error.AddPair('message', Message); + SendJson(ResponseInfo, Status, Response.ToJSON); + finally + Response.Free; + end; +end; + +procedure TMCPIdHTTPServer.SendMethodNotAllowed(ResponseInfo: TIdHTTPResponseInfo); +begin + ResponseInfo.CustomHeaders.Values['Allow'] := ALLOW_HEADER; + SendEmpty(ResponseInfo, HTTP_METHOD_NOT_ALLOWED); end; -end. \ No newline at end of file +end. diff --git a/tests/MCPServer.Tests.dpr b/tests/MCPServerTests.dpr similarity index 100% rename from tests/MCPServer.Tests.dpr rename to tests/MCPServerTests.dpr diff --git a/tests/MCPServer.Tests.dproj b/tests/MCPServerTests.dproj similarity index 100% rename from tests/MCPServer.Tests.dproj rename to tests/MCPServerTests.dproj From b2e0013cf386f556e1fda639e7f96faa526ad2b4 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:31:38 +0200 Subject: [PATCH 14/56] test: in-process HTTP transport tests and header tests - THttpTransportTests drives TMCPIdHTTPServer on an ephemeral port with TIdHTTP: 202 empty body, 405 with Allow, 204, 404, Origin policy with and without CORS, CORS headers and preflight reflection, status codes per era, Mcp-Method and Mcp-Name validation, 413 and depth limits, session echo for legacy only, SSE without id line, loopback binding, EndpointInfoPath - THttpHeadersTests: sentinel decoding table, Accept parsing, Origin policy, JSON depth scanner - The test program is tests\MCPServerTests.dpr: a dotted program name made the compiler resolve the Indy unit IdHTTPServer as MCPServer.IdHTTPServer - HTTP goldens re-recorded for the new transport, with modern header cases; conformance baselines regenerated (2026-07-28 goes from 87 to 110 passed checks, dns-rebinding-protection passes on both wires) --- build-tests.bat | 26 +- conformance-baseline-2025-11-25.yml | 1 - conformance-baseline-2026-07-28.yml | 1 - scripts/McpServerProcess.ps1 | 1 + scripts/capture-http-goldens.ps1 | 18 +- scripts/run-tests.ps1 | 4 +- tests/MCPServer.Tests.Golden.Modern.pas | 4 +- tests/MCPServer.Tests.Http.pas | 472 ++++++++++++++++++ tests/MCPServer.Tests.HttpHeaders.pas | 161 ++++++ tests/MCPServer.Tests.RequestContext.pas | 47 +- tests/MCPServerTests.dpr | 8 +- tests/MCPServerTests.dproj | 12 +- tests/golden/README.md | 3 +- tests/golden/http/delete-endpoint.txt | 13 +- tests/golden/http/get-endpoint-info.txt | 17 +- tests/golden/http/get-info-path.txt | 11 + tests/golden/http/get-sse-stream.txt | 16 +- tests/golden/http/modern-discover.txt | 7 +- .../http/modern-method-header-mismatch.txt | 11 + .../modern-missing-client-capabilities.txt | 9 +- .../http/modern-missing-method-header.txt | 11 + .../http/modern-missing-version-header.txt | 9 +- tests/golden/http/modern-notification.txt | 9 + .../http/modern-tools-call-name-base64.txt | 11 + tests/golden/http/modern-tools-list.txt | 7 +- tests/golden/http/modern-unknown-method.txt | 11 +- .../http/modern-unsupported-version.txt | 9 +- tests/golden/http/options-preflight.txt | 13 +- .../golden/http/post-batch-notifications.txt | 14 +- tests/golden/http/post-batch-requests.txt | 7 +- tests/golden/http/post-client-response.txt | 10 +- tests/golden/http/post-empty-body.txt | 7 +- tests/golden/http/post-initialize-sse.txt | 10 +- tests/golden/http/post-initialize.txt | 7 +- tests/golden/http/post-no-accept-header.txt | 7 +- .../http/post-notification-initialized.txt | 10 +- tests/golden/http/post-origin-allowed.txt | 8 +- tests/golden/http/post-origin-forbidden.txt | 9 +- tests/golden/http/post-parse-error.txt | 7 +- .../http/post-protocol-version-header.txt | 7 +- tests/golden/http/post-resources-list.txt | 7 +- .../http/post-resources-read-project-info.txt | 7 +- .../http/post-session-echo-lowercase.txt | 7 +- tests/golden/http/post-session-echo.txt | 7 +- tests/golden/http/post-tools-call-echo.txt | 7 +- tests/golden/http/post-tools-list-sse.txt | 10 +- tests/golden/http/post-tools-list.txt | 7 +- tests/golden/http/post-unknown-method.txt | 7 +- tests/golden/http/post-wrong-path.txt | 10 +- tests/golden/http/put-endpoint.txt | 13 +- .../modern/initialize-with-modern-meta.json | 18 +- 51 files changed, 916 insertions(+), 209 deletions(-) create mode 100644 tests/MCPServer.Tests.Http.pas create mode 100644 tests/MCPServer.Tests.HttpHeaders.pas create mode 100644 tests/golden/http/get-info-path.txt create mode 100644 tests/golden/http/modern-method-header-mismatch.txt create mode 100644 tests/golden/http/modern-missing-method-header.txt create mode 100644 tests/golden/http/modern-notification.txt create mode 100644 tests/golden/http/modern-tools-call-name-base64.txt diff --git a/build-tests.bat b/build-tests.bat index a90ce6f..7a59de7 100644 --- a/build-tests.bat +++ b/build-tests.bat @@ -29,17 +29,35 @@ if "%PLATFORM%"=="" set PLATFORM=Win32 set OUTPUT_DIR=.\tests\%PLATFORM%\%CONFIG% if not exist %OUTPUT_DIR% mkdir %OUTPUT_DIR% -set UNIT_PATHS=src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;tests +REM Locate TaurusTLS the same way build.bat does; MCPServer.IdHTTPServer needs it. +for %%i in ("!DELPHI_PATH!") do set STUDIO_VER=%%~nxi +set CATALOG_DIR=%USERPROFILE%\Documents\Embarcadero\Studio\!STUDIO_VER!\CatalogRepository + +if not "%TAURUS_PATH%"=="" goto :TaurusResolved + +for /f "usebackq delims=" %%d in (`powershell -NoProfile -Command "$root = '!CATALOG_DIR!\TaurusTLS'; if (Test-Path $root) { Get-ChildItem $root -Directory ^| Where-Object { Test-Path (Join-Path $_.FullName 'Source') } ^| Sort-Object { try { [version]$_.Name } catch { [version]'0.0' } } ^| Select-Object -Last 1 -ExpandProperty FullName }"`) do set "TAURUS_PATH=%%d\Source" + +if "!TAURUS_PATH!"=="" if exist "!CATALOG_DIR!\TaurusTLS-12\Source" set "TAURUS_PATH=!CATALOG_DIR!\TaurusTLS-12\Source" + +:TaurusResolved +if not "!TAURUS_PATH!"=="" ( + set EXTRA_UNITS=;!TAURUS_PATH! +) else ( + set EXTRA_UNITS= + echo Warning: TaurusTLS not found. The HTTP server unit needs it. +) + +set UNIT_PATHS=src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;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% -I"!DUNITX_PATH!" -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServer.Tests.dpr + !DCC32! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win32\debug";%UNIT_PATHS% -Isrc;!TAURUS_PATH!;"!DUNITX_PATH!" -R!TAURUS_PATH! -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServerTests.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Win64" ( - !DCC64! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win64\debug";%UNIT_PATHS% -I"!DUNITX_PATH!" -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServer.Tests.dpr + !DCC64! -B -H -W -NS%NAMESPACES% -U"!DELPHI_PATH!\lib\Win64\debug";%UNIT_PATHS% -Isrc;!TAURUS_PATH!;"!DUNITX_PATH!" -R!TAURUS_PATH! -E%OUTPUT_DIR% -N0%OUTPUT_DIR% -D%CONFIG% tests\MCPServerTests.dpr goto :CheckBuildResult ) else ( echo ERROR: Invalid platform. Use Win32 or Win64 @@ -59,6 +77,6 @@ if %ERRORLEVEL% neq 0 ( echo. echo Test build completed successfully! -echo Output: %OUTPUT_DIR%\MCPServer.Tests.exe +echo Output: %OUTPUT_DIR%\MCPServerTests.exe endlocal diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml index 39134ce..0d60606 100644 --- a/conformance-baseline-2025-11-25.yml +++ b/conformance-baseline-2025-11-25.yml @@ -22,6 +22,5 @@ server: - prompts-get-with-args - prompts-get-embedded-resource - prompts-get-with-image - - dns-rebinding-protection # only a WARNING check (no session id on the SSE path); the runner counts it as not passed - server-sse-multiple-streams diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index 5caf2bb..2fc79ab 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -16,7 +16,6 @@ server: - prompts-get-with-args - prompts-get-embedded-resource - prompts-get-with-image - - dns-rebinding-protection - caching - input-required-result-basic-elicitation - input-required-result-basic-sampling diff --git a/scripts/McpServerProcess.ps1 b/scripts/McpServerProcess.ps1 index 9a94f10..91d2025 100644 --- a/scripts/McpServerProcess.ps1 +++ b/scripts/McpServerProcess.ps1 @@ -69,6 +69,7 @@ Host=localhost Name=delphi-mcp-server Version=1.0.0 Endpoint=/mcp +EndpointInfoPath=/info [CORS] Enabled=1 diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 index 549e92f..315b920 100644 --- a/scripts/capture-http-goldens.ps1 +++ b/scripts/capture-http-goldens.ps1 @@ -65,6 +65,7 @@ Host=localhost Name=delphi-mcp-server Version=1.0.0 Endpoint=/mcp +EndpointInfoPath=/info [CORS] Enabled=1 @@ -117,12 +118,17 @@ try { $modernMeta = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{},"io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0.0"}}' $cases = @( - @{ Name = 'modern-discover'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":"d1","method":"server/discover","params":{' + $modernMeta + '}}' } - @{ Name = 'modern-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":20,"method":"tools/list","params":{' + $modernMeta + '}}' } - @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":21,"method":"prompts/list","params":{' + $modernMeta + '}}' } - @{ Name = 'modern-missing-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{' + $modernMeta + '}}' } - @{ Name = 'modern-unsupported-version'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 1900-01-01'); Body = '{"jsonrpc":"2.0","id":23,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}' } - @{ Name = 'modern-missing-client-capabilities'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":24,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}' } + @{ Name = 'modern-discover'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: server/discover'); Body = '{"jsonrpc":"2.0","id":"d1","method":"server/discover","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":20,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-tools-call-name-base64'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call', 'Mcp-Name: =?base64?ZWNobw==?='); Body = '{"jsonrpc":"2.0","id":25,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hello modern"},' + $modernMeta + '}}' } + @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: prompts/list'); Body = '{"jsonrpc":"2.0","id":21,"method":"prompts/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-missing-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-missing-method-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-method-header-mismatch'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call'); Body = '{"jsonrpc":"2.0","id":27,"method":"tools/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-unsupported-version'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'MCP-Protocol-Version: 1900-01-01', 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":23,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"1900-01-01","io.modelcontextprotocol/clientCapabilities":{}}}}' } + @{ Name = 'modern-missing-client-capabilities'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":24,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}}}' } + @{ Name = 'modern-notification'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","method":"notifications/initialized"}' } + @{ Name = 'get-info-path'; Method = 'GET'; Headers = @($jsonAccept); Path = '/info' } @{ Name = 'post-initialize'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = $initialize } @{ Name = 'post-initialize-sse'; Method = 'POST'; Headers = @($jsonType, $sseAccept); Body = $initialize } @{ Name = 'post-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' } diff --git a/scripts/run-tests.ps1 b/scripts/run-tests.ps1 index c19ca01..17fe62d 100644 --- a/scripts/run-tests.ps1 +++ b/scripts/run-tests.ps1 @@ -3,7 +3,7 @@ Builds and runs the DUnitX test project. .DESCRIPTION - Compiles tests\MCPServer.Tests.dpr with build-tests.bat and runs the + Compiles tests\MCPServerTests.dpr with build-tests.bat and runs the resulting executable. Results are written as NUnit XML to tests\results. .PARAMETER Configuration @@ -46,7 +46,7 @@ param( $ErrorActionPreference = 'Stop' $repoRoot = Split-Path -Parent $PSScriptRoot -$testExe = Join-Path $repoRoot "tests\$Platform\$Configuration\MCPServer.Tests.exe" +$testExe = Join-Path $repoRoot "tests\$Platform\$Configuration\MCPServerTests.exe" $resultsDir = Join-Path $repoRoot 'tests\results' $xmlFile = Join-Path $resultsDir "dunitx-$Platform-$Configuration.xml" diff --git a/tests/MCPServer.Tests.Golden.Modern.pas b/tests/MCPServer.Tests.Golden.Modern.pas index 645c16e..eae2e0c 100644 --- a/tests/MCPServer.Tests.Golden.Modern.pas +++ b/tests/MCPServer.Tests.Golden.Modern.pas @@ -35,7 +35,7 @@ TModernGoldenTests = class [Test] procedure UnknownProtocolVersion; [Test] procedure MissingClientCapabilities; [Test] procedure InvalidLogLevel; - [Test] procedure Initialize_WithModernMeta_IsLegacy; + [Test] procedure Initialize_WithModernMeta_IsNotFound; [Test] procedure Id_Null; [Test] procedure MissingJsonRpcField; end; @@ -142,7 +142,7 @@ procedure TModernGoldenTests.InvalidLogLevel; CheckGolden('invalid-log-level'); end; -procedure TModernGoldenTests.Initialize_WithModernMeta_IsLegacy; +procedure TModernGoldenTests.Initialize_WithModernMeta_IsNotFound; begin CheckGolden('initialize-with-modern-meta'); end; diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas new file mode 100644 index 0000000..2927189 --- /dev/null +++ b/tests/MCPServer.Tests.Http.pas @@ -0,0 +1,472 @@ +unit MCPServer.Tests.Http; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + IdHTTP, + MCPServer.Settings, + MCPServer.IdHTTPServer, + MCPServer.Tests.Harness; + +type + THttpReply = record + Status: Integer; + Body: string; + ContentLength: Int64; + RawHeaders: string; + function Header(const Name: string): string; + function Json: TJSONObject; + end; + + /// The Streamable HTTP transport, in-process on an ephemeral port. + [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; + end; + +implementation + +uses + MCPServer.Types; + +const + MODERN_VERSION_HEADER = 'MCP-Protocol-Version: 2026-07-28'; + MODERN_META = '"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + LEGACY_PING = '{"jsonrpc":"2.0","id":1,"method":"ping"}'; + +{ THttpReply } + +function THttpReply.Header(const Name: string): string; +begin + var Headers := TStringList.Create; + try + Headers.NameValueSeparator := ':'; + Headers.Text := RawHeaders; + Result := Trim(Headers.Values[Name]); + finally + Headers.Free; + end; +end; + +function THttpReply.Json: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Body) as TJSONObject; + Assert.IsNotNull(Result, 'body is not a JSON object: ' + Body); +end; + +{ 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]; + Http.Request.ContentType := 'application/json'; + Http.Request.Accept := 'application/json'; + for var Header in Headers do + begin + var Separator := Header.IndexOf(':'); + var Name := Header.Substring(0, Separator).Trim; + var Value := Header.Substring(Separator + 1).Trim; + if SameText(Name, 'Accept') then + Http.Request.Accept := Value + else if SameText(Name, 'Content-Type') then + Http.Request.ContentType := Value + else + Http.Request.CustomHeaders.AddValue(Name, Value); + end; + + if Method = 'POST' then + Http.Post(Url(Path), Request, Response) + else if Method = 'GET' then + Http.Get(Url(Path), Response) + else if Method = 'DELETE' then + Http.Delete(Url(Path), Response) + else if Method = 'PUT' then + Http.Put(Url(Path), Request, Response) + else if Method = 'OPTIONS' then + Http.Options(Url(Path), Response) + else + raise Exception.Create('unsupported method ' + Method); + + Result.Status := Http.ResponseCode; + Result.ContentLength := Http.Response.ContentLength; + Result.RawHeaders := Http.Response.RawHeaders.Text; + var Bytes: TBytes; + SetLength(Bytes, Integer(Response.Size)); + if Response.Size > 0 then + Move(Response.Memory^, Bytes[0], Integer(Response.Size)); + Result.Body := TEncoding.UTF8.GetString(Bytes); + finally + Response.Free; + Request.Free; + Http.Free; + end; +end; + +function THttpTransportTests.Post(const Body: string; const Headers: array of string): THttpReply; +begin + Result := Send('POST', '/mcp', Body, Headers); +end; + +procedure THttpTransportTests.Notification_Is202WithEmptyBody; +begin + var Reply := Post('{"jsonrpc":"2.0","method":"notifications/initialized"}', []); + Assert.AreEqual(202, Reply.Status); + Assert.AreEqual('', Reply.Body); + Assert.AreEqual(Int64(0), Reply.ContentLength); +end; + +procedure THttpTransportTests.Get_IsMethodNotAllowedWithAllow; +begin + var Reply := Send('GET', '/mcp', '', ['Accept: text/event-stream']); + Assert.AreEqual(405, Reply.Status); + Assert.AreEqual('POST, OPTIONS', Reply.Header('Allow')); + Assert.AreEqual('', Reply.Body); +end; + +procedure THttpTransportTests.Delete_IsMethodNotAllowed; +begin + Assert.AreEqual(405, Send('DELETE', '/mcp', '', []).Status); + Assert.AreEqual(405, Send('PUT', '/mcp', '{}', []).Status); +end; + +procedure THttpTransportTests.Options_Is204; +begin + var Reply := Send('OPTIONS', '/mcp', '', ['Origin: http://localhost']); + Assert.AreEqual(204, Reply.Status); + Assert.AreEqual('', Reply.Body); +end; + +procedure THttpTransportTests.WrongPath_Is404; +begin + Assert.AreEqual(404, Send('POST', '/other', LEGACY_PING, []).Status); + Assert.AreEqual(404, Send('GET', '/mcp/extra', '', []).Status); +end; + +procedure THttpTransportTests.Origin_NotAllowed_Is403WithJsonRpcBody_EvenWithCorsDisabled; +begin + var Reply := Post(LEGACY_PING, ['Origin: http://evil.example']); + Assert.AreEqual(403, Reply.Status); + Assert.AreEqual('Origin', Reply.Header('Vary')); + var Json := Reply.Json; + try + Assert.AreEqual(JSONRPC_INVALID_REQUEST, Json.GetValue('error.code')); + Assert.IsNull(Json.GetValue('id')); + finally + Json.Free; + end; +end; + +procedure THttpTransportTests.Origin_LoopbackOnAnyPort_IsAllowed; +begin + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: http://127.0.0.1:3000']).Status); + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: http://localhost:5173']).Status); + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: https://localhost']).Status); +end; + +procedure THttpTransportTests.Origin_Null_IsDenied; +begin + Assert.AreEqual(403, Post(LEGACY_PING, ['Origin: null']).Status); +end; + +procedure THttpTransportTests.Origin_AllowListWithPortWildcard; +begin + FSettings.SecurityAllowedOrigins := 'https://app.example:*'; + Assert.AreEqual(200, Post(LEGACY_PING, ['Origin: https://app.example:8443']).Status); + Assert.AreEqual(403, Post(LEGACY_PING, ['Origin: https://other.example']).Status); +end; + +procedure THttpTransportTests.Cors_HeadersOnlyWhenEnabled; +begin + var Disabled := Post(LEGACY_PING, ['Origin: http://localhost']); + Assert.AreEqual('', Disabled.Header('Access-Control-Allow-Origin')); + + FServer.Stop; + FSettings.CorsEnabled := True; + var Enabled := Post(LEGACY_PING, ['Origin: http://localhost']); + Assert.AreEqual(200, Enabled.Status); + Assert.AreEqual('http://localhost', Enabled.Header('Access-Control-Allow-Origin')); + Assert.AreEqual('POST, OPTIONS', Enabled.Header('Access-Control-Allow-Methods')); + Assert.IsTrue(Enabled.Header('Access-Control-Allow-Headers').Contains('Mcp-Method')); + Assert.IsTrue(Enabled.Header('Access-Control-Expose-Headers').Contains('WWW-Authenticate')); +end; + +procedure THttpTransportTests.Cors_PreflightReflectsRequestedHeaders; +begin + FSettings.CorsEnabled := True; + var Reply := Send('OPTIONS', '/mcp', '', ['Origin: http://localhost', + 'Access-Control-Request-Method: POST', 'Access-Control-Request-Headers: Mcp-Param-Region, X-Trace']); + Assert.AreEqual(204, Reply.Status); + var AllowHeaders := Reply.Header('Access-Control-Allow-Headers'); + Assert.IsTrue(AllowHeaders.Contains('Mcp-Param-Region'), AllowHeaders); + Assert.IsTrue(AllowHeaders.Contains('X-Trace'), AllowHeaders); +end; + +procedure THttpTransportTests.Legacy_UnknownMethod_Is200; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"prompts/list"}', ['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":"prompts/list","params":{' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: prompts/list']); + 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); + // Indy reports the IPv6 loopback in its expanded form. + 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; + +initialization + TDUnitX.RegisterTestFixture(THttpTransportTests); + +end. diff --git a/tests/MCPServer.Tests.HttpHeaders.pas b/tests/MCPServer.Tests.HttpHeaders.pas new file mode 100644 index 0000000..253ca9b --- /dev/null +++ b/tests/MCPServer.Tests.HttpHeaders.pas @@ -0,0 +1,161 @@ +unit MCPServer.Tests.HttpHeaders; + +interface + +uses + DUnitX.TestFramework; + +type + /// Header value decoding (Base64 sentinel), Accept parsing, Origin policy + /// and the JSON depth scanner. + [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 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.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; + +initialization + TDUnitX.RegisterTestFixture(THttpHeadersTests); + +end. diff --git a/tests/MCPServer.Tests.RequestContext.pas b/tests/MCPServer.Tests.RequestContext.pas index 82357a2..3242250 100644 --- a/tests/MCPServer.Tests.RequestContext.pas +++ b/tests/MCPServer.Tests.RequestContext.pas @@ -30,13 +30,14 @@ TRequestContextTests = class [TearDown] procedure TearDown; - [Test] procedure Initialize_IsLegacy_EvenWithModernMeta; + [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; @@ -122,10 +123,14 @@ procedure TRequestContextTests.ExpectError(const RequestJson: string; const Hint end; end; -procedure TRequestContextTests.Initialize_IsLegacy_EvenWithModernMeta; +procedure TRequestContextTests.Initialize_WithModernMeta_IsNotFound; begin - var Context := Build(Request('initialize', '{"protocolVersion":"2025-11-25",' + META_MODERN + '}'), TMCPTransportHints.None); + // A modern client probing with initialize must learn that the method does + // not exist in its era; only an initialize without modern _meta is legacy. + 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; @@ -169,8 +174,42 @@ procedure TRequestContextTests.ModernMeta_Http_HeaderDiffers_IsHeaderMismatch; procedure TRequestContextTests.ModernMeta_Http_HeaderMatches_IsModern; begin - var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), TMCPTransportHints.ForHttp(True, '2026-07-28')); + 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); + + // The mirrored method header is compared case-sensitively. + 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'); + + // "file:///café.txt" as UTF-8 in the Base64 sentinel form. + 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; diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index deeae9b..817f35f 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -1,4 +1,4 @@ -program MCPServer.Tests; +program MCPServerTests; {$APPTYPE CONSOLE} {$STRONGLINKTYPES ON} @@ -12,6 +12,8 @@ uses 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.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.Logger in '..\src\Core\MCPServer.Logger.pas', @@ -45,7 +47,9 @@ uses 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.Golden.Modern in 'MCPServer.Tests.Golden.Modern.pas', + MCPServer.Tests.HttpHeaders in 'MCPServer.Tests.HttpHeaders.pas', + MCPServer.Tests.Http in 'MCPServer.Tests.Http.pas'; procedure RunTests; begin diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index efde742..5229059 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -1,14 +1,14 @@ {5C1E6B2A-7D4F-4E8B-9A3C-2F1D0E9B8C7A} - MCPServer.Tests.dpr + MCPServerTests.dpr True Debug 3 Console 20.3 Win32 - MCPServer.Tests + MCPServerTests None @@ -43,7 +43,7 @@ false false false - MCPServer_Tests + MCPServerTests true ..\src;..\src\Managers;..\src\Server;..\src\Tools;..\src\Core;..\src\Protocol;..\src\Libraries;..\src\Resources;$(DUnitX);$(BDS)\source\DUnitX;$(DCC_UnitSearchPath) @@ -76,6 +76,8 @@ + + @@ -107,6 +109,8 @@ + + Base @@ -125,7 +129,7 @@ - MCPServer.Tests.dpr + MCPServerTests.dpr diff --git a/tests/golden/README.md b/tests/golden/README.md index 680b7d0..6a1d565 100644 --- a/tests/golden/README.md +++ b/tests/golden/README.md @@ -46,7 +46,8 @@ formatted `expected` value, so key order and array order matter. ## Recording procedure -1. `build.bat Debug Win64` and `build-tests.bat Debug Win64`. +1. `build.bat Debug Win64` and `build-tests.bat Debug Win64` (the test + program is `tests\MCPServerTests.dpr`). 2. `.\scripts\run-tests.ps1 -Record -NoBuild` rewrites the `expected` sections in `legacy/`. Use `-Filter` with the fully qualified test names to re-record single cases. diff --git a/tests/golden/http/delete-endpoint.txt b/tests/golden/http/delete-endpoint.txt index 5b1f9c2..184a6fb 100644 --- a/tests/golden/http/delete-endpoint.txt +++ b/tests/golden/http/delete-endpoint.txt @@ -1,11 +1,10 @@ -HTTP/1.1 405 Method Not Allowed +HTTP/1.1 405 Method not allowed Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 55 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -405 Method Not Allowed +Allow: POST, OPTIONS diff --git a/tests/golden/http/get-endpoint-info.txt b/tests/golden/http/get-endpoint-info.txt index 0f69064..184a6fb 100644 --- a/tests/golden/http/get-endpoint-info.txt +++ b/tests/golden/http/get-endpoint-info.txt @@ -1,13 +1,10 @@ -HTTP/1.1 200 OK +HTTP/1.1 405 Method not allowed Connection: keep-alive -Content-Type: application/json -Content-Length: 57 +Content-Type: text/html; charset=utf-8 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Cache-Control: no-cache -Connection: keep-alive - -{"url": "http://localhost:3939/mcp", "transport": "http"} +Allow: POST, OPTIONS diff --git a/tests/golden/http/get-info-path.txt b/tests/golden/http/get-info-path.txt new file mode 100644 index 0000000..9b6de65 --- /dev/null +++ b/tests/golden/http/get-info-path.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 125 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"url":"http://localhost:3939/mcp","transport":"streamable-http","protocolVersions":["2026-07-28","2025-11-25","2025-06-18"]} diff --git a/tests/golden/http/get-sse-stream.txt b/tests/golden/http/get-sse-stream.txt index 10d7054..184a6fb 100644 --- a/tests/golden/http/get-sse-stream.txt +++ b/tests/golden/http/get-sse-stream.txt @@ -1,14 +1,10 @@ -HTTP/1.1 200 OK +HTTP/1.1 405 Method not allowed Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 39 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Cache-Control: no-cache -Connection: keep-alive -X-Accel-Buffering: no - -200 OK +Allow: POST, OPTIONS diff --git a/tests/golden/http/modern-discover.txt b/tests/golden/http/modern-discover.txt index e2d6942..f14cf4a 100644 --- a/tests/golden/http/modern-discover.txt +++ b/tests/golden/http/modern-discover.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 322 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} diff --git a/tests/golden/http/modern-method-header-mismatch.txt b/tests/golden/http/modern-method-header-mismatch.txt new file mode 100644 index 0000000..ea1d2a1 --- /dev/null +++ b/tests/golden/http/modern-method-header-mismatch.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 154 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":27,"error":{"code":-32020,"message":"Header mismatch: Mcp-Method header value 'tools/call' does not match body value 'tools/list'"}} diff --git a/tests/golden/http/modern-missing-client-capabilities.txt b/tests/golden/http/modern-missing-client-capabilities.txt index c82e75a..f6abb7e 100644 --- a/tests/golden/http/modern-missing-client-capabilities.txt +++ b/tests/golden/http/modern-missing-client-capabilities.txt @@ -1,12 +1,11 @@ -HTTP/1.1 200 OK +HTTP/1.1 400 Bad Request Connection: keep-alive Content-Type: application/json Content-Length: 151 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":24,"error":{"code":-32602,"message":"params._meta.io.modelcontextprotocol/clientCapabilities is required and must be an object"}} diff --git a/tests/golden/http/modern-missing-method-header.txt b/tests/golden/http/modern-missing-method-header.txt new file mode 100644 index 0000000..b5d09ee --- /dev/null +++ b/tests/golden/http/modern-missing-method-header.txt @@ -0,0 +1,11 @@ +HTTP/1.1 400 Bad Request +Connection: keep-alive +Content-Type: application/json +Content-Length: 90 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":26,"error":{"code":-32020,"message":"Mcp-Method header is missing"}} diff --git a/tests/golden/http/modern-missing-version-header.txt b/tests/golden/http/modern-missing-version-header.txt index 825eb74..d8c9799 100644 --- a/tests/golden/http/modern-missing-version-header.txt +++ b/tests/golden/http/modern-missing-version-header.txt @@ -1,12 +1,11 @@ -HTTP/1.1 200 OK +HTTP/1.1 400 Bad Request Connection: keep-alive Content-Type: application/json Content-Length: 100 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":22,"error":{"code":-32020,"message":"MCP-Protocol-Version header is missing"}} diff --git a/tests/golden/http/modern-notification.txt b/tests/golden/http/modern-notification.txt new file mode 100644 index 0000000..99f580f --- /dev/null +++ b/tests/golden/http/modern-notification.txt @@ -0,0 +1,9 @@ +HTTP/1.1 202 Accepted +Connection: keep-alive +Content-Type: text/html; charset=utf-8 +Content-Length: 0 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 diff --git a/tests/golden/http/modern-tools-call-name-base64.txt b/tests/golden/http/modern-tools-call-name-base64.txt new file mode 100644 index 0000000..3ceae2e --- /dev/null +++ b/tests/golden/http/modern-tools-call-name-base64.txt @@ -0,0 +1,11 @@ +HTTP/1.1 200 OK +Connection: keep-alive +Content-Type: application/json +Content-Length: 210 +Access-Control-Allow-Origin: * +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate +Access-Control-Max-Age: 86400 + +{"jsonrpc":"2.0","id":25,"result":{"content":[{"type":"text","text":"Echo: hello modern"}],"resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 0808def..0212436 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 1208 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}],"resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"private"}} diff --git a/tests/golden/http/modern-unknown-method.txt b/tests/golden/http/modern-unknown-method.txt index 226cb60..d0d4aa4 100644 --- a/tests/golden/http/modern-unknown-method.txt +++ b/tests/golden/http/modern-unknown-method.txt @@ -1,12 +1,11 @@ -HTTP/1.1 200 OK -Connection: keep-alive +HTTP/1.1 404 Not Found +Connection: close Content-Type: application/json Content-Length: 141 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":21,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/modern-unsupported-version.txt b/tests/golden/http/modern-unsupported-version.txt index 174f76b..7c4d0fa 100644 --- a/tests/golden/http/modern-unsupported-version.txt +++ b/tests/golden/http/modern-unsupported-version.txt @@ -1,12 +1,11 @@ -HTTP/1.1 200 OK +HTTP/1.1 400 Bad Request Connection: keep-alive Content-Type: application/json Content-Length: 151 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":23,"error":{"code":-32022,"message":"Unsupported protocol version","data":{"supported":["2026-07-28"],"requested":"1900-01-01"}}} diff --git a/tests/golden/http/options-preflight.txt b/tests/golden/http/options-preflight.txt index ec8d22c..48bd820 100644 --- a/tests/golden/http/options-preflight.txt +++ b/tests/golden/http/options-preflight.txt @@ -1,11 +1,10 @@ -HTTP/1.1 200 OK +HTTP/1.1 204 No Content Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 39 +Content-Length: 0 +Vary: Origin Access-Control-Allow-Origin: http://localhost -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -200 OK diff --git a/tests/golden/http/post-batch-notifications.txt b/tests/golden/http/post-batch-notifications.txt index cc7546b..9cff322 100644 --- a/tests/golden/http/post-batch-notifications.txt +++ b/tests/golden/http/post-batch-notifications.txt @@ -1,11 +1,11 @@ -HTTP/1.1 202 Accepted +HTTP/1.1 200 OK Connection: keep-alive -Content-Type: text/html; charset=utf-8 -Content-Length: 45 +Content-Type: application/json +Content-Length: 105 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -202 Accepted +{"jsonrpc":"2.0","id":null,"error":{"code":-32600,"message":"JSON-RPC batch requests are not supported"}} diff --git a/tests/golden/http/post-batch-requests.txt b/tests/golden/http/post-batch-requests.txt index 56df616..9cff322 100644 --- a/tests/golden/http/post-batch-requests.txt +++ b/tests/golden/http/post-batch-requests.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 105 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":null,"error":{"code":-32600,"message":"JSON-RPC batch requests are not supported"}} diff --git a/tests/golden/http/post-client-response.txt b/tests/golden/http/post-client-response.txt index cc7546b..99f580f 100644 --- a/tests/golden/http/post-client-response.txt +++ b/tests/golden/http/post-client-response.txt @@ -1,11 +1,9 @@ HTTP/1.1 202 Accepted Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 45 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -202 Accepted diff --git a/tests/golden/http/post-empty-body.txt b/tests/golden/http/post-empty-body.txt index 22f9e0f..7fb9986 100644 --- a/tests/golden/http/post-empty-body.txt +++ b/tests/golden/http/post-empty-body.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 76 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt index 1dc5400..69c3b1b 100644 --- a/tests/golden/http/post-initialize-sse.txt +++ b/tests/golden/http/post-initialize-sse.txt @@ -1,16 +1,14 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 254 +Content-Length: 248 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 Cache-Control: no-cache -Connection: keep-alive X-Accel-Buffering: no -id: event: message data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-initialize.txt b/tests/golden/http/post-initialize.txt index b0e39c6..3f1cc05 100644 --- a/tests/golden/http/post-initialize.txt +++ b/tests/golden/http/post-initialize.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 225 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-no-accept-header.txt b/tests/golden/http/post-no-accept-header.txt index 2ae6ded..7517a9c 100644 --- a/tests/golden/http/post-no-accept-header.txt +++ b/tests/golden/http/post-no-accept-header.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 36 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":9,"result":{}} diff --git a/tests/golden/http/post-notification-initialized.txt b/tests/golden/http/post-notification-initialized.txt index cc7546b..99f580f 100644 --- a/tests/golden/http/post-notification-initialized.txt +++ b/tests/golden/http/post-notification-initialized.txt @@ -1,11 +1,9 @@ HTTP/1.1 202 Accepted Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 45 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -202 Accepted diff --git a/tests/golden/http/post-origin-allowed.txt b/tests/golden/http/post-origin-allowed.txt index 6a33cf7..5305fd4 100644 --- a/tests/golden/http/post-origin-allowed.txt +++ b/tests/golden/http/post-origin-allowed.txt @@ -2,11 +2,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json Content-Length: 37 +Vary: Origin Access-Control-Allow-Origin: http://localhost -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":13,"result":{}} diff --git a/tests/golden/http/post-origin-forbidden.txt b/tests/golden/http/post-origin-forbidden.txt index 33a8934..9577b99 100644 --- a/tests/golden/http/post-origin-forbidden.txt +++ b/tests/golden/http/post-origin-forbidden.txt @@ -1,6 +1,7 @@ -HTTP/1.1 403 Forbidden - Origin not allowed +HTTP/1.1 403 Forbidden Connection: keep-alive -Content-Type: text/html; charset=utf-8 -Content-Length: 67 +Content-Type: application/json +Content-Length: 72 +Vary: Origin -403 Forbidden - Origin not allowed +{"jsonrpc":"2.0","error":{"code":-32600,"message":"Origin not allowed"}} diff --git a/tests/golden/http/post-parse-error.txt b/tests/golden/http/post-parse-error.txt index 22f9e0f..7fb9986 100644 --- a/tests/golden/http/post-parse-error.txt +++ b/tests/golden/http/post-parse-error.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 76 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":null,"error":{"code":-32700,"message":"Invalid JSON"}} diff --git a/tests/golden/http/post-protocol-version-header.txt b/tests/golden/http/post-protocol-version-header.txt index 3887969..cf65117 100644 --- a/tests/golden/http/post-protocol-version-header.txt +++ b/tests/golden/http/post-protocol-version-header.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 37 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":12,"result":{}} diff --git a/tests/golden/http/post-resources-list.txt b/tests/golden/http/post-resources-list.txt index 130f0cc..a562dd9 100644 --- a/tests/golden/http/post-resources-list.txt +++ b/tests/golden/http/post-resources-list.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 591 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"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":"server://status","name":"server_status","description":"Current server status and health information","mimeType":"application/json"}]}} diff --git a/tests/golden/http/post-resources-read-project-info.txt b/tests/golden/http/post-resources-read-project-info.txt index 4bb1090..8896ccc 100644 --- a/tests/golden/http/post-resources-read-project-info.txt +++ b/tests/golden/http/post-resources-read-project-info.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 590 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"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 2025-06-18\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}"}]}} diff --git a/tests/golden/http/post-session-echo-lowercase.txt b/tests/golden/http/post-session-echo-lowercase.txt index 06753ef..8b64f28 100644 --- a/tests/golden/http/post-session-echo-lowercase.txt +++ b/tests/golden/http/post-session-echo-lowercase.txt @@ -3,11 +3,10 @@ Connection: keep-alive Content-Type: application/json Content-Length: 37 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive Mcp-Session-Id: golden-session-2 {"jsonrpc":"2.0","id":11,"result":{}} diff --git a/tests/golden/http/post-session-echo.txt b/tests/golden/http/post-session-echo.txt index 5c93ed2..24f3dc0 100644 --- a/tests/golden/http/post-session-echo.txt +++ b/tests/golden/http/post-session-echo.txt @@ -3,11 +3,10 @@ Connection: keep-alive Content-Type: application/json Content-Length: 37 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive Mcp-Session-Id: golden-session-1 {"jsonrpc":"2.0","id":10,"result":{}} diff --git a/tests/golden/http/post-tools-call-echo.txt b/tests/golden/http/post-tools-call-echo.txt index 63a3da0..57b6862 100644 --- a/tests/golden/http/post-tools-call-echo.txt +++ b/tests/golden/http/post-tools-call-echo.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 91 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":3,"result":{"content":[{"type":"text","text":"Echo: hello golden"}]}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 11ec540..fbd2127 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,16 +1,14 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 1085 +Content-Length: 1079 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 Cache-Control: no-cache -Connection: keep-alive X-Accel-Buffering: no -id: event: message data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index 9e42b4b..3d5c72e 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 1056 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} diff --git a/tests/golden/http/post-unknown-method.txt b/tests/golden/http/post-unknown-method.txt index 7976d79..e2bae1a 100644 --- a/tests/golden/http/post-unknown-method.txt +++ b/tests/golden/http/post-unknown-method.txt @@ -3,10 +3,9 @@ Connection: keep-alive Content-Type: application/json Content-Length: 140 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -Connection: keep-alive {"jsonrpc":"2.0","id":7,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/post-wrong-path.txt b/tests/golden/http/post-wrong-path.txt index ac68fc0..6246a40 100644 --- a/tests/golden/http/post-wrong-path.txt +++ b/tests/golden/http/post-wrong-path.txt @@ -1,11 +1,9 @@ HTTP/1.1 404 Not Found Connection: close Content-Type: text/html; charset=utf-8 -Content-Length: 46 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -404 Not Found diff --git a/tests/golden/http/put-endpoint.txt b/tests/golden/http/put-endpoint.txt index 5b1f9c2..184a6fb 100644 --- a/tests/golden/http/put-endpoint.txt +++ b/tests/golden/http/put-endpoint.txt @@ -1,11 +1,10 @@ -HTTP/1.1 405 Method Not Allowed +HTTP/1.1 405 Method not allowed Connection: keep-alive Content-Type: text/html; charset=utf-8 -Content-Length: 55 +Content-Length: 0 Access-Control-Allow-Origin: * -Access-Control-Allow-Methods: POST, GET, OPTIONS -Access-Control-Allow-Headers: Accept, Content-Type, Last-Event-ID, Mcp-Protocol-Version, Mcp-Session-Id -Access-Control-Expose-Headers: Mcp-Session-Id +Access-Control-Allow-Methods: POST, OPTIONS +Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID +Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 - -405 Method Not Allowed +Allow: POST, OPTIONS diff --git a/tests/golden/modern/initialize-with-modern-meta.json b/tests/golden/modern/initialize-with-modern-meta.json index e8d7500..80489ce 100644 --- a/tests/golden/modern/initialize-with-modern-meta.json +++ b/tests/golden/modern/initialize-with-modern-meta.json @@ -25,21 +25,9 @@ "expected": { "jsonrpc": "2.0", "id": 12, - "result": { - "protocolVersion": "2025-11-25", - "capabilities": { - "tools": { - "listChanged": false - }, - "resources": { - "subscribe": false, - "listChanged": false - } - }, - "serverInfo": { - "name": "delphi-mcp-server", - "version": "1.0.0" - } + "error": { + "code": -32601, + "message": "Method [initialize] not found. The method does not exist or is not available." } } } From 77742edfe3512dd30dfb0f7f02e804f80fd3b027 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:31:39 +0200 Subject: [PATCH 15/56] docs: migration notes and the network settings MIGRATION.md lists every behaviour change with what to configure; README gains the network and security settings and the HTTP status rules; CHANGELOG entries for the transport. --- CHANGELOG.md | 43 +++++++++++++++++++++++++++++++++- MIGRATION.md | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 18 +++++++++++---- 3 files changed, 121 insertions(+), 5 deletions(-) create mode 100644 MIGRATION.md diff --git a/CHANGELOG.md b/CHANGELOG.md index ef0ce14..ae6c690 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,23 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### Added +- 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 @@ -35,7 +52,7 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). - `settings.ini`: `[Server] Title`, `Description`, `WebsiteUrl`, `Instructions`; `[Protocol] LenientModernPing`, `DiscoverListsLegacyVersions`, `DiscoverTtlMs`. -- DUnitX test project `tests\MCPServer.Tests.dpr` (Win32 and Win64) with an +- 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. @@ -66,6 +83,30 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### Changed +- 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 diff --git a/MIGRATION.md b/MIGRATION.md new file mode 100644 index 0000000..364dcd6 --- /dev/null +++ b/MIGRATION.md @@ -0,0 +1,65 @@ +# 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. + +**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. + +## Library use + +- `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are + unchanged. `ProcessRequestEx` returns the HTTP status your own transport + should answer with. +- `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 5fd2d1a..544dbd4 100644 --- a/README.md +++ b/README.md @@ -33,7 +33,7 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte - **Dual Response Mode**: Supports both JSON-RPC and Server-Sent Events in the same server - **Tool System**: Extensible tool system with RTTI-based discovery and execution - **Resource Management**: Modular resource system supporting various content types -- **Security**: Built-in security features including CORS configuration +- **Security**: `Origin` validation against DNS rebinding on every request, loopback binding by default, CORS headers for browser clients, request size and nesting limits - **High Performance**: Native implementation using Indy HTTP Server with keep-alive support - **Optional Parameters**: Support for optional tool parameters using custom attributes - **Cross-Platform**: Supports Windows (Win32/Win64) and Linux (x64) @@ -136,13 +136,15 @@ The server decides per request which protocol era it is speaking; nothing is neg | Request | Era | Served as | |---|---|---| -| `initialize` | 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. | -| `params._meta` with `io.modelcontextprotocol/protocolVersion` | modern | `2026-07-28`. `clientCapabilities` is required (`-32602`); an unknown revision gets `-32022` with the supported list; `ping`, `logging/setLevel` and `resources/subscribe` do not exist in this era (`-32601`). | +| `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`. @@ -482,6 +484,14 @@ The server provides four resources accessible via URIs: The server supports configuration through `settings.ini` files. A default `settings.ini.example` is provided in the repository. +### 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. +- `[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: @@ -594,7 +604,7 @@ We welcome contributions! Here's how to help: The `tests` folder holds a DUnitX project that drives the JSON-RPC layer in-process and pins the wire behaviour with golden files (`tests\golden`, see the README there). The scripts under `scripts` wrap the build and the external tooling; the Node tools are pinned in `package.json`. ```powershell -.\scripts\run-tests.ps1 # build tests\MCPServer.Tests.dpr (Win64 Debug) and run it +.\scripts\run-tests.ps1 # build tests\MCPServerTests.dpr (Win64 Debug) and run it .\scripts\run-tests.ps1 -Platform Win32 .\scripts\capture-http-goldens.ps1 # replay the HTTP golden cases with curl against Win64\Debug\MCPServer.exe .\scripts\run-stdio-smoke.ps1 # drive --stdio and check the framing of stdout/stderr From 3450987ba2845694de2d49d0e11ccbfa93e69d4b Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:55 +0200 Subject: [PATCH 16/56] feat: tool result builder and tool/resource metadata TMCPToolResult builds text, image, audio, embedded resource and resource link content blocks with structuredContent, _meta and isError. TMCPToolBase gains ExecuteWithContext next to ExecuteWithParams and EMCPToolError for failures reported as isError. Tools publish annotations and icons (IMCPToolMetadata); resources publish title, size, annotations (IMCPResourceMetadata), blob contents (IMCPBinaryResource) and cache hints (IMCPCacheableResource). New schema attributes SchemaTitle, SchemaFormat, SchemaMinimum and SchemaMaximum; EMCPError.UnknownTool and EMCPError.ResourceNotFound carry data.name and data.uri. --- src/Protocol/MCPServer.Errors.pas | 32 ++- src/Protocol/MCPServer.Types.pas | 112 ++++++++++ src/Resources/MCPServer.Resource.Base.pas | 60 +++++- src/Tools/MCPServer.Tool.Base.pas | 153 +++++++++++--- src/Tools/MCPServer.Tool.Result.pas | 241 ++++++++++++++++++++++ 5 files changed, 562 insertions(+), 36 deletions(-) create mode 100644 src/Tools/MCPServer.Tool.Result.pas diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index 17f1317..c873b2d 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -4,7 +4,8 @@ interface uses System.SysUtils, - System.JSON; + System.JSON, + MCPServer.Types; type /// A JSON-RPC error a handler or the processor wants to send back. @@ -36,12 +37,21 @@ EMCPError = class(Exception) class function MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; /// -32022 (HTTP 400): the requested revision is not served. class function UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; + /// -32602 with data.name: tools/call names a tool the server does not have. + class function UnknownTool(const Name: string): EMCPError; + /// Resource not found with data.uri: -32602 in the modern era, -32002 in + /// the initialize-based revisions. + class function ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; property Code: Integer read FCode; property Data: TJSONValue read FData; property HttpStatus: Integer read FHttpStatus write FHttpStatus; end; + /// Raised by a tool to report a tool execution error: the message becomes + /// an isError result that the model can act on, not a protocol error. + EMCPToolError = class(Exception); + const HTTP_STATUS_OK = 200; HTTP_STATUS_ACCEPTED = 202; @@ -50,9 +60,6 @@ EMCPError = class(Exception) implementation -uses - MCPServer.Types; - { EMCPError } constructor EMCPError.Create(ACode: Integer; const AMessage: string; AData: TJSONValue; AHttpStatus: Integer); @@ -128,4 +135,21 @@ class function EMCPError.UnsupportedProtocolVersion(const Requested: string; con 'Unsupported protocol version', Data, HTTP_STATUS_BAD_REQUEST); end; +class function EMCPError.UnknownTool(const Name: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('name', Name); + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown tool: ' + Name, Data); +end; + +class function EMCPError.ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('uri', Uri); + if Era = TMCPProtocolEra.Modern then + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Resource not found', Data) + else + Result := EMCPError.Create(MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY, 'Resource not found', Data); +end; + end. diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 5620b16..e4dd616 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -54,6 +54,10 @@ interface MCP_META_SUBSCRIPTION_ID = 'io.modelcontextprotocol/subscriptionId'; MCP_META_PROGRESS_TOKEN = 'progressToken'; + // Cache scopes (server/utilities/caching.mdx) + MCP_CACHE_SCOPE_PUBLIC = 'public'; + MCP_CACHE_SCOPE_PRIVATE = 'private'; + /// Methods whose complete results must carry ttlMs and cacheScope /// (server/utilities/caching.mdx, "Cacheable Results"). MCP_CACHEABLE_METHODS: array[0..5] of string = ( @@ -83,6 +87,42 @@ SchemaDescriptionAttribute = class(TCustomAttribute) property Description: string read FDescription; end; + /// Human-readable title of a parameter (JSON Schema "title"). + SchemaTitleAttribute = class(TCustomAttribute) + private + FTitle: string; + public + constructor Create(const ATitle: string); + property Title: string read FTitle; + end; + + /// JSON Schema "format" of a string parameter, for example 'date-time' or 'uri'. + SchemaFormatAttribute = class(TCustomAttribute) + private + FFormat: string; + public + constructor Create(const AFormat: string); + property Format: string read FFormat; + end; + + /// JSON Schema "minimum" of a numeric parameter. + SchemaMinimumAttribute = class(TCustomAttribute) + private + FMinimum: Double; + public + constructor Create(const AMinimum: Double); + property Minimum: Double read FMinimum; + end; + + /// JSON Schema "maximum" of a numeric parameter. + SchemaMaximumAttribute = class(TCustomAttribute) + private + FMaximum: Double; + public + constructor Create(const AMaximum: Double); + property Maximum: Double read FMaximum; + end; + SchemaEnumAttribute = class(TCustomAttribute) private FValues: TArray; @@ -214,6 +254,46 @@ TMCPLegacySession = class procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); end; + /// Optional tool metadata for tools/list: annotations (readOnlyHint and + /// friends) and icons. Both may be nil. The tool keeps ownership. + IMCPToolMetadata = interface + ['{D2E4F6A8-1B3C-4D5E-9F0A-2B3C4D5E6F70}'] + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; + property Annotations: TJSONObject read GetAnnotations; + property Icons: TJSONArray read GetIcons; + end; + + /// Resources whose contents are bytes rather than text; resources/read + /// answers with a Base64 "blob" instead of "text". + IMCPBinaryResource = interface + ['{E3F5A7B9-2C4D-4E6F-A0B1-3C4D5E6F7081}'] + function ReadBinary: TBytes; + end; + + /// Optional resource metadata for resources/list: title, size in bytes + /// (-1 when unknown) and annotations (may be nil, the resource keeps ownership). + 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; + + /// Cache hints a resource attaches to its resources/read result in the + /// modern era: ttlMs (milliseconds, 0 = immediately stale) and cacheScope + /// ('public' or 'private'). + IMCPCacheableResource = interface + ['{05B7C9DB-4E6F-4081-C2D3-5E6F708192A3}'] + function GetTtlMs: Integer; + function GetCacheScope: string; + property TtlMs: Integer read GetTtlMs; + property CacheScope: string read GetCacheScope; + end; + TMCPCapabilities = class private FTools: TMCPToolsCapability; @@ -384,6 +464,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); diff --git a/src/Resources/MCPServer.Resource.Base.pas b/src/Resources/MCPServer.Resource.Base.pas index 09aa327..8dea987 100644 --- a/src/Resources/MCPServer.Resource.Base.pas +++ b/src/Resources/MCPServer.Resource.Base.pas @@ -5,7 +5,8 @@ interface uses System.SysUtils, System.Rtti, - System.JSON; + System.JSON, + MCPServer.Types; type IMCPResource = interface @@ -15,28 +16,46 @@ 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) + + /// Resource whose data is a class T serialised as JSON (mime type + /// application/json) or, for other mime types, the string in T's Content + /// property. + /// + /// The protected fields FTitle, FSize (-1 = unknown), FAnnotations (nil), + /// FTtlMs (0) and FCacheScope ('private') have safe defaults; set them in + /// the constructor of a descendant. + 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; @@ -61,10 +80,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 +111,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 +181,4 @@ function TMCPResourceBase.Read: string; end; end; -end. \ No newline at end of file +end. diff --git a/src/Tools/MCPServer.Tool.Base.pas b/src/Tools/MCPServer.Tool.Base.pas index cda7484..a53cf03 100644 --- a/src/Tools/MCPServer.Tool.Base.pas +++ b/src/Tools/MCPServer.Tool.Base.pas @@ -5,7 +5,8 @@ interface uses System.SysUtils, System.Rtti, - System.JSON; + System.JSON, + MCPServer.Types; type IMCPTool = interface @@ -15,6 +16,9 @@ interface function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; + /// Returns a string (one text block), a TJSONObject (structured content), + /// a TJSONArray (content blocks) or a TMCPToolResult. The tools manager + /// takes ownership of objects. function Execute(const Arguments: TJSONObject): TValue; property Name: string read GetName; @@ -24,66 +28,93 @@ interface property OutputSchema: TJSONObject read GetOutputSchema; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + /// Tool with a hand-written schema and raw JSON arguments. + /// + /// The protected fields FAnnotations and FIcons (nil by default) are + /// reported in tools/list when set; the tool owns them. + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; + FAnnotations: TJSONObject; + FIcons: TJSONArray; function BuildSchema: TJSONObject; 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 GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; function Execute(const Arguments: TJSONObject): TValue; virtual; abstract; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + /// Tool whose parameters are a class T; the schema comes from T's RTTI. + /// + /// Override ExecuteWithParams for a text result, or ExecuteWithContext for + /// any other result (TMCPToolResult, structured content) and access to the + /// request context. The default ExecuteWithContext calls ExecuteWithParams. + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; - function ExecuteWithParams(const Params: T): string;virtual; abstract; + FAnnotations: TJSONObject; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T): string; virtual; + function ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; virtual; function GetParamsClass: TClass; virtual; public constructor Create; virtual; + destructor Destroy; override; function GetName: string; function GetTitle: string; function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; function Execute(const Arguments: TJSONObject): TValue; end; - TMCPToolBase = class(TInterfacedObject, IMCPTool) + /// Tool with parameters T and a typed result R that is serialised as + /// structured content (with the compact JSON as text for older clients). + TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; FTitle: string; FDescription: string; - function ExecuteWithParams(const Params: T): R;virtual; abstract; + FAnnotations: TJSONObject; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T): R; virtual; + function ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; virtual; public constructor Create; virtual; + destructor Destroy; override; function GetName: string; function GetTitle: string; function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; + function GetAnnotations: TJSONObject; + function GetIcons: TJSONArray; function Execute(const Arguments: TJSONObject): TValue; end; - - - implementation uses MCPServer.Schema.Generator, - MCPServer.Serializer; + MCPServer.Serializer, + MCPServer.RequestContext, + MCPServer.Tool.Result; { TMCPToolBase } @@ -92,6 +123,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 +145,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -120,6 +158,16 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := BuildSchema; end; +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + { TMCPToolBase } constructor TMCPToolBase.Create; @@ -127,6 +175,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 +197,7 @@ function TMCPToolBase.GetTitle: string; function TMCPToolBase.GetOutputSchema: TJSONObject; begin - result := nil; + Result := nil; end; function TMCPToolBase.GetDescription: string; @@ -155,13 +210,33 @@ function TMCPToolBase.GetInputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(T); end; +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +function TMCPToolBase.ExecuteWithParams(const Params: T): string; +begin + raise ENotImplemented.CreateFmt('%s overrides neither ExecuteWithParams nor ExecuteWithContext', [ClassName]); +end; + +function TMCPToolBase.ExecuteWithContext(const Params: T; const Context: IMCPRequestContext): TValue; +begin + Result := ExecuteWithParams(Params); +end; + function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; var ParamsInstance: T; begin ParamsInstance := TMCPSerializer.Deserialize(Arguments); try - Result := ExecuteWithParams(ParamsInstance); + Result := ExecuteWithContext(ParamsInstance, TMCPRequestContext.Current); finally ParamsInstance.Free; end; @@ -172,7 +247,6 @@ function TMCPToolBase.GetParamsClass: TClass; Result := T; end; - { TMCPToolBase } constructor TMCPToolBase.Create; @@ -180,22 +254,39 @@ constructor TMCPToolBase.Create; inherited Create; end; +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 + Response: R; +begin + Response := ExecuteWithParams(Params); + try + var JsonObj := TJSONObject.Create; + TMCPSerializer.Serialize(Response, JsonObj); + Result := TValue.From(JsonObj); + finally + Response.Free; + end; +end; + function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; var ParamsInstance: T; - Response : R; - JsonObj : TJSONObject; begin ParamsInstance := TMCPSerializer.Deserialize(Arguments); try - Response := ExecuteWithParams(ParamsInstance); - try - JsonObj := TJSONObject.Create; - TMCPSerializer.Serialize(Response, JsonObj); - result := TValue.From(JsonObj); - finally - Response.Free; - end; + Result := ExecuteWithContext(ParamsInstance, TMCPRequestContext.Current); finally ParamsInstance.Free; end; @@ -203,7 +294,7 @@ function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; function TMCPToolBase.GetDescription: string; begin - result := FDescription; + Result := FDescription; end; function TMCPToolBase.GetInputSchema: TJSONObject; @@ -229,4 +320,14 @@ function TMCPToolBase.GetOutputSchema: TJSONObject; Result := TMCPSchemaGenerator.GenerateSchema(R); end; -end. \ No newline at end of file +function TMCPToolBase.GetAnnotations: TJSONObject; +begin + Result := FAnnotations; +end; + +function TMCPToolBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +end. diff --git a/src/Tools/MCPServer.Tool.Result.pas b/src/Tools/MCPServer.Tool.Result.pas new file mode 100644 index 0000000..76ff2ab --- /dev/null +++ b/src/Tools/MCPServer.Tool.Result.pas @@ -0,0 +1,241 @@ +unit MCPServer.Tool.Result; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types; + +type + /// Builds a tools/call result: content blocks of every kind, optional + /// structured content, the error flag and result metadata. A tool returns + /// the instance from Execute (as a TValue); the tools manager serialises it + /// for the era of the request and frees it. + TMCPToolResult = class + private + FContent: TJSONArray; + FStructuredContent: TJSONValue; + FMeta: TJSONObject; + FIsError: Boolean; + function AddBlock(const BlockType: string): TJSONObject; + function BuildContent(Era: TMCPProtocolEra): TJSONArray; + public + constructor Create; + destructor Destroy; override; + + function AddText(const Text: string): TMCPToolResult; + /// Data is the raw content; it is Base64-encoded here. + 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; + /// Annotations for the block added last (audience, priority, lastModified). + function WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; + /// Takes ownership. Any JSON value; the initialize-based revisions only + /// carry it when it is an object, and a text block with the compact JSON + /// is added when no other content exists. + function SetStructuredContent(const Value: TJSONValue): TMCPToolResult; + /// Takes ownership of the result-level _meta object. + 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; + + /// The CallToolResult object for the era; the caller owns it. + function ToJson(Era: TMCPProtocolEra): TJSONObject; + + property IsError: Boolean read FIsError write FIsError; + property Content: TJSONArray read FContent; + property StructuredContent: TJSONValue read FStructuredContent; + end; + + /// Base64 without line breaks, as the schema requires for blobs. + function EncodeBase64Blob(const Data: TBytes): string; + +implementation + +uses + System.NetEncoding; + +function EncodeBase64Blob(const Data: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Data); + finally + Encoding.Free; + end; +end; + +{ TMCPToolResult } + +constructor TMCPToolResult.Create; +begin + inherited Create; + FContent := TJSONArray.Create; +end; + +destructor TMCPToolResult.Destroy; +begin + FContent.Free; + FStructuredContent.Free; + FMeta.Free; + inherited; +end; + +function TMCPToolResult.AddBlock(const BlockType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', BlockType); + FContent.AddElement(Result); +end; + +function TMCPToolResult.AddText(const Text: string): TMCPToolResult; +begin + AddBlock('text').AddPair('text', Text); + Result := Self; +end; + +function TMCPToolResult.AddImage(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddImage(EncodeBase64Blob(Data), MimeType); +end; + +function TMCPToolResult.AddImage(const Base64Data, MimeType: string): TMCPToolResult; +begin + var Block := AddBlock('image'); + Block.AddPair('data', Base64Data); + Block.AddPair('mimeType', MimeType); + Result := Self; +end; + +function TMCPToolResult.AddAudio(const Data: TBytes; const MimeType: string): TMCPToolResult; +begin + Result := AddAudio(EncodeBase64Blob(Data), MimeType); +end; + +function TMCPToolResult.AddAudio(const Base64Data, MimeType: string): TMCPToolResult; +begin + var Block := AddBlock('audio'); + Block.AddPair('data', Base64Data); + Block.AddPair('mimeType', MimeType); + Result := Self; +end; + +function TMCPToolResult.AddResourceLink(const Uri, Name, Description, MimeType: string): TMCPToolResult; +begin + var Block := AddBlock('resource_link'); + Block.AddPair('uri', Uri); + Block.AddPair('name', Name); + if Description <> '' then + Block.AddPair('description', Description); + if MimeType <> '' then + Block.AddPair('mimeType', MimeType); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('text', Text); + AddBlock('resource').AddPair('resource', Resource); + Result := Self; +end; + +function TMCPToolResult.AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('blob', EncodeBase64Blob(Data)); + AddBlock('resource').AddPair('resource', Resource); + Result := Self; +end; + +function TMCPToolResult.WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; +begin + if FContent.Count = 0 then + begin + Annotations.Free; + raise EInvalidOperation.Create('WithAnnotations needs a content block to attach to'); + end; + TJSONObject(FContent.Items[FContent.Count - 1]).AddPair('annotations', Annotations); + Result := Self; +end; + +function TMCPToolResult.SetStructuredContent(const Value: TJSONValue): TMCPToolResult; +begin + FStructuredContent.Free; + FStructuredContent := Value; + Result := Self; +end; + +function TMCPToolResult.SetMeta(const Meta: TJSONObject): TMCPToolResult; +begin + FMeta.Free; + FMeta := Meta; + Result := Self; +end; + +function TMCPToolResult.SetError(const Message: string): TMCPToolResult; +begin + AddText(Message); + FIsError := True; + Result := Self; +end; + +class function TMCPToolResult.Text(const Text: string): TMCPToolResult; +begin + Result := TMCPToolResult.Create.AddText(Text); +end; + +class function TMCPToolResult.Error(const Message: string): TMCPToolResult; +begin + Result := TMCPToolResult.Create.SetError(Message); +end; + +function TMCPToolResult.BuildContent(Era: TMCPProtocolEra): TJSONArray; +begin + Result := TJSONArray(FContent.Clone); + // The schema requires content; structured-only results get the JSON as text. + if (Result.Count = 0) and Assigned(FStructuredContent) then + begin + var Block := TJSONObject.Create; + Block.AddPair('type', 'text'); + Block.AddPair('text', FStructuredContent.ToJSON); + Result.AddElement(Block); + end; +end; + +function TMCPToolResult.ToJson(Era: TMCPProtocolEra): TJSONObject; +begin + Result := TJSONObject.Create; + try + Result.AddPair('content', BuildContent(Era)); + + // 2025-06-18 and 2025-11-25 define structuredContent as an object only. + if Assigned(FStructuredContent) + and ((Era = TMCPProtocolEra.Modern) or (FStructuredContent is TJSONObject)) then + Result.AddPair('structuredContent', FStructuredContent.Clone as TJSONValue); + + if FIsError then + Result.AddPair('isError', TJSONBool.Create(True)); + + if Assigned(FMeta) then + Result.AddPair('_meta', TJSONObject(FMeta.Clone)); + except + Result.Free; + raise; + end; +end; + +end. From 818c9c0951470e6b4ac695856be91c7e0e4e4aa8 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:55 +0200 Subject: [PATCH 17/56] feat: strict argument validation and typed schemas Deserialisation rejects a missing required parameter, a wrong JSON type, a fraction for an integer and an unknown enumeration name with an EArgumentException naming the parameter; null counts as absent. Serialisation writes enumerations by name, sets and dynamic arrays as arrays, nil objects as null and TDateTime as ISO 8601. The schema generator emits integer for integers, date-time strings for TDateTime, enum names, typed arrays for sets, dynamic arrays and TList, nested object schemas and additionalProperties: false for parameter-less tools. --- src/Protocol/MCPServer.Schema.Generator.pas | 322 +++++++++++++------- src/Protocol/MCPServer.Serializer.pas | 179 +++++++---- 2 files changed, 341 insertions(+), 160 deletions(-) diff --git a/src/Protocol/MCPServer.Schema.Generator.pas b/src/Protocol/MCPServer.Schema.Generator.pas index 1f5e04b..890f62d 100644 --- a/src/Protocol/MCPServer.Schema.Generator.pas +++ b/src/Protocol/MCPServer.Schema.Generator.pas @@ -9,12 +9,33 @@ interface System.JSON; type + /// JSON Schema (2020-12 subset) for a parameter or result class, derived + /// from its published/public properties: + /// + /// Integer, Int64, Byte ... integer + /// Double, Single, Currency number + /// TDateTime / TDate / TTime string with format date-time / date / time + /// string string + /// Boolean boolean + /// other enumerations string with the enum names + /// sets array of enum names + /// dynamic arrays, TList array with typed items + /// TJSONArray / TJSONObject array / object (free form) + /// other classes nested object schema + /// + /// Attributes: [SchemaDescription], [SchemaTitle], [SchemaFormat], + /// [SchemaMinimum], [SchemaMaximum], [SchemaEnum] and [Optional]. TMCPSchemaGenerator = class private - class function GetJsonTypeFromRttiType(RttiType: TRttiType): string; - class function GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; + const MAX_NESTING_DEPTH = 8; + class function GetPropertyJsonName(Prop: TRttiProperty): string; class function IsRequiredProperty(Prop: TRttiProperty): Boolean; class function CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; + class function ListItemType(RttiType: TRttiType): TRttiType; + class function TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function ObjectSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; + class function NumberValue(const Value: Double): TJSONNumber; + class procedure ApplyAttributes(Prop: TRttiProperty; const PropSchema: TJSONObject); public class function GenerateSchema(Cls: TClass): TJSONObject; class function GenerateSchemaFromInstance(Instance: TObject): TJSONObject; @@ -26,147 +47,232 @@ implementation System.Generics.Collections, MCPServer.Types; +var + RttiContext: TRttiContext; + { TMCPSchemaGenerator } class function TMCPSchemaGenerator.GenerateSchema(Cls: TClass): TJSONObject; -var - Attr: TCustomAttribute; - EnumArray: TJSONArray; - JsonName: string; - JsonType: string; - Properties: TJSONObject; - PropSchema: TJSONObject; - RequiredArray: TJSONArray; - RttiContext: TRttiContext; - RttiProp: TRttiProperty; - RttiType: TRttiType; - Value: string; begin - Result := TJSONObject.Create; - Result.AddPair('type', 'object'); + Result := ObjectSchema(RttiContext.GetType(Cls), 0); +end; - Properties := TJSONObject.Create; - Result.AddPair('properties', Properties); - RequiredArray := TJSONArray.Create; +class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; +begin + Result := GenerateSchema(Instance.ClassType); +end; - RttiContext := TRttiContext.Create; - try - RttiType := RttiContext.GetType(Cls); +class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty): string; +begin + Result := LowerCase(Prop.Name); +end; - for RttiProp in RttiType.GetProperties do - begin - if RttiProp.IsReadable and RttiProp.IsWritable then - begin - JsonName := GetPropertyJsonName(RttiProp, RttiType); +class function TMCPSchemaGenerator.IsRequiredProperty(Prop: TRttiProperty): Boolean; +begin + for var Attr in Prop.GetAttributes do + if Attr is OptionalAttribute then + Exit(False); + Result := True; +end; - PropSchema := TJSONObject.Create; - Properties.AddPair(JsonName, PropSchema); +class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; +begin + Result := nil; + if not (RttiType is TRttiEnumerationType) or (RttiType.Handle = TypeInfo(Boolean)) then + Exit; + + var EnumType := TRttiEnumerationType(RttiType); + Result := TJSONArray.Create; + for var Ordinal := EnumType.MinValue to EnumType.MaxValue do + Result.Add(GetEnumName(RttiType.Handle, Ordinal)); +end; - JsonType := GetJsonTypeFromRttiType(RttiProp.PropertyType); - PropSchema.AddPair('type', JsonType); +class function TMCPSchemaGenerator.ListItemType(RttiType: TRttiType): TRttiType; +begin + // TList and TObjectList expose Items[Index: NativeInt]: T. + 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 function TMCPSchemaGenerator.TypeSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; +begin + Result := TJSONObject.Create; + try + case RttiType.TypeKind of + tkInteger, tkInt64: + Result.AddPair('type', 'integer'); - if JsonType = 'array' then - PropSchema.AddPair('items', TJSONObject.Create); + tkFloat: + if RttiType.Handle = TypeInfo(TDateTime) then + begin + Result.AddPair('type', 'string'); + Result.AddPair('format', 'date-time'); + end + else if RttiType.Handle = TypeInfo(TDate) then + begin + Result.AddPair('type', 'string'); + Result.AddPair('format', 'date'); + end + else if RttiType.Handle = TypeInfo(TTime) then + begin + Result.AddPair('type', 'string'); + Result.AddPair('format', 'time'); + end + else + Result.AddPair('type', 'number'); - EnumArray := nil; + tkString, tkLString, tkWString, tkUString, tkChar, tkWChar: + Result.AddPair('type', 'string'); - for Attr in RttiProp.GetAttributes do + tkEnumeration: + if RttiType.Handle = TypeInfo(Boolean) then + Result.AddPair('type', 'boolean') + else begin - if Attr is SchemaDescriptionAttribute then - begin - PropSchema.AddPair('description', SchemaDescriptionAttribute(Attr).Description); - end - else if Attr is SchemaEnumAttribute then - begin - EnumArray := TJSONArray.Create; - for Value in SchemaEnumAttribute(Attr).Values do - EnumArray.Add(Value); - end; + Result.AddPair('type', 'string'); + Result.AddPair('enum', CreateEnumValuesArray(RttiType)); end; - if not Assigned(EnumArray) then - EnumArray := CreateEnumValuesArray(RttiProp.PropertyType); + tkSet: + begin + Result.AddPair('type', 'array'); + var Items := TJSONObject.Create; + Result.AddPair('items', Items); + Items.AddPair('type', 'string'); + var ElementType := TRttiSetType(RttiType).ElementType; + var Names := CreateEnumValuesArray(ElementType); + if Assigned(Names) then + Items.AddPair('enum', Names); + end; - if Assigned(EnumArray) then - PropSchema.AddPair('enum', EnumArray); + tkDynArray: + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(TRttiDynamicArrayType(RttiType).ElementType, Depth + 1)); + end; - if IsRequiredProperty(RttiProp) then - RequiredArray.Add(JsonName); - end; - end; + tkArray: + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(TRttiArrayType(RttiType).ElementType, Depth + 1)); + end; - if RequiredArray.Count > 0 then - Result.AddPair('required', RequiredArray) + tkClass: + begin + var Metaclass := TRttiInstanceType(RttiType).MetaclassType; + if Metaclass.InheritsFrom(TJSONArray) then + Result.AddPair('type', 'array') + else if Metaclass.InheritsFrom(TJSONValue) then + Result.AddPair('type', 'object') + else + begin + var ItemType := ListItemType(RttiType); + if Assigned(ItemType) then + begin + Result.AddPair('type', 'array'); + Result.AddPair('items', TypeSchema(ItemType, Depth + 1)); + end + else if Depth < MAX_NESTING_DEPTH then + begin + Result.Free; + Result := ObjectSchema(RttiType, Depth + 1); + end + else + Result.AddPair('type', 'object'); + end; + end; else - RequiredArray.Free; - finally - RttiContext.Free; + Result.AddPair('type', 'string'); + end; + except + Result.Free; + raise; end; end; -class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject): TJSONObject; +class function TMCPSchemaGenerator.NumberValue(const Value: Double): TJSONNumber; begin - Result := GenerateSchema(Instance.ClassType); -end; - -class function TMCPSchemaGenerator.GetJsonTypeFromRttiType(RttiType: TRttiType): string; -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'; + // Whole bounds are written as integers, so "minimum": 1 rather than 1.0. + if Frac(Value) = 0 then + Result := TJSONNumber.Create(Trunc(Value)) else - Result := 'string'; - end; -end; - -class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty; RType: TRttiType): string; -begin - Result := LowerCase(Prop.Name); + Result := TJSONNumber.Create(Value); end; -class function TMCPSchemaGenerator.IsRequiredProperty(Prop: TRttiProperty): Boolean; -var - Attr: TCustomAttribute; +class procedure TMCPSchemaGenerator.ApplyAttributes(Prop: TRttiProperty; const PropSchema: TJSONObject); begin - for Attr in Prop.GetAttributes do + for var Attr in Prop.GetAttributes do begin - if Attr is OptionalAttribute then - Exit(False); + if Attr is SchemaDescriptionAttribute then + PropSchema.AddPair('description', SchemaDescriptionAttribute(Attr).Description) + else if Attr is SchemaTitleAttribute then + PropSchema.AddPair('title', SchemaTitleAttribute(Attr).Title) + else if Attr is SchemaFormatAttribute then + begin + PropSchema.RemovePair('format').Free; + PropSchema.AddPair('format', SchemaFormatAttribute(Attr).Format); + end + else if Attr is SchemaMinimumAttribute then + PropSchema.AddPair('minimum', NumberValue(SchemaMinimumAttribute(Attr).Minimum)) + else if Attr is SchemaMaximumAttribute then + PropSchema.AddPair('maximum', NumberValue(SchemaMaximumAttribute(Attr).Maximum)) + else if Attr is SchemaEnumAttribute then + begin + PropSchema.RemovePair('enum').Free; + var EnumArray := TJSONArray.Create; + for var Value in SchemaEnumAttribute(Attr).Values do + EnumArray.Add(Value); + PropSchema.AddPair('enum', EnumArray); + end; end; - Result := True; end; -class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): TJSONArray; -var - EnumType: TRttiEnumerationType; - Ordinal: Integer; +class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Integer): TJSONObject; begin - Result := nil; + Result := TJSONObject.Create; + try + Result.AddPair('type', 'object'); + var Properties := TJSONObject.Create; + Result.AddPair('properties', Properties); + var RequiredArray := TJSONArray.Create; - if not (RttiType is TRttiEnumerationType) then - Exit; + for var RttiProp in RttiType.GetProperties do + begin + if not (RttiProp.IsReadable and RttiProp.IsWritable) then + Continue; - if RttiType.Handle = TypeInfo(Boolean) then - Exit; + var JsonName := GetPropertyJsonName(RttiProp); + var PropSchema := TypeSchema(RttiProp.PropertyType, Depth); + Properties.AddPair(JsonName, PropSchema); + ApplyAttributes(RttiProp, PropSchema); - EnumType := TRttiEnumerationType(RttiType); + if IsRequiredProperty(RttiProp) then + RequiredArray.Add(JsonName); + end; - Result := TJSONArray.Create; - for Ordinal := EnumType.MinValue to EnumType.MaxValue do - Result.Add(GetEnumName(RttiType.Handle, Ordinal)); + if RequiredArray.Count > 0 then + Result.AddPair('required', RequiredArray) + else + RequiredArray.Free; + + // A tool without parameters accepts an empty object and nothing else. + if Properties.Count = 0 then + Result.AddPair('additionalProperties', TJSONBool.Create(False)); + except + Result.Free; + raise; + end; end; -end. \ No newline at end of file +initialization + RttiContext := TRttiContext.Create; + +finalization + RttiContext.Free; + +end. diff --git a/src/Protocol/MCPServer.Serializer.pas b/src/Protocol/MCPServer.Serializer.pas index 049f2df..f3c2ce1 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -36,6 +36,7 @@ TMCPSerializer = class // Single normalization rule shared by lookup and validation class function NormalizeKey(const Name: string): string; inline; + class function IsRequiredProperty(const Prop: TRttiProperty): Boolean; public class constructor Create; class destructor Destroy; @@ -48,6 +49,11 @@ TMCPSerializer = class implementation +uses + System.Math, + System.DateUtils, + MCPServer.Types; + { TMCPSerializer } class constructor TMCPSerializer.Create; @@ -128,8 +134,13 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: JsonValue := GetJsonValueCaseInsensitive(Json, RttiProp.Name); - if not Assigned(JsonValue) then + // Absent and null both mean "not given"; a required parameter must be given. + if not Assigned(JsonValue) or (JsonValue is TJSONNull) then + begin + if IsRequiredProperty(RttiProp) then + raise EArgumentException.CreateFmt('Missing required parameter "%s"', [LowerCase(RttiProp.Name)]); Continue; + end; try PropValue := ConvertJsonToValue(JsonValue, RttiProp.PropertyType); @@ -147,6 +158,14 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: end; end; +class function TMCPSerializer.IsRequiredProperty(const Prop: TRttiProperty): Boolean; +begin + for var Attr in Prop.GetAttributes do + if Attr is OptionalAttribute then + Exit(False); + Result := True; +end; + class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); var JsonValue: TJSONValue; @@ -196,49 +215,56 @@ class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; co if not Assigned(JsonValue) then Exit; + // Values must have the JSON type the schema advertises; a mismatch is an + // argument error the tool reports as isError, so the model can correct it. case RttiType.TypeKind of - tkInteger: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsInt - else - Result := StrToIntDef(JsonValue.Value, 0); + tkInteger, tkInt64: + begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected an integer'); + var Number := TJSONNumber(JsonValue); + if Frac(Number.AsDouble) <> 0 then + raise EArgumentException.Create('expected an integer'); + if RttiType.TypeKind = tkInt64 then + Result := Number.AsInt64 + else + Result := TValue.FromOrdinal(RttiType.Handle, Number.AsInt64); + end; - tkInt64: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsInt64 - else - Result := StrToInt64Def(JsonValue.Value, 0); - tkFloat: - if JsonValue is TJSONNumber then - Result := (JsonValue as TJSONNumber).AsDouble + if RttiType.Handle = TypeInfo(TDateTime) then + begin + if not (JsonValue is TJSONString) then + raise EArgumentException.Create('expected a date-time string'); + try + Result := TValue.From(ISO8601ToDate(JsonValue.Value, False)); + except + raise EArgumentException.Create('expected an ISO 8601 date-time'); + end; + end else -{$IF COMPILERVERSION <= 28} - Result := StrToFloatDef(JsonValue.Value, 0, TFormatSettings.Create('en-US')); -{$ELSE} - Result := StrToFloatDef(JsonValue.Value, 0, FormatSettings.Invariant); -{$ENDIF} + begin + if not (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected a number'); + Result := TJSONNumber(JsonValue).AsDouble; + end; tkString, tkLString, tkWString, tkUString: - Result := JsonValue.Value; - + begin + if not (JsonValue is TJSONString) or (JsonValue is TJSONNumber) then + raise EArgumentException.Create('expected a string'); + Result := JsonValue.Value; + end; + tkEnumeration: if RttiType.Handle = TypeInfo(Boolean) then begin -{$IF COMPILERVERSION <= 29} - if (JsonValue is TJSONTrue) or (JsonValue is TJSONFalse) then - Result := JsonValue is TJSONTrue -{$ELSE} - if JsonValue is TJSONBool then - Result := (JsonValue as TJSONBool).AsBoolean -{$ENDIF} - else - Result := LowerCase(JsonValue.Value) = 'true'; + if not (JsonValue is TJSONBool) then + raise EArgumentException.Create('expected a boolean'); + Result := TJSONBool(JsonValue).AsBoolean; end else - begin Result := ConvertJsonToEnum(JsonValue, RttiType); - end; tkClass: if JsonValue is TJSONObject then @@ -246,16 +272,26 @@ class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; co NestedInstance := CreateInstanceFromType(RttiType); if Assigned(NestedInstance) then begin - DeserializeObject(NestedInstance, JsonValue as TJSONObject); + try + DeserializeObject(NestedInstance, JsonValue as TJSONObject); + except + NestedInstance.Free; + raise; + end; Result := NestedInstance; end; end else if JsonValue is TJSONArray then - Result := DeserializeArray(RttiType, JsonValue as TJSONArray); - + Result := DeserializeArray(RttiType, JsonValue as TJSONArray) + else + raise EArgumentException.Create('expected an object'); + tkDynArray: - if JsonValue is TJSONArray then + begin + if not (JsonValue is TJSONArray) then + raise EArgumentException.Create('expected an array'); Result := DeserializeArray(RttiType, JsonValue as TJSONArray); + end; end; end; @@ -327,33 +363,70 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti Obj: TObject; begin Result := nil; - + + // Empty means nil for objects and [] for dynamic arrays; both are worth + // writing so the JSON has the property the schema advertises. 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, 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} + // Every included element by its enum name. + var Names := TJSONArray.Create; + var ElementType := TRttiEnumerationType(TRttiSetType(RttiType).ElementType); + // A set is stored from the byte that holds its lowest element. + var SetBits: Int64 := 0; + Move(Value.GetReferenceToRawData^, SetBits, Min(Value.DataSize, SizeOf(SetBits))); + var FirstBit := ElementType.MinValue and not 7; + for var Ordinal := ElementType.MinValue to ElementType.MaxValue do + if (SetBits and (Int64(1) shl (Ordinal - FirstBit))) <> 0 then + Names.Add(GetEnumName(ElementType.Handle, Ordinal)); + Result := Names; + end; + + tkDynArray: + begin + var Items := TJSONArray.Create; + var ElementType := TRttiDynamicArrayType(RttiType).ElementType; + for var I := 0 to Value.GetArrayLength - 1 do + begin + var Item := ConvertValueToJson(Value.GetArrayElement(I), ElementType); + if Assigned(Item) then + Items.AddElement(Item) + else + Items.AddElement(TJSONNull.Create); + end; + Result := Items; end; tkClass: @@ -371,7 +444,9 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti Serialize(Obj, ChildJson); Result := ChildJson; end; - end; + end + else + Result := TJSONNull.Create; end; end; From e572475429688d77ae6ac9aa1bda071f5aad85c8 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:56 +0200 Subject: [PATCH 18/56] feat: era-aware tools and resources managers tools/call answers -32602 with data.name for an unknown tool and for a missing name or non-object arguments; argument validation errors and EMCPToolError become isError results; every result has a content array and a typed result gets a text block next to structuredContent. resources/read answers -32002 (initialize-based) or -32602 (modern) with data.uri for an unknown URI, -32603 for a failing read, and delivers IMCPBinaryResource contents as blob. Lists follow registration order, carry resource metadata and, in the modern era, ttlMs and cacheScope. AddTool and AddResource register instances outside TMCPRegistry. --- src/Core/MCPServer.Registration.pas | 20 +- src/Managers/MCPServer.ResourcesManager.pas | 267 ++++++++++----- src/Managers/MCPServer.ToolsManager.pas | 352 ++++++++++++-------- 3 files changed, 410 insertions(+), 229 deletions(-) diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index 1f28a28..c63411b 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -15,7 +15,8 @@ TMCPToolClass = class of TMCPToolBase; TMCPToolFactory = reference to function: IMCPTool; TMCPResourceFactory = reference to function: IMCPResource; - /// Process-wide registry of tool and resource factories. + /// Process-wide registry of tool and resource factories, enumerated in + /// registration order. /// /// The dictionaries exist from the class constructor on, so registration /// from unit initialization sections needs no lazy checks. Registration is @@ -26,7 +27,9 @@ TMCPToolClass = class of TMCPToolBase; TMCPRegistry = class private class var FTools: TDictionary; + class var FToolOrder: TList; class var FResources: TDictionary; + class var FResourceOrder: TList; class constructor Create; class destructor Destroy; @@ -40,7 +43,9 @@ TMCPRegistry = class class function CreateTool(const Name: string): IMCPTool; class function CreateResource(const URI: string): IMCPResource; + /// Names in registration order. class function GetToolNames: TArray; + /// URIs in registration order. class function GetResourceURIs: TArray; class function HasTool(const Name: string): Boolean; @@ -54,23 +59,31 @@ implementation class constructor TMCPRegistry.Create; begin FTools := TDictionary.Create; + FToolOrder := TList.Create; FResources := TDictionary.Create; + FResourceOrder := TList.Create; end; class destructor TMCPRegistry.Destroy; begin FreeAndNil(FTools); + FreeAndNil(FToolOrder); FreeAndNil(FResources); + FreeAndNil(FResourceOrder); end; class procedure TMCPRegistry.RegisterTool(const Name: string; Factory: TMCPToolFactory); begin + 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 + if not FResources.ContainsKey(URI) then + FResourceOrder.Add(URI); FResources.AddOrSetValue(URI, Factory); TLogger.Info('Registered resource: ' + URI); end; @@ -80,6 +93,7 @@ class procedure TMCPRegistry.UnregisterResource(const URI: string); if FResources.ContainsKey(URI) then begin FResources.Remove(URI); + FResourceOrder.Remove(URI); TLogger.Info('Unregistered resource: ' + URI); end; end; @@ -106,12 +120,12 @@ class function TMCPRegistry.CreateResource(const URI: string): IMCPResource; class function TMCPRegistry.GetToolNames: TArray; begin - Result := FTools.Keys.ToArray; + Result := FToolOrder.ToArray; end; class function TMCPRegistry.GetResourceURIs: TArray; begin - Result := FResources.Keys.ToArray; + Result := FResourceOrder.ToArray; end; class function TMCPRegistry.HasTool(const Name: string): Boolean; diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 25375d9..17b58f7 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -13,29 +13,58 @@ interface MCPServer.Resource.Base; type - TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityProvider) + /// resources/list, resources/read and resources/templates/list over the + /// resources registered in TMCPRegistry, listed in registration order. + /// + /// An unknown resource is a JSON-RPC error: -32602 with data.uri in the + /// modern era, -32002 in the initialize-based revisions. A failing read is + /// -32603. Resources that implement IMCPBinaryResource are read as blobs. + TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) private FResources: TDictionary; + FOrder: TList; + FListTtlMs: Integer; + FListCacheScope: string; procedure RegisterResource(const Resource: IMCPResource); procedure RegisterBuiltInResources; + procedure CheckCursor(const Params: TJSONObject); + procedure AddListCacheHints(const ResultJSON: TJSONObject; Era: TMCPProtocolEra); + function CreateResourceJSON(const Resource: IMCPResource): TJSONObject; + function CreateContentsItem(const Resource: IMCPResource): TJSONObject; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; public constructor Create; destructor Destroy; override; - + + /// Adds a resource to this manager only (next to the ones from TMCPRegistry). + procedure AddResource(const Resource: IMCPResource); + 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 ListResources: TValue; - function ReadResource(const Params: System.JSON.TJSONObject): TValue; - function ListResourceTemplates: TValue; + 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; + + /// Cache hints on the list results for modern clients; 0 and 'private' unless set. + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; end; implementation uses - MCPServer.Registration; + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Errors, + MCPServer.Tool.Result; { TMCPResourcesManager } @@ -43,12 +72,16 @@ constructor TMCPResourcesManager.Create; begin inherited; FResources := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; RegisterBuiltInResources; end; destructor TMCPResourcesManager.Destroy; begin FResources.Free; + FOrder.Free; inherited; end; @@ -72,57 +105,130 @@ procedure TMCPResourcesManager.DescribeCapabilities(const Capabilities: TJSONObj Capabilities.AddPair('resources', Resources); end; +function TMCPResourcesManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + function TMCPResourcesManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPResourcesManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'resources/list' then - Result := ListResources + Result := ListResources(Params, EraOf(Context)) else if Method = 'resources/read' then - Result := ReadResource(Params) + Result := ReadResource(Params, EraOf(Context)) else if Method = 'resources/templates/list' then - Result := ListResourceTemplates + Result := ListResourceTemplates(Params, EraOf(Context)) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; procedure TMCPResourcesManager.RegisterResource(const Resource: IMCPResource); begin - FResources.Add(Resource.URI, Resource); + if not FResources.ContainsKey(Resource.URI) then + FOrder.Add(Resource.URI); + FResources.AddOrSetValue(Resource.URI, Resource); end; procedure TMCPResourcesManager.RegisterBuiltInResources; +begin + for var ResourceURI in TMCPRegistry.GetResourceURIs do + RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); +end; + +procedure TMCPResourcesManager.AddResource(const Resource: IMCPResource); +begin + RegisterResource(Resource); +end; + +procedure TMCPResourcesManager.CheckCursor(const Params: TJSONObject); +begin + // Every list fits in one page; a cursor is never one this server issued. + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +procedure TMCPResourcesManager.AddListCacheHints(const ResultJSON: TJSONObject; Era: TMCPProtocolEra); +begin + if Era = TMCPProtocolEra.Modern then + begin + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair('cacheScope', FListCacheScope); + end; +end; + +function TMCPResourcesManager.CreateResourceJSON(const Resource: IMCPResource): TJSONObject; var - ResourceURI: string; + Metadata: IMCPResourceMetadata; begin - for ResourceURI in TMCPRegistry.GetResourceURIs do + Result := TJSONObject.Create; + Result.AddPair('uri', Resource.URI); + Result.AddPair('name', Resource.Name); + + if Supports(Resource, IMCPResourceMetadata, Metadata) then begin - RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); + if Metadata.Title <> '' then + Result.AddPair('title', Metadata.Title); + end; + if Resource.Description <> '' then + Result.AddPair('description', Resource.Description); + if Resource.MimeType <> '' then + Result.AddPair('mimeType', Resource.MimeType); + if Assigned(Metadata) then + begin + if Metadata.Size >= 0 then + Result.AddPair('size', TJSONNumber.Create(Metadata.Size)); + if Assigned(Metadata.Annotations) then + Result.AddPair('annotations', TJSONObject(Metadata.Annotations.Clone)); end; end; -function TMCPResourcesManager.ListResources: TValue; +function TMCPResourcesManager.CreateContentsItem(const Resource: IMCPResource): TJSONObject; var - Resource: IMCPResource; - ResourcesArray: TJSONArray; - ResourceObj: TJSONObject; - ResultJSON: TJSONObject; + Binary: IMCPBinaryResource; +begin + Result := TJSONObject.Create; + try + Result.AddPair('uri', Resource.URI); + if Resource.MimeType <> '' then + Result.AddPair('mimeType', Resource.MimeType); + + if Supports(Resource, IMCPBinaryResource, Binary) then + Result.AddPair('blob', EncodeBase64Blob(Binary.ReadBinary)) + else + Result.AddPair('text', Resource.Read); + except + Result.Free; + raise; + end; +end; + +function TMCPResourcesManager.ListResources: TValue; +begin + Result := ListResources(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPResourcesManager.ListResources(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; begin TLogger.Info('MCP ListResources called'); + CheckCursor(Params); - ResultJSON := TJSONObject.Create; + var ResultJSON := TJSONObject.Create; try - ResourcesArray := TJSONArray.Create; + var ResourcesArray := TJSONArray.Create; ResultJSON.AddPair('resources', ResourcesArray); - - for Resource in FResources.Values do - begin - ResourceObj := TJSONObject.Create; - ResourceObj.AddPair('uri', Resource.URI); - ResourceObj.AddPair('name', Resource.Name); - ResourceObj.AddPair('description', Resource.Description); - ResourceObj.AddPair('mimeType', Resource.MimeType); - ResourcesArray.AddElement(ResourceObj); - end; - + for var URI in FOrder do + ResourcesArray.AddElement(CreateResourceJSON(FResources[URI])); + AddListCacheHints(ResultJSON, Era); + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -131,57 +237,53 @@ 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 - // Params is nil when the request carries no params object; treat that - // like a missing uri instead of dereferencing nil. - URI := ''; - if Assigned(Params) then - begin - URIValue := Params.GetValue('uri'); - if Assigned(URIValue) then - URI := URIValue.Value; - end; + Cacheable: IMCPCacheableResource; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.uri is required'); + var URIValue := Params.GetValue('uri'); + if not (URIValue is TJSONString) or (TJSONString(URIValue).Value = '') then + raise EMCPError.InvalidParams('params.uri is required and must be a non-empty string'); + var URI := TJSONString(URIValue).Value; TLogger.Info('MCP ReadResource called for URI: ' + URI); - ResultJSON := TJSONObject.Create; + if not FResources.TryGetValue(URI, 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: Exception do + raise EMCPError.InternalError('Error reading resource: ' + E.Message); + end; - ContentItem := TJSONObject.Create; - ContentsArray.AddElement(ContentItem); - - if FResources.TryGetValue(URI, Resource) then + if Era = TMCPProtocolEra.Modern then begin - ContentItem.AddPair('uri', Resource.URI); - ContentItem.AddPair('mimeType', Resource.MimeType); - - try - ResourceText := Resource.Read; - ContentItem.AddPair('text', ResourceText); - except - on E: Exception do - begin - ContentItem.AddPair('text', 'Error reading resource: ' + E.Message); - end; + var TtlMs := 0; + var CacheScope := MCP_CACHE_SCOPE_PRIVATE; + if Supports(Resource, IMCPCacheableResource, Cacheable) then + begin + TtlMs := Cacheable.TtlMs; + CacheScope := Cacheable.CacheScope; end; - end - else - begin - ContentItem.AddPair('uri', URI); - ContentItem.AddPair('mimeType', 'text/plain'); - ContentItem.AddPair('text', 'Error: Resource not found: ' + URI); + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(TtlMs)); + ResultJSON.AddPair('cacheScope', CacheScope); end; - + Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -190,19 +292,20 @@ 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 - + // This server has no resource templates. + ResultJSON.AddPair('resourceTemplates', TJSONArray.Create); + AddListCacheHints(ResultJSON, Era); Result := TValue.From(ResultJSON); except ResultJSON.Free; @@ -210,4 +313,4 @@ function TMCPResourcesManager.ListResourceTemplates: TValue; end; end; -end. \ No newline at end of file +end. diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 21fdc4a..746ac3c 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -13,34 +13,65 @@ interface MCPServer.Tool.Base; type - TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityProvider) + /// tools/list and tools/call over the tools registered in TMCPRegistry, + /// listed in registration order. + /// + /// Protocol errors (-32602) are raised for a missing or unknown tool name + /// and malformed params; everything a tool itself reports (EMCPToolError, + /// argument validation, unexpected exceptions) becomes an isError result + /// the model can act on. + 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; + FListTtlMs: Integer; + FListCacheScope: string; + 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); + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; private - FTools: TDictionary; procedure RegisterTool(const Tool: IMCPTool); procedure RegisterBuiltInTools; public constructor Create; destructor Destroy; override; - + + /// Adds a tool to this manager only (next to the ones from TMCPRegistry). + procedure AddTool(const Tool: IMCPTool); + 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 ListTools: TValue; - function CallTool(const Params: System.JSON.TJSONObject): TValue; + 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; + + /// Cache hints on tools/list for modern clients; 0 and 'private' unless set. + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; end; implementation uses - MCPServer.Registration; + System.RegularExpressions, + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Errors, + MCPServer.Tool.Result; + +const + TOOL_NAME_PATTERN = '^[A-Za-z0-9_.\-]{1,128}$'; { TMCPToolsManager } @@ -48,12 +79,16 @@ constructor TMCPToolsManager.Create; begin inherited; FTools := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; RegisterBuiltInTools; end; destructor TMCPToolsManager.Destroy; begin FTools.Free; + FOrder.Free; inherited; end; @@ -74,126 +109,153 @@ procedure TMCPToolsManager.DescribeCapabilities(const Capabilities: TJSONObject; Capabilities.AddPair('tools', Tools); end; +function TMCPToolsManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + function TMCPToolsManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPToolsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; begin if Method = 'tools/list' then - Result := ListTools + Result := ListTools(Params, EraOf(Context)) else if Method = 'tools/call' then - Result := CallTool(Params) + Result := CallTool(Params, EraOf(Context)) else raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; +procedure TMCPToolsManager.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); + if not FTools.ContainsKey(Tool.Name) then + FOrder.Add(Tool.Name); + FTools.AddOrSetValue(Tool.Name, Tool); end; procedure TMCPToolsManager.RegisterBuiltInTools; -var - Tool: IMCPTool; - ToolName: string; begin - for ToolName in TMCPRegistry.GetToolNames do - begin - Tool := TMCPRegistry.CreateTool(ToolName); - RegisterTool(Tool); - end; + for var ToolName in TMCPRegistry.GetToolNames do + RegisterTool(TMCPRegistry.CreateTool(ToolName)); end; -function TMCPToolsManager.ExtractToolNameAndArguments(const Params: System.JSON.TJSONObject; out ToolName: string; out Arguments: TJSONObject): Boolean; -var - ArgsValue: TJSONValue; - NameValue: TJSONValue; +procedure TMCPToolsManager.AddTool(const Tool: IMCPTool); begin - Result := False; - ToolName := ''; - Arguments := nil; - - if not Assigned(Params) then - Exit; - - NameValue := Params.GetValue('name'); - if Assigned(NameValue) then - begin - ToolName := NameValue.Value; - Result := ToolName <> ''; - end; - - ArgsValue := Params.GetValue('arguments'); - if Assigned(ArgsValue) and (ArgsValue is TJSONObject) then - Arguments := ArgsValue as TJSONObject; + RegisterTool(Tool); +end; + +procedure TMCPToolsManager.CheckCursor(const Params: TJSONObject); +begin + // Every list fits in one page; a cursor is never one this server issued. + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); end; -function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject): TValue; +function TMCPToolsManager.ErrorResult(const Message: string; Era: TMCPProtocolEra): TJSONObject; begin + var ToolResult := TMCPToolResult.Error(Message); try - Result := Tool.Execute(Arguments); - except - on E: Exception do - Result := 'Error executing tool: ' + E.Message; + Result := ToolResult.ToJson(Era); + finally + ToolResult.Free; end; end; -function TMCPToolsManager.BuildToolCallResponse(const ResultValue: TValue): TJSONObject; -var - ContentArray: TJSONArray; - ContentItem: TJSONObject; - ErrorValue: TJSONValue; - HasError: Boolean; - JsonResult: TJSONObject; - TextValue: string; +function TMCPToolsManager.ResultToJson(const ResultValue: TValue; Era: TMCPProtocolEra): TJSONObject; begin - Result := TJSONObject.Create; + if ResultValue.IsType then + begin + var ToolResult := ResultValue.AsType; + try + Exit(ToolResult.ToJson(Era)); + finally + ToolResult.Free; + end; + end; if ResultValue.IsType then begin - // The tool already produced a content array (e.g. text plus an image item); - // take ownership so it is passed through verbatim and freed with the - // response (no clone, no leak of the original array). + // A ready-made content array is passed through as is. + Result := TJSONObject.Create; Result.AddPair('content', ResultValue.AsType); - end - else if ResultValue.IsType then - begin - TextValue := ResultValue.AsString; - HasError := TextValue.StartsWith('Error:') or TextValue.StartsWith('Error executing tool:'); - - ContentArray := TJSONArray.Create; - Result.AddPair('content', ContentArray); - - ContentItem := TJSONObject.Create; - ContentArray.AddElement(ContentItem); - ContentItem.AddPair('type', 'text'); - ContentItem.AddPair('text', TextValue); - - if HasError then -{$IF COMPILERVERSION <= 29} - Result.AddPair('isError', TJSONTrue.Create); -{$ELSE} - Result.AddPair('isError', TJSONBool.Create(True)); -{$ENDIF} - end - else if ResultValue.IsType then + Exit; + end; + + var ToolResult := TMCPToolResult.Create; + try + if ResultValue.IsType then + begin + var Text := ResultValue.AsString; + ToolResult.AddText(Text); + // Text results keep signalling failure with an "Error:" prefix. + ToolResult.IsError := Text.StartsWith('Error:') or Text.StartsWith('Error executing tool:'); + end + else if ResultValue.IsType then + begin + var Structured := ResultValue.AsType; + ToolResult.SetStructuredContent(Structured); + var ErrorValue := Structured.GetValue('error'); + ToolResult.IsError := Assigned(ErrorValue) and (ErrorValue.Value <> ''); + end + else if not ResultValue.IsEmpty then + ToolResult.AddText(ResultValue.ToString); + + Result := ToolResult.ToJson(Era); + finally + ToolResult.Free; + end; +end; + +function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJSONObject; + Era: TMCPProtocolEra): TJSONObject; +var + ResultValue: TValue; +begin + // "arguments" is optional on the wire; a tool always receives an object. + var OwnedArguments: TJSONObject := nil; + var EffectiveArguments := Arguments; + if not Assigned(EffectiveArguments) then begin - JsonResult := ResultValue.AsType; - Result.AddPair('structuredContent', TJSONObject(JsonResult.Clone)); - - ErrorValue := JsonResult.GetValue('error'); - HasError := Assigned(ErrorValue) and (ErrorValue.Value <> ''); - if HasError then -{$IF COMPILERVERSION <= 29} - Result.AddPair('isError', TJSONTrue.Create); -{$ELSE} - Result.AddPair('isError', TJSONBool.Create(True)); -{$ENDIF} + OwnedArguments := TJSONObject.Create; + EffectiveArguments := OwnedArguments; end; + try + try + ResultValue := Tool.Execute(EffectiveArguments); + except + on E: EMCPToolError do + Exit(ErrorResult(E.Message, Era)); + on E: EArgumentException do + Exit(ErrorResult('Invalid arguments: ' + E.Message, Era)); + on E: EMCPError do + raise; + on E: Exception do + Exit(ErrorResult('Error executing tool: ' + E.Message, Era)); + end; + Result := ResultToJson(ResultValue, Era); + 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); @@ -201,78 +263,80 @@ function TMCPToolsManager.CreateToolJSON(const Tool: IMCPTool): TJSONObject; Result.AddPair('title', Tool.Title); Result.AddPair('description', Tool.Description); - Schema := Tool.InputSchema; + var Schema := Tool.InputSchema; if Assigned(Schema) then - begin - SchemaClone := TJSONObject.ParseJSONValue(Schema.ToJSON) as TJSONObject; - Result.AddPair('inputSchema', SchemaClone); - Schema.Free; - end; + Result.AddPair('inputSchema', Schema); + Schema := Tool.OutputSchema; if Assigned(Schema) then + Result.AddPair('outputSchema', Schema); + + if Supports(Tool, IMCPToolMetadata, Metadata) then begin - SchemaClone := TJSONObject.ParseJSONValue(Schema.ToJSON) as TJSONObject; - Result.AddPair('outputSchema', SchemaClone); - Schema.Free; + if Assigned(Metadata.Annotations) then + Result.AddPair('annotations', TJSONObject(Metadata.Annotations.Clone)); + if Assigned(Metadata.Icons) then + Result.AddPair('icons', TJSONArray(Metadata.Icons.Clone)); end; - end; -function TMCPToolsManager.BuildToolListResponse: TJSONObject; -var - Tool: IMCPTool; - ToolsArray: TJSONArray; - ToolJSON: TJSONObject; +function TMCPToolsManager.BuildToolListResponse(Era: TMCPProtocolEra): TJSONObject; begin Result := TJSONObject.Create; - ToolsArray := TJSONArray.Create; + var ToolsArray := TJSONArray.Create; Result.AddPair('tools', ToolsArray); - for Tool in FTools.Values do + for var Name in FOrder do + ToolsArray.AddElement(CreateToolJSON(FTools[Name])); + + if Era = TMCPProtocolEra.Modern then begin - ToolJSON := CreateToolJSON(Tool); - ToolsArray.AddElement(ToolJSON); + Result.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + Result.AddPair('cacheScope', FListCacheScope); end; end; +function TMCPToolsManager.ListTools: TValue; +begin + Result := ListTools(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPToolsManager.ListTools(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +begin + TLogger.Info('MCP ListTools called'); + CheckCursor(Params); + Result := TValue.From(BuildToolListResponse(Era)); +end; + function TMCPToolsManager.CallTool(const Params: System.JSON.TJSONObject): TValue; +begin + Result := CallTool(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPToolsManager.CallTool(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; var - Arguments: TJSONObject; - EmptyArguments: TJSONObject; - ResultValue: TValue; Tool: IMCPTool; - ToolName: string; begin - if not ExtractToolNameAndArguments(Params, ToolName, Arguments) then - begin - Result := TValue.From(BuildToolCallResponse('Error: Invalid tool parameters')); - Exit; - end; + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.name is required'); - TLogger.Info('MCP CallTool called for tool: ' + ToolName); + var NameValue := Params.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.name is required and must be a non-empty string'); + var ToolName := TJSONString(NameValue).Value; - if not FTools.TryGetValue(ToolName, Tool) then - ResultValue := TValue.From('Error: Tool not found: ' + ToolName) - else if Assigned(Arguments) then - ResultValue := ExecuteTool(Tool, Arguments) - else - begin - // "arguments" is optional on the wire; a tool always receives an object. - EmptyArguments := TJSONObject.Create; - try - ResultValue := ExecuteTool(Tool, EmptyArguments); - finally - EmptyArguments.Free; - end; - end; + var ArgumentsValue := Params.GetValue('arguments'); + if Assigned(ArgumentsValue) and not (ArgumentsValue is TJSONObject) and not (ArgumentsValue is TJSONNull) then + raise EMCPError.InvalidParams('params.arguments must be an object'); + var Arguments: TJSONObject := nil; + if ArgumentsValue is TJSONObject then + Arguments := TJSONObject(ArgumentsValue); - Result := TValue.From(BuildToolCallResponse(ResultValue)); -end; + if not FTools.TryGetValue(ToolName, Tool) then + raise EMCPError.UnknownTool(ToolName); -function TMCPToolsManager.ListTools: TValue; -begin - TLogger.Info('MCP ListTools called'); - Result := TValue.From(BuildToolListResponse); + TLogger.Info('MCP CallTool called for tool: ' + ToolName); + Result := TValue.From(ExecuteTool(Tool, Arguments, Era)); end; -end. \ No newline at end of file +end. From 9ecbb578e7be07dca479a282532823d2f7742674 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:56 +0200 Subject: [PATCH 19/56] feat: content sample tools and resources One small tool per content type (test_simple_text, test_image_content, test_audio_content, test_embedded_resource, test_multiple_content_types, test_error_handling) and the resources test://static-text and test://static-binary, the fixtures the conformance suite calls. logs://recent no longer logs its own reads; project://info names the current protocol revisions and is cacheable for an hour. --- src/MCPServer.dpr | 5 +- src/MCPServer.dproj | 3 + src/Resources/MCPServer.Resource.Logs.pas | 9 +- src/Resources/MCPServer.Resource.Project.pas | 11 +- src/Resources/MCPServer.Resource.Samples.pas | 104 ++++++++++ src/Tools/MCPServer.Tool.ContentSamples.pas | 201 +++++++++++++++++++ 6 files changed, 327 insertions(+), 6 deletions(-) create mode 100644 src/Resources/MCPServer.Resource.Samples.pas create mode 100644 src/Tools/MCPServer.Tool.ContentSamples.pas diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 485e6a2..7ec83e8 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -23,6 +23,7 @@ uses 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.IdHTTPServer in 'Server\MCPServer.IdHTTPServer.pas', MCPServer.StdioTransport in 'Server\MCPServer.StdioTransport.pas', @@ -36,7 +37,9 @@ uses 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.Resource.Samples in 'Resources\MCPServer.Resource.Samples.pas'; var Server: TMCPIdHTTPServer; diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index d61c4c4..537bce6 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -152,6 +152,9 @@ + + + Base diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index cb87fc7..554f7ab 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 @@ -200,6 +201,9 @@ constructor TLogsRecentResource.Create; FName := 'Recent Logs'; FDescription := 'Recent log entries from all categories'; FMimeType := 'application/json'; + // Live data: never cache, never share between callers. + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; end; function TLogsRecentResource.GetResourceData: TLogEntries; @@ -207,10 +211,7 @@ function TLogsRecentResource.GetResourceData: TLogEntries; Logs: TObjectList; begin Result := TLogEntries.Create; - - // Add access log entry - TLogBuffer.Instance.AddLog('INFO', 'Resource accessed: logs://recent', 'ACCESS'); - + Logs := TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES); try Result.Entries.AddRange(Logs); diff --git a/src/Resources/MCPServer.Resource.Project.pas b/src/Resources/MCPServer.Resource.Project.pas index c719540..40ac540 100644 --- a/src/Resources/MCPServer.Resource.Project.pas +++ b/src/Resources/MCPServer.Resource.Project.pas @@ -65,6 +65,9 @@ implementation uses MCPServer.Registration; +const + PROJECT_RESOURCE_TTL_MS = 3600000; + { TProjectInfo } constructor TProjectInfo.Create; @@ -88,6 +91,9 @@ constructor TProjectInfoResource.Create; FName := 'Project Information'; FDescription := 'Basic information about the Delphi MCP Server project'; FMimeType := 'application/json'; + // Static content: an hour of caching, shareable between callers. + FTtlMs := PROJECT_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; end; function TProjectInfoResource.GetResourceData: TProjectInfo; @@ -98,7 +104,8 @@ function TProjectInfoResource.GetResourceData: TProjectInfo; Result.Description := 'A Model Context Protocol (MCP) server implementation in Delphi'; Result.Language := 'Delphi'; Result.Framework := 'Indy HTTP Server (TIdHTTPServer)'; - Result.Protocol := 'MCP ' + MCP_PROTOCOL_VERSION; + Result.Protocol := 'MCP ' + MCP_LATEST_PROTOCOL_VERSION + ' (initialize-based: ' + + MCP_PROTOCOL_VERSION_2025_11_25 + ', ' + MCP_PROTOCOL_VERSION_2025_06_18 + ')'; Result.Transport := 'Streamable HTTP'; Result.Author := 'GDK Software'; Result.Repository := 'https://github.com/GDKsoftware/delphi-mcp-server'; @@ -117,6 +124,8 @@ constructor TProjectReadmeResource.Create; FName := 'Project README'; FDescription := 'README.md file contents'; FMimeType := 'text/markdown'; + FTtlMs := PROJECT_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; end; function TProjectReadmeResource.GetResourceData: TTextContent; diff --git a/src/Resources/MCPServer.Resource.Samples.pas b/src/Resources/MCPServer.Resource.Samples.pas new file mode 100644 index 0000000..042dfec --- /dev/null +++ b/src/Resources/MCPServer.Resource.Samples.pas @@ -0,0 +1,104 @@ +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; + + /// A static text resource. The URIs of these sample resources follow the + /// official conformance suite, which reads them by URI. + TStaticTextResource = class(TMCPResourceBase) + protected + function GetResourceData: TStaticText; override; + public + constructor Create; override; + end; + + /// A static binary resource (a 1x1 PNG), read through IMCPBinaryResource. + TStaticBinaryResource = class(TMCPResourceBase, IMCPBinaryResource) + protected + function GetResourceData: TStaticText; override; + public + constructor Create; override; + function ReadBinary: TBytes; + end; + +implementation + +uses + System.NetEncoding, + MCPServer.Registration, + MCPServer.Tool.ContentSamples; + +const + SAMPLE_RESOURCE_TTL_MS = 3600000; + +{ TStaticTextResource } + +constructor TStaticTextResource.Create; +begin + inherited; + FURI := SAMPLE_TEXT_RESOURCE_URI; + FName := 'Static text'; + FTitle := 'Static text resource'; + FDescription := 'A fixed text resource'; + FMimeType := 'text/plain'; + FTtlMs := SAMPLE_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; +end; + +function TStaticTextResource.GetResourceData: TStaticText; +begin + Result := TStaticText.Create; + Result.Content := SAMPLE_TEXT_RESOURCE_CONTENT; +end; + +{ TStaticBinaryResource } + +constructor TStaticBinaryResource.Create; +begin + inherited; + FURI := 'test://static-binary'; + FName := 'Static binary'; + FTitle := 'Static binary resource'; + FDescription := 'A fixed PNG image'; + FMimeType := 'image/png'; + FTtlMs := SAMPLE_RESOURCE_TTL_MS; + FCacheScope := MCP_CACHE_SCOPE_PUBLIC; +end; + +function TStaticBinaryResource.GetResourceData: TStaticText; +begin + // Text reads of a binary resource hand out the Base64 form. + Result := TStaticText.Create; + Result.Content := SAMPLE_PNG_BASE64; +end; + +function TStaticBinaryResource.ReadBinary: TBytes; +begin + Result := TNetEncoding.Base64.DecodeStringToBytes(SAMPLE_PNG_BASE64); +end; + +initialization + TMCPRegistry.RegisterResource(SAMPLE_TEXT_RESOURCE_URI, + function: IMCPResource + begin + Result := TStaticTextResource.Create; + end); + TMCPRegistry.RegisterResource('test://static-binary', + function: IMCPResource + begin + Result := TStaticBinaryResource.Create; + end); + +end. diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas new file mode 100644 index 0000000..a32cebb --- /dev/null +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -0,0 +1,201 @@ +unit MCPServer.Tool.ContentSamples; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base; + +type + TNoParams = class + end; + + /// Plain text result. The names of these sample tools follow the official + /// conformance suite, which calls them by name. + TSimpleTextTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TNoParams): string; override; + public + constructor Create; override; + end; + + /// One image block (a 1x1 PNG). + TImageContentTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + /// One audio block (a silent WAV). + TAudioContentTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + /// An embedded text resource. + TEmbeddedResourceTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + /// Text, image and an embedded resource in one result. + TMultipleContentTypesTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + /// Always fails with a tool execution error (isError: true). + TErrorHandlingTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TNoParams): string; 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.'; + /// A 1x1 transparent PNG. + SAMPLE_PNG_BASE64 = 'iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mNkYPhfDwAChwGA60e6kgAAAABJRU5ErkJggg=='; + /// A WAV header for 8 kHz mono 8-bit audio with no samples. + SAMPLE_WAV_BASE64 = 'UklGRiQAAABXQVZFZm10IBAAAAABAAEAQB8AAEAfAAABAAgAZGF0YQAAAAA='; + +implementation + +uses + MCPServer.Errors, + MCPServer.Registration, + MCPServer.Tool.Result; + +{ TSimpleTextTool } + +constructor TSimpleTextTool.Create; +begin + inherited; + FName := 'test_simple_text'; + FDescription := 'Returns a plain text result'; + FAnnotations := TJSONObject.Create; + FAnnotations.AddPair('readOnlyHint', TJSONBool.Create(True)); +end; + +function TSimpleTextTool.ExecuteWithParams(const Params: TNoParams): string; +begin + Result := 'This is a simple text response'; +end; + +{ TImageContentTool } + +constructor TImageContentTool.Create; +begin + inherited; + FName := 'test_image_content'; + FDescription := 'Returns an image content block'; +end; + +function TImageContentTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddImage(SAMPLE_PNG_BASE64, 'image/png'); +end; + +{ TAudioContentTool } + +constructor TAudioContentTool.Create; +begin + inherited; + FName := 'test_audio_content'; + FDescription := 'Returns an audio content block'; +end; + +function TAudioContentTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddAudio(SAMPLE_WAV_BASE64, 'audio/wav'); +end; + +{ TEmbeddedResourceTool } + +constructor TEmbeddedResourceTool.Create; +begin + inherited; + FName := 'test_embedded_resource'; + FDescription := 'Returns an embedded resource content block'; +end; + +function TEmbeddedResourceTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create.AddEmbeddedText(SAMPLE_TEXT_RESOURCE_URI, 'text/plain', SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TMultipleContentTypesTool } + +constructor TMultipleContentTypesTool.Create; +begin + inherited; + FName := 'test_multiple_content_types'; + FDescription := 'Returns text, image and embedded resource content in one result'; +end; + +function TMultipleContentTypesTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create + .AddText('Multiple content types example') + .AddImage(SAMPLE_PNG_BASE64, 'image/png') + .AddEmbeddedText(SAMPLE_TEXT_RESOURCE_URI, 'text/plain', SAMPLE_TEXT_RESOURCE_CONTENT); +end; + +{ TErrorHandlingTool } + +constructor TErrorHandlingTool.Create; +begin + inherited; + FName := 'test_error_handling'; + FDescription := 'Always fails with a tool execution error'; +end; + +function TErrorHandlingTool.ExecuteWithParams(const Params: TNoParams): string; +begin + raise EMCPToolError.Create('This tool always fails, as an example of a tool execution error'); +end; + +initialization + TMCPRegistry.RegisterTool('test_simple_text', + function: IMCPTool + begin + Result := TSimpleTextTool.Create; + end); + TMCPRegistry.RegisterTool('test_image_content', + function: IMCPTool + begin + Result := TImageContentTool.Create; + end); + TMCPRegistry.RegisterTool('test_audio_content', + function: IMCPTool + begin + Result := TAudioContentTool.Create; + end); + TMCPRegistry.RegisterTool('test_embedded_resource', + function: IMCPTool + begin + Result := TEmbeddedResourceTool.Create; + end); + TMCPRegistry.RegisterTool('test_multiple_content_types', + function: IMCPTool + begin + Result := TMultipleContentTypesTool.Create; + end); + TMCPRegistry.RegisterTool('test_error_handling', + function: IMCPTool + begin + Result := TErrorHandlingTool.Create; + end); + +end. From 51b4dee4dc119fbc7b52f2abad690d7b27c5a98e Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:56 +0200 Subject: [PATCH 20/56] test: cover tool results, validation, schemas and managers DUnitX fixtures for TMCPToolResult, the serializer, the schema generator and the tools and resources managers in both eras. Goldens re-recorded for the new tools, schemas, error codes and ISO timestamps; conformance baselines pruned of the content-block and binary-resource scenarios that pass now, with resources-templates-read added. --- conformance-baseline-2025-11-25.yml | 7 +- conformance-baseline-2026-07-28.yml | 12 +- tests/MCPServer.Tests.Registration.pas | 4 +- tests/MCPServer.Tests.ResourcesManager.pas | 238 ++++++++++++++++ tests/MCPServer.Tests.Schema.pas | 201 +++++++++++++ tests/MCPServer.Tests.Serializer.pas | 232 +++++++++++++++ tests/MCPServer.Tests.ToolResult.pas | 157 ++++++++++ tests/MCPServer.Tests.ToolsManager.pas | 267 ++++++++++++++++++ tests/MCPServerTests.dpr | 10 +- tests/MCPServerTests.dproj | 8 + tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/post-resources-list.txt | 4 +- .../http/post-resources-read-project-info.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/legacy/resources-list.json | 30 +- .../legacy/resources-read-logs-recent.json | 17 +- .../legacy/resources-read-project-info.json | 2 +- .../legacy/resources-read-server-status.json | 4 +- .../legacy/resources-read-unknown-uri.json | 14 +- .../legacy/resources-read-without-params.json | 11 +- .../golden/legacy/tools-call-empty-name.json | 11 +- .../tools-call-invalid-argument-type.json | 5 +- .../legacy/tools-call-missing-arguments.json | 5 +- .../legacy/tools-call-unknown-tool.json | 14 +- .../legacy/tools-call-without-params.json | 11 +- tests/golden/legacy/tools-list.json | 110 ++++++-- tests/golden/modern/resources-list.json | 36 ++- .../modern/resources-read-project-info.json | 8 +- .../modern/resources-templates-list.json | 6 +- .../modern/tools-call-unknown-tool.json | 19 +- tests/golden/modern/tools-list.json | 116 ++++++-- 32 files changed, 1401 insertions(+), 174 deletions(-) create mode 100644 tests/MCPServer.Tests.ResourcesManager.pas create mode 100644 tests/MCPServer.Tests.Schema.pas create mode 100644 tests/MCPServer.Tests.Serializer.pas create mode 100644 tests/MCPServer.Tests.ToolResult.pas create mode 100644 tests/MCPServer.Tests.ToolsManager.pas diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml index 0d60606..749aaff 100644 --- a/conformance-baseline-2025-11-25.yml +++ b/conformance-baseline-2025-11-25.yml @@ -4,17 +4,14 @@ server: - logging-set-level - completion-complete - - tools-call-image - - tools-call-audio - - tools-call-embedded-resource - - tools-call-mixed-content - tools-call-with-logging - tools-call-with-progress - tools-call-sampling - tools-call-elicitation - elicitation-sep1034-defaults - elicitation-sep1330-enums - - resources-read-binary + # resource templates are not implemented + - resources-templates-read - resources-subscribe - resources-unsubscribe - prompts-list diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index 2fc79ab..d1fe24b 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -4,13 +4,9 @@ server: - server-stateless - completion-complete - - tools-call-image - - tools-call-audio - - tools-call-embedded-resource - - tools-call-mixed-content - tools-call-with-progress - - resources-read-binary - - sep-2164-resource-not-found + # resource templates are not implemented + - resources-templates-read - prompts-list - prompts-get-simple - prompts-get-with-args @@ -27,6 +23,6 @@ server: - input-required-result-result-type - input-required-result-tampered-state - input-required-result-capability-check - # only WARNING checks (MRTR is not implemented); the runner counts them as not passed + # only WARNING checks (MRTR is not implemented, so the tool these call is unknown); the runner counts them as not passed - input-required-result-missing-input-response - - input-required-result-validate-input + - input-required-result-ignore-extra-params diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index 96dfb77..ac46632 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -34,7 +34,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(4, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(10, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; @@ -43,7 +43,7 @@ procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasResource('project://readme')); Assert.IsTrue(TMCPRegistry.HasResource('logs://recent')); Assert.IsTrue(TMCPRegistry.HasResource('server://status')); - Assert.AreEqual(4, Integer(Length(TMCPRegistry.GetResourceURIs))); + Assert.AreEqual(6, Integer(Length(TMCPRegistry.GetResourceURIs))); end; procedure TRegistryTests.ServerStatus_IsRegisteredByDefault; diff --git a/tests/MCPServer.Tests.ResourcesManager.pas b/tests/MCPServer.Tests.ResourcesManager.pas new file mode 100644 index 0000000..2875d58 --- /dev/null +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -0,0 +1,238 @@ +unit MCPServer.Tests.ResourcesManager; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.Resource.Base, + MCPServer.ResourcesManager; + +type + TFailingData = class + end; + + /// A resource whose read raises. + TFailingResource = class(TMCPResourceBase) + protected + function GetResourceData: TFailingData; override; + public + constructor Create; 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_AreEmpty_WithHints; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors; + +{ TFailingResource } + +constructor TFailingResource.Create; +begin + inherited; + FURI := 'test://failing'; + FName := 'Failing'; + FMimeType := 'application/json'; +end; + +function TFailingResource.GetResourceData: TFailingData; +begin + raise Exception.Create('disk on fire'); +end; + +{ TResourcesManagerTests } + +procedure TResourcesManagerTests.Setup; +begin + FManager := TMCPResourcesManager.Create; + FManager.AddResource(TFailingResource.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_AreEmpty_WithHints; +begin + var Modern := FManager.ListResourceTemplates(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.AreEqual(0, (Modern.GetValue('resourceTemplates') as TJSONArray).Count); + Assert.AreEqual('private', Modern.GetValue('cacheScope')); + finally + Modern.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TResourcesManagerTests); + +end. diff --git a/tests/MCPServer.Tests.Schema.pas b/tests/MCPServer.Tests.Schema.pas new file mode 100644 index 0000000..b0f39ee --- /dev/null +++ b/tests/MCPServer.Tests.Schema.pas @@ -0,0 +1,201 @@ +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; + 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; + end; + + TEmptyParams = class + 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; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Schema.Generator; + +{ TSchemaGeneratorTests } + +procedure TSchemaGeneratorTests.Integers_AreInteger_FloatsAreNumber; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('integer', Schema.GetValue('properties.count.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.big.type')); + Assert.AreEqual('number', Schema.GetValue('properties.ratio.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.DateTime_IsStringWithFormat; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('string', Schema.GetValue('properties.when.type')); + Assert.AreEqual('date-time', Schema.GetValue('properties.when.format')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Boolean_And_Enum; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('boolean', Schema.GetValue('properties.flag.type')); + Assert.AreEqual('string', Schema.GetValue('properties.level.type')); + Assert.AreEqual('Mid', Schema.GetValue('properties.level.enum[1]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Set_IsArrayOfEnumNames; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('array', Schema.GetValue('properties.levels.type')); + Assert.AreEqual('string', Schema.GetValue('properties.levels.items.type')); + Assert.AreEqual('High', Schema.GetValue('properties.levels.items.enum[2]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.DynArray_And_List_HaveItems; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('array', Schema.GetValue('properties.names.type')); + Assert.AreEqual('string', Schema.GetValue('properties.names.items.type')); + Assert.AreEqual('array', Schema.GetValue('properties.points.type')); + Assert.AreEqual('object', Schema.GetValue('properties.points.items.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.points.items.properties.x.type')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.NestedObject_HasProperties; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('object', Schema.GetValue('properties.origin.type')); + Assert.AreEqual('integer', Schema.GetValue('properties.origin.properties.y.type')); + Assert.AreEqual('x', Schema.GetValue('properties.origin.required[0]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Attributes_AreApplied; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + Assert.AreEqual('How many', Schema.GetValue('properties.count.description')); + Assert.AreEqual(1, Schema.GetValue('properties.count.minimum')); + Assert.AreEqual(10, Schema.GetValue('properties.count.maximum')); + Assert.AreEqual('When it happened', Schema.GetValue('properties.when.title')); + Assert.AreEqual('uri', Schema.GetValue('properties.code.format')); + Assert.AreEqual('one', Schema.GetValue('properties.score.enum[0]')); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.Optional_IsNotRequired; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TSchemaParams); + try + var Required := Schema.GetValue('required') as TJSONArray; + for var Item in Required do + Assert.AreNotEqual('code', Item.Value); + Assert.AreEqual('count', Required.Items[0].Value); + finally + Schema.Free; + end; +end; + +procedure TSchemaGeneratorTests.NoParameters_ForbidsAdditionalProperties; +begin + var Schema := TMCPSchemaGenerator.GenerateSchema(TEmptyParams); + try + Assert.AreEqual(0, (Schema.GetValue('properties') as TJSONObject).Count); + Assert.IsFalse(Schema.GetValue('additionalProperties')); + Assert.IsNull(Schema.GetValue('required')); + finally + Schema.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TSchemaGeneratorTests); + +end. diff --git a/tests/MCPServer.Tests.Serializer.pas b/tests/MCPServer.Tests.Serializer.pas new file mode 100644 index 0000000..5b25a3f --- /dev/null +++ b/tests/MCPServer.Tests.Serializer.pas @@ -0,0 +1,232 @@ +unit MCPServer.Tests.Serializer; + +interface + +uses + DUnitX.TestFramework, + System.Generics.Collections, + MCPServer.Types; + +type + TColour = (Red, Green, Blue); + TColours = set of TColour; + + TNested = class + private + FLabel: string; + public + property Label_: string read FLabel write FLabel; + end; + + TSampleParams = class + private + FName: string; + FCount: Integer; + FRatio: Double; + FEnabled: Boolean; + FColour: TColour; + FWhen: TDateTime; + FTags: TArray; + FNested: TNested; + FNote: string; + public + destructor Destroy; override; + property Name: string read FName write FName; + property Count: Integer read FCount write FCount; + [Optional] property Ratio: Double read FRatio write FRatio; + [Optional] property Enabled: Boolean read FEnabled write FEnabled; + [Optional] property Colour: TColour read FColour write FColour; + [Optional] property When: TDateTime read FWhen write FWhen; + [Optional] property Tags: TArray read FTags write FTags; + [Optional] property Nested: TNested read FNested write FNested; + [Optional] property Note: string read FNote write FNote; + end; + + 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; + end; + +implementation + +uses + System.SysUtils, + System.DateUtils, + System.JSON, + MCPServer.Serializer; + +{ TSampleParams } + +destructor TSampleParams.Destroy; +begin + FNested.Free; + inherited; +end; + +{ TSerializerTests } + +function TSerializerTests.Deserialize(const Json: string): TSampleParams; +begin + var Obj := TJSONObject.ParseJSONValue(Json) as TJSONObject; + try + Result := TMCPSerializer.Deserialize(Obj); + finally + Obj.Free; + end; +end; + +procedure TSerializerTests.ExpectArgumentError(const Json, Fragment: string); +begin + try + Deserialize(Json).Free; + Assert.Fail('expected EArgumentException for ' + Json); + except + on E: EArgumentException do + Assert.IsTrue(E.Message.Contains(Fragment), E.Message + ' does not mention ' + Fragment); + end; +end; + +procedure TSerializerTests.Deserialize_AllTypes; +begin + var Params := Deserialize('{"name":"n","count":3,"ratio":1.5,"enabled":true,"colour":"Green",' + + '"when":"2026-09-03T10:00:00Z","tags":["a","b"],"nested":{"label_":"x"}}'); + try + Assert.AreEqual('n', Params.Name); + Assert.AreEqual(3, Params.Count); + Assert.AreEqual(1.5, Params.Ratio, 0.0001); + Assert.IsTrue(Params.Enabled); + Assert.AreEqual(Green, Params.Colour); + Assert.AreEqual(2026, YearOf(Params.When)); + Assert.AreEqual(2, Integer(Length(Params.Tags))); + Assert.AreEqual('x', Params.Nested.Label_); + finally + Params.Free; + end; +end; + +procedure TSerializerTests.MissingRequired_Raises; +begin + ExpectArgumentError('{"name":"n"}', 'Missing required parameter "count"'); + ExpectArgumentError('{}', 'Missing required parameter "name"'); +end; + +procedure TSerializerTests.Null_CountsAsAbsent; +begin + ExpectArgumentError('{"name":null,"count":1}', 'Missing required parameter "name"'); + var Params := Deserialize('{"name":"n","count":1,"note":null}'); + try + Assert.AreEqual('', Params.Note); + finally + Params.Free; + end; +end; + +procedure TSerializerTests.WrongType_String_Raises; +begin + ExpectArgumentError('{"name":5,"count":1}', 'Parameter "name": expected a string'); +end; + +procedure TSerializerTests.WrongType_Integer_Raises; +begin + ExpectArgumentError('{"name":"n","count":"two"}', 'Parameter "count": expected an integer'); +end; + +procedure TSerializerTests.Fraction_ForInteger_Raises; +begin + ExpectArgumentError('{"name":"n","count":1.5}', 'expected an integer'); +end; + +procedure TSerializerTests.WrongType_Boolean_Raises; +begin + ExpectArgumentError('{"name":"n","count":1,"enabled":"yes"}', 'expected a boolean'); +end; + +procedure TSerializerTests.UnknownParameter_Raises; +begin + ExpectArgumentError('{"name":"n","count":1,"bogus":1}', 'Unknown parameter "bogus"'); +end; + +procedure TSerializerTests.Enum_ByName_AndInvalidRaises; +begin + var Params := Deserialize('{"name":"n","count":1,"colour":"Blue"}'); + try + Assert.AreEqual(Blue, Params.Colour); + finally + Params.Free; + end; + ExpectArgumentError('{"name":"n","count":1,"colour":"Purple"}', 'Valid values: Red, Green, Blue'); +end; + +procedure TSerializerTests.Serialize_Enum_Set_Array_DateTime; +begin + var Value := TSampleResult.Create; + var Json := TJSONObject.Create; + try + Value.Colour := Blue; + Value.Colours := [Red, Blue]; + Value.Values := [1, 2, 3]; + Value.Child := TNested.Create; + Value.Child.Label_ := 'c'; + Value.Stamp := EncodeDateTime(2026, 9, 3, 10, 30, 0, 0); + TMCPSerializer.Serialize(Value, Json); + + Assert.AreEqual('Blue', Json.GetValue('colour')); + Assert.AreEqual('Red', Json.GetValue('colours[0]')); + Assert.AreEqual('Blue', Json.GetValue('colours[1]')); + Assert.AreEqual(3, (Json.GetValue('values') as TJSONArray).Count); + Assert.AreEqual('c', Json.GetValue('child.label_')); + Assert.IsTrue(Json.GetValue('stamp').StartsWith('2026-09-03T10:30:00')); + finally + Value.Child.Free; + Value.Free; + Json.Free; + end; +end; + +procedure TSerializerTests.Serialize_NilObject_IsNull; +begin + var Value := TSampleResult.Create; + var Json := TJSONObject.Create; + try + TMCPSerializer.Serialize(Value, Json); + Assert.IsTrue(Json.GetValue('child') is TJSONNull); + Assert.AreEqual(0, (Json.GetValue('values') as TJSONArray).Count); + finally + Value.Free; + Json.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TSerializerTests); + +end. diff --git a/tests/MCPServer.Tests.ToolResult.pas b/tests/MCPServer.Tests.ToolResult.pas new file mode 100644 index 0000000..67366e0 --- /dev/null +++ b/tests/MCPServer.Tests.ToolResult.pas @@ -0,0 +1,157 @@ +unit MCPServer.Tests.ToolResult; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TToolResultTests = class + public + [Test] procedure Text_ProducesOneTextBlock; + [Test] procedure Image_Audio_Embedded_Blocks; + [Test] procedure StructuredOnly_GetsTextFallback; + [Test] procedure StructuredArray_LegacyDropsIt_ModernKeepsIt; + [Test] procedure Error_SetsIsError; + [Test] procedure Meta_IsEmitted; + [Test] procedure Annotations_AttachToLastBlock; + [Test] procedure Base64Blob_HasNoLineBreaks; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Result; + +{ TToolResultTests } + +procedure TToolResultTests.Text_ProducesOneTextBlock; +begin + var ToolResult := TMCPToolResult.Text('hello'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Legacy); + try + Assert.AreEqual('text', Json.GetValue('content[0].type')); + Assert.AreEqual('hello', Json.GetValue('content[0].text')); + Assert.IsNull(Json.GetValue('isError')); + Assert.IsNull(Json.GetValue('structuredContent')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Image_Audio_Embedded_Blocks; +begin + var ToolResult := TMCPToolResult.Create + .AddImage(TEncoding.UTF8.GetBytes('png'), 'image/png') + .AddAudio('AAAA', 'audio/wav') + .AddEmbeddedText('test://x', 'text/plain', 'body') + .AddEmbeddedBlob('test://y', 'application/octet-stream', TEncoding.UTF8.GetBytes('bin')) + .AddResourceLink('file:///a.txt', 'a.txt', 'A file', 'text/plain'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.AreEqual(5, (Json.GetValue('content') as TJSONArray).Count); + Assert.AreEqual('image', Json.GetValue('content[0].type')); + Assert.AreEqual('cG5n', Json.GetValue('content[0].data')); + Assert.AreEqual('image/png', Json.GetValue('content[0].mimeType')); + Assert.AreEqual('audio', Json.GetValue('content[1].type')); + Assert.AreEqual('resource', Json.GetValue('content[2].type')); + Assert.AreEqual('body', Json.GetValue('content[2].resource.text')); + Assert.AreEqual('Ymlu', Json.GetValue('content[3].resource.blob')); + Assert.AreEqual('resource_link', Json.GetValue('content[4].type')); + Assert.AreEqual('A file', Json.GetValue('content[4].description')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.StructuredOnly_GetsTextFallback; +begin + var ToolResult := TMCPToolResult.Create.SetStructuredContent(TJSONObject.ParseJSONValue('{"a":1}')); + var Json := ToolResult.ToJson(TMCPProtocolEra.Legacy); + try + Assert.AreEqual('{"a":1}', Json.GetValue('content[0].text')); + Assert.AreEqual(1, Json.GetValue('structuredContent.a')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.StructuredArray_LegacyDropsIt_ModernKeepsIt; +begin + var ToolResult := TMCPToolResult.Text('list').SetStructuredContent(TJSONObject.ParseJSONValue('[1,2]')); + var Legacy := ToolResult.ToJson(TMCPProtocolEra.Legacy); + var Modern := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsNull(Legacy.GetValue('structuredContent'), 'legacy schemas only allow objects'); + Assert.IsTrue(Modern.GetValue('structuredContent') is TJSONArray); + finally + Legacy.Free; + Modern.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Error_SetsIsError; +begin + var ToolResult := TMCPToolResult.Error('boom'); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsTrue(Json.GetValue('isError')); + Assert.AreEqual('boom', Json.GetValue('content[0].text')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Meta_IsEmitted; +begin + var Meta := TJSONObject.Create; + Meta.AddPair('com.example/trace', 'abc'); + var ToolResult := TMCPToolResult.Text('x').SetMeta(Meta); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.AreEqual('abc', Json.GetValue('_meta["com.example/trace"]')); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Annotations_AttachToLastBlock; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var ToolResult := TMCPToolResult.Text('first').AddText('second').WithAnnotations(Annotations); + var Json := ToolResult.ToJson(TMCPProtocolEra.Modern); + try + Assert.IsNull(Json.FindValue('content[0].annotations')); + Assert.AreEqual(0.5, Json.GetValue('content[1].annotations.priority'), 0.0001); + finally + Json.Free; + ToolResult.Free; + end; +end; + +procedure TToolResultTests.Base64Blob_HasNoLineBreaks; +begin + var Bytes: TBytes; + SetLength(Bytes, 300); + for var I := 0 to High(Bytes) do + Bytes[I] := Byte(I); + var Encoded := EncodeBase64Blob(Bytes); + Assert.AreEqual(400, Length(Encoded)); + Assert.IsFalse(Encoded.Contains(#13) or Encoded.Contains(#10)); +end; + +initialization + TDUnitX.RegisterTestFixture(TToolResultTests); + +end. diff --git a/tests/MCPServer.Tests.ToolsManager.pas b/tests/MCPServer.Tests.ToolsManager.pas new file mode 100644 index 0000000..ebf608c --- /dev/null +++ b/tests/MCPServer.Tests.ToolsManager.pas @@ -0,0 +1,267 @@ +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; + + /// A typed tool: structured content plus the text fallback. + TDoublingTool = class(TMCPToolBase) + protected + function ExecuteWithParams(const Params: TStructuredParams): TStructuredOutput; override; + public + constructor Create; override; + end; + + [TestFixture] + TToolsManagerTests = class + private + FManager: TMCPToolsManager; + function Call(const ParamsJson: string; Era: TMCPProtocolEra): TJSONObject; + procedure ExpectError(const ParamsJson: string; Era: TMCPProtocolEra; ExpectedCode: Integer); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure UnknownTool_IsInvalidParams_WithName; + [Test] procedure MissingName_IsInvalidParams; + [Test] procedure ArgumentsNotObject_IsInvalidParams; + [Test] procedure MissingRequiredArgument_IsErrorResult; + [Test] procedure WrongArgumentType_IsErrorResult; + [Test] procedure UnknownArgument_IsErrorResult; + [Test] procedure ToolError_IsErrorResult; + [Test] procedure ContentBlocks_FromToolResult; + [Test] procedure StructuredResult_HasTextFallback; + [Test] procedure List_IsInRegistrationOrder_WithAnnotations; + [Test] procedure List_CacheHints_ModernOnly; + [Test] procedure List_Cursor_IsInvalidParams; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors; + +{ TDoublingTool } + +constructor TDoublingTool.Create; +begin + inherited; + FName := 'doubling'; + FDescription := 'Doubles a number'; +end; + +function TDoublingTool.ExecuteWithParams(const Params: TStructuredParams): TStructuredOutput; +begin + Result := TStructuredOutput.Create; + Result.Doubled := Params.Value * 2; +end; + +{ TToolsManagerTests } + +procedure TToolsManagerTests.Setup; +begin + FManager := TMCPToolsManager.Create; + FManager.AddTool(TDoublingTool.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('doubling', Tools.Items[Tools.Count - 1].GetValue('name'), 'the added tool comes last'); + 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 - 1).ToString + '].inputSchema.properties.value.type')); + finally + Json.Free; + end; +end; + +procedure TToolsManagerTests.List_CacheHints_ModernOnly; +begin + FManager.ListTtlMs := 300000; + FManager.ListCacheScope := MCP_CACHE_SCOPE_PUBLIC; + + var Legacy := FManager.ListTools(nil, TMCPProtocolEra.Legacy).AsType; + var Modern := FManager.ListTools(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Legacy.GetValue('ttlMs')); + Assert.AreEqual(300000, Modern.GetValue('ttlMs')); + Assert.AreEqual('public', Modern.GetValue('cacheScope')); + finally + Legacy.Free; + Modern.Free; + end; +end; + +procedure TToolsManagerTests.List_Cursor_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"cursor":"abc"}') as TJSONObject; + try + try + FManager.ListTools(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TToolsManagerTests); + +end. diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index 817f35f..7012490 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -37,6 +37,9 @@ uses 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.Resource.Samples in '..\src\Resources\MCPServer.Resource.Samples.pas', + MCPServer.Tool.Result in '..\src\Tools\MCPServer.Tool.Result.pas', MCPServer.Tests.Harness in 'MCPServer.Tests.Harness.pas', MCPServer.Tests.Golden in 'MCPServer.Tests.Golden.pas', MCPServer.Tests.Golden.Legacy in 'MCPServer.Tests.Golden.Legacy.pas', @@ -49,7 +52,12 @@ uses MCPServer.Tests.Capabilities in 'MCPServer.Tests.Capabilities.pas', MCPServer.Tests.Golden.Modern in 'MCPServer.Tests.Golden.Modern.pas', MCPServer.Tests.HttpHeaders in 'MCPServer.Tests.HttpHeaders.pas', - MCPServer.Tests.Http in 'MCPServer.Tests.Http.pas'; + MCPServer.Tests.Http in 'MCPServer.Tests.Http.pas', + MCPServer.Tests.ToolResult in 'MCPServer.Tests.ToolResult.pas', + MCPServer.Tests.Serializer in 'MCPServer.Tests.Serializer.pas', + MCPServer.Tests.Schema in 'MCPServer.Tests.Schema.pas', + MCPServer.Tests.ToolsManager in 'MCPServer.Tests.ToolsManager.pas', + MCPServer.Tests.ResourcesManager in 'MCPServer.Tests.ResourcesManager.pas'; procedure RunTests; begin diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 5229059..15e414a 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -111,6 +111,14 @@ + + + + + + + + Base diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 0212436..a57b3de 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 1208 +Content-Length: 2261 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}],"resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"private"}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/post-resources-list.txt b/tests/golden/http/post-resources-list.txt index a562dd9..52dac26 100644 --- a/tests/golden/http/post-resources-list.txt +++ b/tests/golden/http/post-resources-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 591 +Content-Length: 878 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"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":"server://status","name":"server_status","description":"Current server status and health information","mimeType":"application/json"}]}} +{"jsonrpc":"2.0","id":4,"result":{"resources":[{"uri":"server://status","name":"server_status","description":"Current server status and health information","mimeType":"application/json"},{"uri":"logs://recent","name":"Recent Logs","description":"Recent log entries from all categories","mimeType":"application/json"},{"uri":"project://info","name":"Project Information","description":"Basic information about the Delphi MCP Server project","mimeType":"application/json"},{"uri":"project://readme","name":"Project README","description":"README.md file contents","mimeType":"text/markdown"},{"uri":"test://static-text","name":"Static text","title":"Static text resource","description":"A fixed text resource","mimeType":"text/plain"},{"uri":"test://static-binary","name":"Static binary","title":"Static binary resource","description":"A fixed PNG image","mimeType":"image/png"}]}} diff --git a/tests/golden/http/post-resources-read-project-info.txt b/tests/golden/http/post-resources-read-project-info.txt index 8896ccc..c112976 100644 --- a/tests/golden/http/post-resources-read-project-info.txt +++ b/tests/golden/http/post-resources-read-project-info.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 590 +Content-Length: 633 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":5,"result":{"contents":[{"uri":"project://info","mimeType":"application/json","text":"{\"name\":\"delphi-mcp-server\",\"version\":\"1.0.0\",\"description\":\"A Model Context Protocol (MCP) server implementation in Delphi\",\"language\":\"Delphi\",\"framework\":\"Indy HTTP Server (TIdHTTPServer)\",\"protocol\":\"MCP 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\"]}"}]}} +{"jsonrpc":"2.0","id":5,"result":{"contents":[{"uri":"project://info","mimeType":"application/json","text":"{\"name\":\"delphi-mcp-server\",\"version\":\"1.0.0\",\"description\":\"A Model Context Protocol (MCP) server implementation in Delphi\",\"language\":\"Delphi\",\"framework\":\"Indy HTTP Server (TIdHTTPServer)\",\"protocol\":\"MCP 2026-07-28 (initialize-based: 2025-11-25, 2025-06-18)\",\"transport\":\"Streamable HTTP\",\"author\":\"GDK Software\",\"repository\":\"https://github.com/GDKsoftware/delphi-mcp-server\",\"features\":[\"Tools capability\",\"Resources capability\",\"JSON-RPC 2.0 support\",\"CORS support\"]}"}]}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index fbd2127..26e132a 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 1079 +Content-Length: 2132 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index 3d5c72e..88cd3b5 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 1056 +Content-Length: 2109 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{}}},{"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":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"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"]}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/legacy/resources-list.json b/tests/golden/legacy/resources-list.json index 50a91f4..951d5a1 100644 --- a/tests/golden/legacy/resources-list.json +++ b/tests/golden/legacy/resources-list.json @@ -10,10 +10,10 @@ "result": { "resources": [ { - "uri": "project://readme", - "name": "Project README", - "description": "README.md file contents", - "mimeType": "text/markdown" + "uri": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" }, { "uri": "logs://recent", @@ -28,10 +28,24 @@ "mimeType": "application/json" }, { - "uri": "server://status", - "name": "server_status", - "description": "Current server status and health information", - "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 index 0553deb..7cdec3d 100644 --- a/tests/golden/legacy/resources-read-logs-recent.json +++ b/tests/golden/legacy/resources-read-logs-recent.json @@ -21,42 +21,35 @@ "text": { "entries": [ { - "timestamp": "number", + "timestamp": "string", "level": "string", "message": "string", "threadid": "number", "category": "string" }, { - "timestamp": "number", + "timestamp": "string", "level": "string", "message": "string", "threadid": "number", "category": "string" }, { - "timestamp": "number", + "timestamp": "string", "level": "string", "message": "string", "threadid": "number", "category": "string" }, { - "timestamp": "number", + "timestamp": "string", "level": "string", "message": "string", "threadid": "number", "category": "string" }, { - "timestamp": "number", - "level": "string", - "message": "string", - "threadid": "number", - "category": "string" - }, - { - "timestamp": "number", + "timestamp": "string", "level": "string", "message": "string", "threadid": "number", diff --git a/tests/golden/legacy/resources-read-project-info.json b/tests/golden/legacy/resources-read-project-info.json index 22d122d..e02709a 100644 --- a/tests/golden/legacy/resources-read-project-info.json +++ b/tests/golden/legacy/resources-read-project-info.json @@ -15,7 +15,7 @@ { "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 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\"]}" + "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-server-status.json b/tests/golden/legacy/resources-read-server-status.json index 4dde8a1..9fe5372 100644 --- a/tests/golden/legacy/resources-read-server-status.json +++ b/tests/golden/legacy/resources-read-server-status.json @@ -21,8 +21,8 @@ "text": { "status": "string", "uptime": "number", - "starttime": "number", - "currenttime": "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 index df41980..fb5ed0a 100644 --- a/tests/golden/legacy/resources-read-unknown-uri.json +++ b/tests/golden/legacy/resources-read-unknown-uri.json @@ -10,14 +10,12 @@ "expected": { "jsonrpc": "2.0", "id": 17, - "result": { - "contents": [ - { - "uri": "nope://missing", - "mimeType": "text/plain", - "text": "Error: Resource not found: nope://missing" - } - ] + "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 index c5f9daf..babb234 100644 --- a/tests/golden/legacy/resources-read-without-params.json +++ b/tests/golden/legacy/resources-read-without-params.json @@ -7,14 +7,9 @@ "expected": { "jsonrpc": "2.0", "id": 18, - "result": { - "contents": [ - { - "uri": "", - "mimeType": "text/plain", - "text": "Error: Resource not found: " - } - ] + "error": { + "code": -32602, + "message": "params.uri is required" } } } diff --git a/tests/golden/legacy/tools-call-empty-name.json b/tests/golden/legacy/tools-call-empty-name.json index eb64a21..da8239d 100644 --- a/tests/golden/legacy/tools-call-empty-name.json +++ b/tests/golden/legacy/tools-call-empty-name.json @@ -12,14 +12,9 @@ "expected": { "jsonrpc": "2.0", "id": 12, - "result": { - "content": [ - { - "type": "text", - "text": "Error: Invalid tool parameters" - } - ], - "isError": true + "error": { + "code": -32602, + "message": "params.name is required and must be a non-empty string" } } } diff --git a/tests/golden/legacy/tools-call-invalid-argument-type.json b/tests/golden/legacy/tools-call-invalid-argument-type.json index 391f563..2af8f1f 100644 --- a/tests/golden/legacy/tools-call-invalid-argument-type.json +++ b/tests/golden/legacy/tools-call-invalid-argument-type.json @@ -19,9 +19,10 @@ "content": [ { "type": "text", - "text": "0 add 3 = 3" + "text": "Invalid arguments: Parameter \"a\": expected a number" } - ] + ], + "isError": true } } } diff --git a/tests/golden/legacy/tools-call-missing-arguments.json b/tests/golden/legacy/tools-call-missing-arguments.json index afeca94..54dfb0d 100644 --- a/tests/golden/legacy/tools-call-missing-arguments.json +++ b/tests/golden/legacy/tools-call-missing-arguments.json @@ -14,9 +14,10 @@ "content": [ { "type": "text", - "text": "Echo: " + "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 index c5fb316..a2c400e 100644 --- a/tests/golden/legacy/tools-call-unknown-tool.json +++ b/tests/golden/legacy/tools-call-unknown-tool.json @@ -12,14 +12,12 @@ "expected": { "jsonrpc": "2.0", "id": 9, - "result": { - "content": [ - { - "type": "text", - "text": "Error: Tool not found: no_such_tool" - } - ], - "isError": true + "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 index fbc7ceb..4b82b2f 100644 --- a/tests/golden/legacy/tools-call-without-params.json +++ b/tests/golden/legacy/tools-call-without-params.json @@ -7,14 +7,9 @@ "expected": { "jsonrpc": "2.0", "id": 11, - "result": { - "content": [ - { - "type": "text", - "text": "Error: Invalid tool parameters" - } - ], - "isError": true + "error": { + "code": -32602, + "message": "params.name is required" } } } diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json index b3678c0..54a9dcc 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -9,13 +9,50 @@ "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" + ] } }, { @@ -51,39 +88,66 @@ } }, { - "name": "echo", - "description": "Echo a message back to the user", + "name": "test_simple_text", + "description": "Returns a plain text result", "inputSchema": { "type": "object", "properties": { - "message": { - "type": "string", - "description": "Message to echo back" - } }, - "required": [ - "message" - ] + "additionalProperties": false + }, + "annotations": { + "readOnlyHint": true } }, { - "name": "list_files", - "description": "List files in a directory", + "name": "test_image_content", + "description": "Returns an image content block", "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" - ] + "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_error_handling", + "description": "Always fails with a tool execution error", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false } } ] diff --git a/tests/golden/modern/resources-list.json b/tests/golden/modern/resources-list.json index ce79da0..986f19d 100644 --- a/tests/golden/modern/resources-list.json +++ b/tests/golden/modern/resources-list.json @@ -21,10 +21,10 @@ "result": { "resources": [ { - "uri": "project://readme", - "name": "Project README", - "description": "README.md file contents", - "mimeType": "text/markdown" + "uri": "server://status", + "name": "server_status", + "description": "Current server status and health information", + "mimeType": "application/json" }, { "uri": "logs://recent", @@ -39,21 +39,35 @@ "mimeType": "application/json" }, { - "uri": "server://status", - "name": "server_status", - "description": "Current server status and health information", - "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" } - }, - "ttlMs": 0, - "cacheScope": "private" + } } } } diff --git a/tests/golden/modern/resources-read-project-info.json b/tests/golden/modern/resources-read-project-info.json index 320b30e..2a5ef13 100644 --- a/tests/golden/modern/resources-read-project-info.json +++ b/tests/golden/modern/resources-read-project-info.json @@ -24,18 +24,18 @@ { "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 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\"]}" + "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" } - }, - "ttlMs": 0, - "cacheScope": "private" + } } } } diff --git a/tests/golden/modern/resources-templates-list.json b/tests/golden/modern/resources-templates-list.json index d53e717..5c6fefa 100644 --- a/tests/golden/modern/resources-templates-list.json +++ b/tests/golden/modern/resources-templates-list.json @@ -21,15 +21,15 @@ "result": { "resourceTemplates": [ ], + "ttlMs": 0, + "cacheScope": "private", "resultType": "complete", "_meta": { "io.modelcontextprotocol/serverInfo": { "name": "delphi-mcp-server", "version": "1.0.0" } - }, - "ttlMs": 0, - "cacheScope": "private" + } } } } diff --git a/tests/golden/modern/tools-call-unknown-tool.json b/tests/golden/modern/tools-call-unknown-tool.json index b517254..1a79437 100644 --- a/tests/golden/modern/tools-call-unknown-tool.json +++ b/tests/golden/modern/tools-call-unknown-tool.json @@ -21,20 +21,11 @@ "expected": { "jsonrpc": "2.0", "id": 3, - "result": { - "content": [ - { - "type": "text", - "text": "Error: Tool not found: no_such_tool" - } - ], - "isError": true, - "resultType": "complete", - "_meta": { - "io.modelcontextprotocol/serverInfo": { - "name": "delphi-mcp-server", - "version": "1.0.0" - } + "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 index d77f6f6..ef6ef5d 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -20,13 +20,50 @@ "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" + ] } }, { @@ -62,51 +99,78 @@ } }, { - "name": "echo", - "description": "Echo a message back to the user", + "name": "test_simple_text", + "description": "Returns a plain text result", "inputSchema": { "type": "object", "properties": { - "message": { - "type": "string", - "description": "Message to echo back" - } }, - "required": [ - "message" - ] + "additionalProperties": false + }, + "annotations": { + "readOnlyHint": true } }, { - "name": "list_files", - "description": "List files in a directory", + "name": "test_image_content", + "description": "Returns an image content block", "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" - ] + "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_error_handling", + "description": "Always fails with a tool execution error", + "inputSchema": { + "type": "object", + "properties": { + }, + "additionalProperties": false } } ], + "ttlMs": 0, + "cacheScope": "private", "resultType": "complete", "_meta": { "io.modelcontextprotocol/serverInfo": { "name": "delphi-mcp-server", "version": "1.0.0" } - }, - "ttlMs": 0, - "cacheScope": "private" + } } } } From 0e7e923263c88f7e854feda344810c2f34e2c506 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 14:57:56 +0200 Subject: [PATCH 21/56] docs: describe tool results, validation and error codes --- CHANGELOG.md | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++ MIGRATION.md | 50 ++++++++++++++++++++++++++++++++++++++++ README.md | 54 +++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 165 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ae6c690..ffc0ba2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -80,6 +80,33 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). and `UseStdErr := False` is refused with a one-time warning. - README sections "Protocol Versions and Dual-Era Behaviour", the library checklist and "Automated tests". +- `TMCPToolResult` (`MCPServer.Tool.Result`): a builder for tool results with + text, image, audio, embedded resource and resource link content blocks, + `structuredContent`, `_meta`, per-block annotations and `isError`; + `EncodeBase64Blob` encodes without line breaks. +- `TMCPToolBase.ExecuteWithContext(Params, Context)` returning a `TValue` + (a string, a `TMCPToolResult`, a `TJSONObject` for structured content or a + ready-made `TJSONArray` of content blocks) next to `ExecuteWithParams`; + `EMCPToolError` for a failure the tool wants reported as an `isError` result. +- Tool metadata through `IMCPToolMetadata` (`annotations`, `icons`) on every + tool base; resource metadata through `IMCPResourceMetadata` (`title`, `size`, + `annotations`), `IMCPBinaryResource` (`blob` contents) and + `IMCPCacheableResource` (`ttlMs`, `cacheScope`) on `TMCPResourceBase`. +- `TMCPToolsManager` and `TMCPResourcesManager`: `AddTool` / `AddResource` + for instances outside `TMCPRegistry`, `ListTtlMs` and `ListCacheScope` for + the modern list results. +- Schema attributes `SchemaTitle`, `SchemaFormat`, `SchemaMinimum` and + `SchemaMaximum`. +- Example tools `test_simple_text`, `test_image_content`, `test_audio_content`, + `test_embedded_resource`, `test_multiple_content_types` and + `test_error_handling` (`MCPServer.Tool.ContentSamples`) and the resources + `test://static-text` and `test://static-binary` + (`MCPServer.Resource.Samples`): one example per content type, and the + fixtures the conformance suite calls. +- `EMCPError.UnknownTool` and `EMCPError.ResourceNotFound(Uri, Era)`; + `MCP_CACHE_SCOPE_PUBLIC` and `MCP_CACHE_SCOPE_PRIVATE`. +- Tests for the tool result builder, the serializer, the schema generator and + the tools and resources managers in both eras. ### Changed @@ -133,6 +160,40 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). `TLogger.StdoutReserved`. Library consumers that create the transport with console logging enabled and never set `UseStdErr` now get their log lines on stderr instead of corrupting the MCP channel on stdout. +- `tools/call` with an unknown tool answers `-32602` with `data.name` (it + answered an `isError` result "Tool not found"); a missing or empty `name` + and an `arguments` that is not an object are `-32602` as well (they were an + `isError` result "Invalid tool parameters"). +- `resources/read` for an unknown URI answers `-32002` with `data.uri` for + initialize-based clients and `-32602` with `data.uri` for modern clients (it + answered a text content "Error: Resource not found"); a missing `uri` is + `-32602`, a read that raises is `-32603`. +- Tool arguments are checked against the schema before the tool runs: a + missing required parameter, a value of the wrong JSON type, a fraction for an + integer or an unknown enumeration name is an `isError` result that names the + parameter. Missing parameters were silently defaulted and wrong types + coerced. +- Every `tools/call` result has a `content` array; a typed result + (`TMCPToolBase`) gets a text block with the compact JSON next to + `structuredContent`, so clients without structured-content support see it. +- Tools and resources are listed in registration order (they were listed in + dictionary order). +- Generated schemas: integer properties are `integer` (they were `number`), + `TDateTime` is a `string` with `format: date-time`, enumerations, sets, + dynamic arrays, `TList` and nested classes get typed schemas, and a tool + without parameters gets `additionalProperties: false`. +- Serialisation of results and resource data: enumerations by name (they were + written as booleans), sets and dynamic arrays as arrays, `nil` objects as + `null`, `TDateTime` as an ISO 8601 string (the `logs://recent` timestamps and + the `server://status` times were floating-point day numbers). +- `resources/list` carries `title`, `size` and `annotations` when the resource + provides them and omits an empty `description` or `mimeType`. Modern + `tools/list`, `resources/list`, `resources/templates/list` and + `resources/read` results carry `ttlMs` and `cacheScope` from the manager or + the resource. +- `logs://recent` no longer writes an access-log entry on every read; + `project://info` reports `MCP 2026-07-28 (initialize-based: 2025-11-25, + 2025-06-18)` and is cacheable for an hour (`cacheScope: public`). ### Fixed @@ -152,3 +213,6 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). `-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. diff --git a/MIGRATION.md b/MIGRATION.md index 364dcd6..7efa376 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -49,11 +49,61 @@ without `USE_TAURUS_TLS`). `requestState`, `inputResponses` and token-like members redacted. Lower `TLogger.MinLogLevel` to see them. +## Tools and resources + +**An unknown tool is a JSON-RPC error.** `tools/call` with a name that is not +registered answers `-32602` with `data.name`; it used to answer an `isError` +result with the text "Tool not found". A missing or empty `name`, or an +`arguments` that is not an object, is `-32602` too. Modern clients get HTTP +`400` with it, initialize-based clients `200`. + +**An unknown resource is a JSON-RPC error.** `resources/read` answers `-32002` +with `data.uri` for initialize-based clients and `-32602` with `data.uri` for +modern clients; it used to answer a text content "Error: Resource not found". +A read that raises is `-32603`. + +**Arguments are checked against the schema.** A missing required parameter, a +wrong JSON type (a string for a number, a fraction for an integer, a string +for a boolean) or an unknown enumeration name is an `isError` result naming +the parameter, before the tool runs. A parameter that may be absent needs the +`[Optional]` attribute; without it the old behaviour (silently defaulting) +is gone. `null` counts as absent. + +**Generated schemas changed.** Integer properties are `integer` (they were +`number`), `TDateTime` is a `string` with `format: date-time`, enumerations +and sets list their names, and a tool without parameters declares +`additionalProperties: false`. Clients that validate arguments against the +schema now reject `1.5` for an integer. + +**Result and resource JSON changed.** Enumerations are written by name (they +were booleans), sets and dynamic arrays as arrays, `nil` objects as `null` +and `TDateTime` as an ISO 8601 string. The `logs://recent` timestamps and the +`server://status` times are strings now. + +**Tools and resources are listed in registration order.** Anything that +depended on the previous dictionary order should use the names instead. + +**A typed tool result also gets a text block.** `TMCPToolBase` results +carry `structuredContent` and a text block with the same JSON; `content` is +never empty. + ## 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 diff --git a/README.md b/README.md index 544dbd4..28aa1b9 100644 --- a/README.md +++ b/README.md @@ -312,6 +312,38 @@ initialization end. ``` +Arguments are validated against the generated schema before the tool runs: a +missing property without `[Optional]`, a value of the wrong JSON type or an +unknown enumeration name is answered as an `isError` result that names the +parameter. Integer properties are published as `integer`, `TDateTime` as a +`string` with `format: date-time`, enumerations and sets with their names; +`[SchemaTitle]`, `[SchemaFormat]`, `[SchemaMinimum]` and `[SchemaMaximum]` +add the corresponding keywords. + +A tool that returns more than text overrides `ExecuteWithContext` and builds +a `TMCPToolResult` (`MCPServer.Tool.Result`): + +```pascal +function TChartTool.ExecuteWithContext(const AParams: TChartParams; + const Context: IMCPRequestContext): TValue; +begin + Result := TMCPToolResult.Create + .AddText('Chart for ' + AParams.Series) + .AddImage(RenderPng(AParams), 'image/png') + .AddResourceLink('chart://' + AParams.Series, AParams.Series, '', 'image/png'); +end; +``` + +The builder also has `AddAudio`, `AddEmbeddedText`, `AddEmbeddedBlob`, +`WithAnnotations` (for the last block), `SetStructuredContent`, `SetMeta` and +`SetError`. Raise `EMCPToolError` for a failure the model should see as an +`isError` result; the request context gives the protocol era and the +client's `_meta`. Tools that inherit from `TMCPToolBase` return an +object that becomes `structuredContent` plus a text block with the same +JSON. Set `FAnnotations` (for example `readOnlyHint`) or `FIcons` in the +constructor to publish them in `tools/list`. `MCPServer.Tool.ContentSamples` +has one small example per content type. + ### Creating Custom Resources ```pascal @@ -370,6 +402,15 @@ 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`. + ## Integration with Claude Code Configure using the Streamable HTTP transport: @@ -470,15 +511,22 @@ The Inspector provides a web interface to interact with your MCP server, making - **get_time**: Get the current server time - **list_files**: List files in a directory - **calculate**: Perform basic arithmetic calculations +- **test_simple_text**, **test_image_content**, **test_audio_content**, + **test_embedded_resource**, **test_multiple_content_types**, + **test_error_handling**: one small tool per content type and one that + fails, from `MCPServer.Tool.ContentSamples`; the conformance suite calls + these by name ## Available Example resources -The server provides four resources accessible via URIs: +The server provides six resources 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 (request and connection counters) +- **test://static-text** - A fixed text resource +- **test://static-binary** - A fixed PNG image, delivered as a `blob` ## Configuration From 0ed445e71f08504fd21d0cd1856fcbe47fcb4246 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 15:56:37 +0200 Subject: [PATCH 22/56] feat: rewrite the stdio transport for spec-correct framing and cancellation UTF-8 byte streams (MCPServer.StdioChannel) replace Text I/O, which decoded stdin with the console code page and mangled non-ASCII input. A reader thread answers notifications, client responses and legacy ping inline; every other request goes through a queue to MaxConcurrentRequests worker threads (default 1, so responses keep arriving in order). notifications/cancelled stops the named request and it gets no response (IMCPRequestContext.IsCancelled/CheckCancelled/Cancel, IMCPRequestTracker). A request with _meta.progressToken gets notifications/progress before its response (IMCPRequestContext.ReportProgress, monotonic and throttled). On EOF, in-flight work drains for ShutdownDrainMs before the rest is cancelled, so the process always exits promptly. A stdio server never writes settings.ini next to the executable; the console-control and signal handlers, and the debug leak report, are skipped in stdio mode. --- settings.ini.example | 2 + src/Core/MCPServer.Settings.pas | 9 + src/MCPServer.dpr | 27 +- src/MCPServer.dproj | 1 + src/Protocol/MCPServer.Errors.pas | 4 + src/Protocol/MCPServer.JsonRpcProcessor.pas | 78 +++- src/Protocol/MCPServer.RequestContext.pas | 104 ++++- src/Protocol/MCPServer.Types.pas | 39 ++ src/Server/MCPServer.StdioChannel.pas | 214 +++++++++ src/Server/MCPServer.StdioTransport.pas | 472 ++++++++++++++++++-- 10 files changed, 889 insertions(+), 61 deletions(-) create mode 100644 src/Server/MCPServer.StdioChannel.pas diff --git a/settings.ini.example b/settings.ini.example index 5f6225f..8cbde63 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -27,6 +27,8 @@ MaxRequestBodyBytes=4194304 MaxJsonDepth=64 ; Indy connection limit; 0 = unlimited MaxConnections=0 +; 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 diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index ce9096b..0824d31 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -34,6 +34,7 @@ TMCPSettings = class FMaxRequestBodyBytes: Integer; FMaxJsonDepth: Integer; FMaxConnections: Integer; + FMaxConcurrentRequests: Integer; FSecurityAllowedOrigins: string; function GetProtocol: string; function GetAllowedOrigins: string; @@ -90,6 +91,9 @@ TMCPSettings = class property MaxJsonDepth: Integer read FMaxJsonDepth write FMaxJsonDepth; /// [Server] MaxConnections: Indy connection limit; 0 = unlimited. property MaxConnections: Integer read FMaxConnections write FMaxConnections; + /// [Server] MaxConcurrentRequests: worker threads of the stdio transport. + /// 1 (default) answers requests in the order they arrive. + property MaxConcurrentRequests: Integer read FMaxConcurrentRequests write FMaxConcurrentRequests; /// [Security] AllowedOrigins: origins that pass the Origin check next to /// the loopback origins. Falls back to [CORS] AllowedOrigins when empty. property SecurityAllowedOrigins: string read FSecurityAllowedOrigins write FSecurityAllowedOrigins; @@ -98,6 +102,7 @@ TMCPSettings = class const DEFAULT_MAX_REQUEST_BODY_BYTES = 4 * 1024 * 1024; const DEFAULT_MAX_JSON_DEPTH = 64; + const DEFAULT_MAX_CONCURRENT_REQUESTS = 1; end; implementation @@ -156,6 +161,7 @@ procedure TMCPSettings.LoadDefaults; FEndpointInfoPath := ''; FMaxRequestBodyBytes := DEFAULT_MAX_REQUEST_BODY_BYTES; FMaxJsonDepth := DEFAULT_MAX_JSON_DEPTH; + FMaxConcurrentRequests := DEFAULT_MAX_CONCURRENT_REQUESTS; FMaxConnections := 0; FSecurityAllowedOrigins := ''; end; @@ -198,6 +204,7 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); IniFile.WriteString('Security', '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); @@ -245,6 +252,7 @@ procedure TMCPSettings.LoadFromFile; FEndpointInfoPath := IniFile.ReadString('Server', 'EndpointInfoPath', FEndpointInfoPath); FMaxRequestBodyBytes := IniFile.ReadInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); FMaxJsonDepth := IniFile.ReadInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + FMaxConcurrentRequests := IniFile.ReadInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); FMaxConnections := IniFile.ReadInteger('Server', 'MaxConnections', FMaxConnections); FSecurityAllowedOrigins := IniFile.ReadString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); @@ -296,6 +304,7 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteString('Server', 'EndpointInfoPath', FEndpointInfoPath); IniFile.WriteInteger('Server', 'MaxRequestBodyBytes', FMaxRequestBodyBytes); IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); + IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 7ec83e8..99429a6 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -27,6 +27,7 @@ uses MCPServer.Resource.Base in 'Resources\MCPServer.Resource.Base.pas', MCPServer.IdHTTPServer in 'Server\MCPServer.IdHTTPServer.pas', MCPServer.StdioTransport in 'Server\MCPServer.StdioTransport.pas', + MCPServer.StdioChannel in 'Server\MCPServer.StdioChannel.pas', MCPServer.JsonRpcProcessor in 'Protocol\MCPServer.JsonRpcProcessor.pas', MCPServer.CoreManager in 'Managers\MCPServer.CoreManager.pas', MCPServer.ToolsManager in 'Managers\MCPServer.ToolsManager.pas', @@ -122,7 +123,9 @@ procedure RunStdioServer; var StdioTransport: TMCPStdioTransport; begin - Settings := TMCPSettings.Create; + // A stdio server is spawned by its client; it reads settings.ini when + // present but never writes one next to the executable. + Settings := TMCPSettings.Create('', False); TLogger.Info('Delphi MCP Server v' + Settings.ServerVersion); TLogger.Info('================================'); @@ -174,20 +177,29 @@ begin TLogger.LogToConsole := True; TLogger.MinLogLevel := TLogLevel.Info; - ReportMemoryLeaksOnShutdown := True; + {$IFDEF DEBUG} + // The leak report is a dialog on Windows; a stdio server has no place for it. + ReportMemoryLeaksOnShutdown := not HasStdioFlag; + {$ENDIF} IsMultiThread := True; // Create shutdown event ShutdownEvent := TEvent.Create(nil, True, False, ''); try - // Set up signal handlers + // Set up signal handlers. Over stdio the client ends the server by + // closing stdin; a signal keeps its default meaning (terminate) instead + // of setting an event nobody waits on. {$IFDEF MSWINDOWS} - SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); + if not HasStdioFlag then + SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); {$ENDIF} {$IFDEF POSIX} - signal(SIGINT, @SignalHandler); - signal(SIGTERM, @SignalHandler); + if not HasStdioFlag then + begin + signal(SIGINT, @SignalHandler); + signal(SIGTERM, @SignalHandler); + end; {$ENDIF} try @@ -204,7 +216,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 537bce6..0f12633 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -153,6 +153,7 @@ + diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index c873b2d..55333a8 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -52,6 +52,10 @@ EMCPError = class(Exception) /// an isError result that the model can act on, not a protocol error. EMCPToolError = class(Exception); + /// Raised by IMCPRequestContext.CheckCancelled once the client cancelled + /// the request. The processor sends no response for it. + EMCPRequestCancelled = class(Exception); + const HTTP_STATUS_OK = 200; HTTP_STATUS_ACCEPTED = 202; diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 2b4b4b6..bff7cb1 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -22,6 +22,8 @@ TMCPProcessResult = record HttpStatus: Integer; Era: TMCPProtocolEra; IsNotification: Boolean; + /// True when the request was cancelled by the client; Body is empty. + Cancelled: Boolean; end; /// Transport-independent JSON-RPC pipeline: parse, validate the message @@ -47,6 +49,8 @@ TMCPJsonRpcProcessor = class 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); @@ -69,6 +73,10 @@ TMCPJsonRpcProcessor = class /// Raises EMCPError with the HTTP status a modern transport must use. function BuildRequestContext(const Method: string; const Params: TJSONObject; const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; + /// The JSON-RPC error response body for an error a transport detected + /// itself (a duplicate id, an overlong line). The error's data is + /// detached into the body. + function BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; /// Server identity and protocol options. A processor created without @@ -327,7 +335,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa end; Exit(TMCPRequestContext.Create(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry)); + Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; // 2. initialize without modern _meta selects the legacy era and negotiates @@ -342,7 +350,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa Requested := TJSONString(RequestedValue).Value; end; Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), - Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry)); + Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; // 3. A modern-only method without _meta is a malformed modern request. @@ -363,7 +371,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa 'Unsupported MCP-Protocol-Version header: ' + Header, nil, HTTP_STATUS_BAD_REQUEST); Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry)); + Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; // 5. Legacy, with the version negotiated on this process when known. @@ -374,7 +382,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa Version := MCP_LATEST_LEGACY_PROTOCOL_VERSION; Result := TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Version, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry); + Hints.LegacySession, FManagerRegistry, Hints.Sink); end; function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Params: TJSONObject; @@ -387,6 +395,12 @@ function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Pa TLogger.Info('Notification received: ' + Method); + if Method = MCP_METHOD_NOTIFICATIONS_CANCELLED then + begin + HandleCancelled(Params, Hints); + Exit; + end; + var Manager: IMCPCapabilityManager := nil; if Assigned(FManagerRegistry) then Manager := FManagerRegistry.GetManagerForMethod(Method); @@ -401,6 +415,41 @@ function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Pa end; end; +procedure TMCPJsonRpcProcessor.HandleCancelled(const Params: TJSONObject; const Hints: TMCPTransportHints); +begin + // Only a transport that tracks its requests can act on the notification. + if not Assigned(Hints.Tracker) or not Assigned(Params) then + Exit; + + var RequestId := TMCPRequestId.FromJson(Params.GetValue('requestId')); + if not RequestId.IsPresent then + begin + TLogger.Warning('notifications/cancelled without a usable requestId'); + Exit; + end; + + var Reason := ''; + var ReasonValue := Params.GetValue('reason'); + if ReasonValue is TJSONString 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; + +function TMCPJsonRpcProcessor.CancelledResult(Era: TMCPProtocolEra): TMCPProcessResult; +begin + Result := Default(TMCPProcessResult); + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Era; + Result.Cancelled := True; +end; + +function TMCPJsonRpcProcessor.BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; +begin + Result := ErrorResult(TMCPProtocolEra.Legacy, RequestId, Error).Body; +end; + function TMCPJsonRpcProcessor.DispatchRequest(const Context: IMCPRequestContext; const Params: TJSONObject): TValue; var ManagerEx: IMCPCapabilityManagerEx; @@ -631,7 +680,24 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; Context := BuildRequestContext(Method, Params, RequestId, Hints); Era := Context.Era; - var ExecuteResult := DispatchRequest(Context, Params); + var ExecuteResult: TValue; + if Assigned(Hints.Tracker) then + Hints.Tracker.Track(Context); + try + ExecuteResult := DispatchRequest(Context, Params); + finally + if Assigned(Hints.Tracker) then + Hints.Tracker.Untrack(Context); + end; + + // A cancelled request gets no response, whether or not the handler + // noticed the cancellation. + if Context.IsCancelled then + begin + if ExecuteResult.IsObject then + ExecuteResult.AsObject.Free; + Exit(CancelledResult(Era)); + end; var Response := TJSONObject.Create; try @@ -648,6 +714,8 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; Result.Era := Era; Result.IsNotification := False; except + on E: EMCPRequestCancelled do + Result := CancelledResult(Era); on E: EMCPError do Result := ErrorResult(Era, RequestId, E); on E: Exception do diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas index 206b6ac..aac6fa9 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -4,9 +4,15 @@ interface uses System.SysUtils, + System.Classes, System.JSON, MCPServer.Types; +const + /// Progress notifications for one request are sent at most this often, + /// except for the one that reaches the total. + PROGRESS_MIN_INTERVAL_MS = 50; + type /// What the transport knows about a request before the processor sees it. TMCPTransportHints = record @@ -21,11 +27,20 @@ TMCPTransportHints = record RemoteAddress: string; /// Per-process legacy state (stdio); nil for stateless transports. LegacySession: TMCPLegacySession; + /// Channel for request-scoped notifications (progress); nil when the + /// transport cannot deliver them before the response. + Sink: IMCPMessageSink; + /// In-flight bookkeeping for notifications/cancelled; nil when the + /// transport signals cancellation another way. + Tracker: IMCPRequestTracker; /// No headers, no session: the plain JSON-RPC layer. class function None: TMCPTransportHints; static; /// stdio: no headers, one session slot per process. - class function ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; static; + class function ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; overload; static; + /// stdio with a channel for progress notifications and cancellation. + class function ForStdio(const Session: TMCPLegacySession; const Sink: IMCPMessageSink; + const Tracker: IMCPRequestTracker): TMCPTransportHints; overload; static; /// HTTP: the MCP-Protocol-Version header, empty and HasHeader False when absent. class function ForHttp(const HasVersionHeader: Boolean; const VersionHeader: string): TMCPTransportHints; static; end; @@ -40,12 +55,19 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) FMeta: TJSONObject; FLegacySession: TMCPLegacySession; FManagerRegistry: IMCPManagerRegistry; + FSink: IMCPMessageSink; + FCancelled: Integer; + FProgressSent: Boolean; + FLastProgress: Double; + FLastProgressTick: UInt64; function MetaObject(const Key: string): TJSONObject; public - /// Meta is cloned; the context owns its copy. + /// Meta is cloned; the context owns its copy. Sink is where progress + /// notifications go; nil disables them. constructor Create(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; const ARequestId: TMCPRequestId; const AMeta: TJSONObject; - const ALegacySession: TMCPLegacySession; const AManagerRegistry: IMCPManagerRegistry); + const ALegacySession: TMCPLegacySession; const AManagerRegistry: IMCPManagerRegistry; + const ASink: IMCPMessageSink = nil); destructor Destroy; override; function GetEra: TMCPProtocolEra; @@ -63,6 +85,9 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) 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 = ''); /// The context of the request the calling thread is serving, or nil. class function Current: IMCPRequestContext; @@ -93,6 +118,14 @@ class function TMCPTransportHints.ForStdio(const Session: TMCPLegacySession): TM 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); @@ -105,7 +138,7 @@ class function TMCPTransportHints.ForHttp(const HasVersionHeader: Boolean; const constructor TMCPRequestContext.Create(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; const ARequestId: TMCPRequestId; const AMeta: TJSONObject; const ALegacySession: TMCPLegacySession; - const AManagerRegistry: IMCPManagerRegistry); + const AManagerRegistry: IMCPManagerRegistry; const ASink: IMCPMessageSink); begin inherited Create; FEra := AEra; @@ -116,6 +149,7 @@ constructor TMCPRequestContext.Create(AEra: TMCPProtocolEra; const AProtocolVers FMeta := TJSONObject(AMeta.Clone); FLegacySession := ALegacySession; FManagerRegistry := AManagerRegistry; + FSink := ASink; end; destructor TMCPRequestContext.Destroy; @@ -236,12 +270,70 @@ procedure TMCPRequestContext.RequireClientCapability(const Path: string); function TMCPRequestContext.IsCancelled: Boolean; begin - Result := False; + Result := AtomicCmpExchange(FCancelled, 0, 0) <> 0; end; procedure TMCPRequestContext.CheckCancelled; begin - // Cancellation is not wired to a transport yet; nothing to check. + if IsCancelled then + raise EMCPRequestCancelled.Create('Request ' + FRequestId.AsText + ' was cancelled by the client'); +end; + +procedure TMCPRequestContext.Cancel; +begin + AtomicExchange(FCancelled, 1); +end; + +function TMCPRequestContext.HasProgressToken: Boolean; +begin + var Token := GetProgressToken; + // A whole-valued number or a string; TJSONNumber must be checked first + // since it descends from TJSONString. + if not Assigned(Token) then + Exit(False); + if Token is TJSONNumber then + Exit(Frac(TJSONNumber(Token).AsDouble) = 0); + Result := Token is TJSONString; +end; + +procedure TMCPRequestContext.ReportProgress(const Progress, Total: Double; const Message: string); +const + JSON_RPC_VERSION = '2.0'; +begin + // Nothing to deliver without a token or a channel, and nothing more for a + // request the client cancelled. + if not Assigned(FSink) or not HasProgressToken or IsCancelled then + Exit; + + var Completes := (Total >= 0) and (Progress >= Total); + var Tick := TThread.GetTickCount64; + if FProgressSent then + begin + if Progress <= FLastProgress then + Exit; + if (Tick - FLastProgressTick < PROGRESS_MIN_INTERVAL_MS) and not Completes then + Exit; + end; + FProgressSent := True; + FLastProgress := Progress; + FLastProgressTick := Tick; + + var Notification := TJSONObject.Create; + try + Notification.AddPair('jsonrpc', JSON_RPC_VERSION); + Notification.AddPair('method', MCP_METHOD_NOTIFICATIONS_PROGRESS); + var Params := TJSONObject.Create; + Notification.AddPair('params', Params); + Params.AddPair(MCP_META_PROGRESS_TOKEN, TJSONValue(GetProgressToken.Clone)); + Params.AddPair('progress', TJSONNumber.Create(Progress)); + if Total >= 0 then + Params.AddPair('total', TJSONNumber.Create(Total)); + if Message <> '' then + Params.AddPair('message', Message); + FSink.Send(Notification.ToJSON); + finally + Notification.Free; + end; end; class function TMCPRequestContext.Current: IMCPRequestContext; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index e4dd616..3983905 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -54,6 +54,9 @@ interface MCP_META_SUBSCRIPTION_ID = 'io.modelcontextprotocol/subscriptionId'; MCP_META_PROGRESS_TOKEN = 'progressToken'; + MCP_METHOD_NOTIFICATIONS_CANCELLED = 'notifications/cancelled'; + MCP_METHOD_NOTIFICATIONS_PROGRESS = 'notifications/progress'; + // Cache scopes (server/utilities/caching.mdx) MCP_CACHE_SCOPE_PUBLIC = 'public'; MCP_CACHE_SCOPE_PRIVATE = 'private'; @@ -197,6 +200,14 @@ TMCPLegacySession = class property ProtocolVersion: string read FProtocolVersion write FProtocolVersion; end; + /// Where a transport delivers the server-to-client messages that belong to + /// a request in flight (notifications/progress). The stdio transport + /// writes them to stdout; a transport without such a channel passes nil. + IMCPMessageSink = interface + ['{2B7D4E90-6C1A-4F3B-9E8D-5A0C1B2D3E4F}'] + procedure Send(const Json: string); + end; + /// What a handler may know about the request it is serving. Built once /// per request by the JSON-RPC processor and reachable through /// TMCPRequestContext.Current while the handler runs. @@ -220,8 +231,23 @@ TMCPLegacySession = class function HasClientCapability(const Path: string): Boolean; /// Raises EMCPError -32021 when the capability was not declared. procedure RequireClientCapability(const Path: string); + /// True once the client cancelled the request (notifications/cancelled + /// on stdio). function IsCancelled: Boolean; + /// Raises EMCPRequestCancelled when the request was cancelled; the + /// processor then sends no response. Long-running handlers call this + /// between steps. procedure CheckCancelled; + /// Marks the request cancelled. Called by the transport. + procedure Cancel; + /// True when the request carries _meta.progressToken. + function HasProgressToken: Boolean; + /// Sends notifications/progress for this request when it carries a + /// progress token and the transport can deliver it; otherwise nothing + /// happens. Progress must increase: a value at or below the last one is + /// dropped, and so is a notification within PROGRESS_MIN_INTERVAL_MS of + /// the previous one unless it reaches Total. Total < 0 means unknown. + procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); property Era: TMCPProtocolEra read GetEra; property ProtocolVersion: string read GetProtocolVersion; @@ -239,6 +265,19 @@ TMCPLegacySession = class property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; end; + /// In-flight bookkeeping a transport keeps so notifications/cancelled can + /// reach the request it names. The processor binds every request context + /// while its handler runs. + IMCPRequestTracker = interface + ['{8C5E1F2A-3B4D-4E6F-A1B2-C3D4E5F6A7B8}'] + /// Binds the context to its request id for the duration of the handler. + /// A request cancelled before its handler started begins cancelled. + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + /// Cancels the request with that id; False when it is unknown or done. + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + end; + /// Managers that want the request context receive it through this /// interface; the processor falls back to IMCPCapabilityManager.ExecuteMethod. IMCPCapabilityManagerEx = interface diff --git a/src/Server/MCPServer.StdioChannel.pas b/src/Server/MCPServer.StdioChannel.pas new file mode 100644 index 0000000..9a45c99 --- /dev/null +++ b/src/Server/MCPServer.StdioChannel.pas @@ -0,0 +1,214 @@ +unit MCPServer.StdioChannel; + +/// The byte-level side of the stdio transport: one UTF-8 encoded JSON-RPC +/// message per line, LF-delimited, no BOM, and the standard handles as +/// streams. Text I/O is deliberately not used: it decodes stdin with the +/// console code page on Windows and would alter every non-ASCII character. + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + MCPServer.Types; + +type + TMCPLineStatus = ( + /// A complete line was decoded. + Ok, + /// The line exceeded the limit; it was skipped up to its newline. + TooLong, + /// The bytes were not valid UTF-8; the line was skipped. + InvalidUtf8 + ); + + /// Reads LF-delimited UTF-8 lines from a byte stream. A trailing CR is + /// dropped, a leading byte-order mark is ignored, the last line needs no + /// newline. + TMCPLineReader = class + strict private + const READ_CHUNK_BYTES = 64 * 1024; + strict private + FStream: TStream; + FMaxLineBytes: Integer; + FPending: TBytes; + FPendingLength: Integer; + FAtStart: Boolean; + FEndOfStream: Boolean; + function Fill: Boolean; + function DecodeLine(Start, Count: Integer; out Line: string): TMCPLineStatus; + public + constructor Create(Stream: TStream; MaxLineBytes: Integer); + /// False at the end of the stream. Status says whether Line is usable. + function ReadLine(out Line: string; out Status: TMCPLineStatus): Boolean; + end; + + /// Writes one message per line, UTF-8 with a bare LF, and serialises + /// concurrent writers so lines never interleave. Any newline inside a + /// message is replaced by a space: the framing does not allow it. + TMCPLineWriter = class(TInterfacedObject, IMCPMessageSink) + strict private + FStream: TStream; + FLock: TCriticalSection; + public + constructor Create(Stream: TStream); + destructor Destroy; override; + procedure Send(const Json: string); + end; + +/// Streams over the process's standard input and output handles. +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 + // Grow the buffer when a line is longer than a chunk, then append a chunk. + if Length(FPending) - FPendingLength < READ_CHUNK_BYTES then + SetLength(FPending, Length(FPending) + READ_CHUNK_BYTES); + + var BytesRead := FStream.Read(FPending[FPendingLength], READ_CHUNK_BYTES); + if BytesRead <= 0 then + begin + FEndOfStream := True; + Exit(False); + end; + + if FAtStart then + begin + FAtStart := False; + if (BytesRead >= 3) and (FPending[0] = $EF) and (FPending[1] = $BB) and (FPending[2] = $BF) then + begin + Move(FPending[3], FPending[0], BytesRead - 3); + Dec(BytesRead, 3); + end; + end; + + Inc(FPendingLength, BytesRead); + Result := True; +end; + +function TMCPLineReader.DecodeLine(Start, Count: Integer; out Line: string): TMCPLineStatus; +begin + if (Count > 0) and (FPending[Start + Count - 1] = 13) then + Dec(Count); + + if Count > FMaxLineBytes then + begin + Line := ''; + Exit(TMCPLineStatus.TooLong); + end; + + try + Line := TEncoding.UTF8.GetString(FPending, Start, Count); + except + // Some malformed sequences raise instead of decoding leniently. + Line := ''; + Exit(TMCPLineStatus.InvalidUtf8); + end; + // The RTL decoder answers an empty string for other malformed input. + if (Line = '') and (Count > 0) then + Exit(TMCPLineStatus.InvalidUtf8); + Result := TMCPLineStatus.Ok; +end; + +function TMCPLineReader.ReadLine(out Line: string; out Status: TMCPLineStatus): Boolean; +begin + Line := ''; + Status := TMCPLineStatus.Ok; + var ScanFrom := 0; + + while True do + begin + for var I := ScanFrom to FPendingLength - 1 do + if FPending[I] = 10 then + begin + Status := DecodeLine(0, I, Line); + var Remaining := FPendingLength - (I + 1); + if Remaining > 0 then + Move(FPending[I + 1], FPending[0], Remaining); + FPendingLength := Remaining; + Exit(True); + end; + ScanFrom := FPendingLength; + + if FEndOfStream or not Fill then + begin + // The final line may end without a newline. + if FPendingLength = 0 then + Exit(False); + Status := DecodeLine(0, FPendingLength, Line); + FPendingLength := 0; + Exit(True); + end; + end; +end; + +{ TMCPLineWriter } + +constructor TMCPLineWriter.Create(Stream: TStream); +begin + inherited Create; + FStream := Stream; + FLock := TCriticalSection.Create; +end; + +destructor TMCPLineWriter.Destroy; +begin + FLock.Free; + inherited; +end; + +procedure TMCPLineWriter.Send(const Json: string); +begin + var Line := Json.Replace(#13, ' ').Replace(#10, ' ') + #10; + var Bytes := TEncoding.UTF8.GetBytes(Line); + FLock.Enter; + try + FStream.WriteBuffer(Bytes, Length(Bytes)); + finally + FLock.Leave; + end; +end; + +end. diff --git a/src/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index d790337..c6f24a5 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -1,37 +1,262 @@ unit MCPServer.StdioTransport; +/// The stdio transport: JSON-RPC messages on stdin, one per line, answered +/// on stdout; every log line on stderr. +/// +/// A reader thread (the calling thread of Run) parses each line. Messages +/// without an id and legacy ping are handled on that thread at once, so a +/// notifications/cancelled reaches a request that is still running. Other +/// requests go through a queue to MaxConcurrentRequests worker threads +/// (default 1: responses in request order). A cancelled request gets no +/// response. When stdin closes, queued and running work is drained for +/// ShutdownDrainMs, the rest is cancelled, and Run returns. + 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 + /// The requests a stdio process has accepted and not yet answered, keyed + /// by id, so notifications/cancelled can reach them. + 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; + /// Claims the id when it is read; False when that id is still in flight. + function Reserve(const RequestId: TMCPRequestId): Boolean; + /// Drops the claim once the request is answered or refused. + procedure Release(const RequestId: TMCPRequestId); + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + /// Cancels everything still in flight; returns how many there were. + 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; + strict private FManagerRegistry: IMCPManagerRegistry; FCoreManager: IMCPCapabilityManager; FJsonRpcProcessor: TMCPJsonRpcProcessor; FLegacySession: TMCPLegacySession; + FTracker: TMCPStdioRequestTracker; + FTrackerIntf: IMCPRequestTracker; + FWriter: IMCPMessageSink; + FQueue: TThreadedQueue; + FWorkersDone: TCountdownEvent; + FShutdownDrainMs: 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 StartWorkers; + procedure DrainAndStop; + procedure ReadLoop(InputStream: TStream); + private + procedure WorkerLoop; public constructor Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); destructor Destroy; override; + /// Serves the process's standard input and output until stdin closes. procedure Run; + /// Serves the given streams until the input ends; what Run does with the + /// standard handles. Both streams stay owned by the caller. + procedure RunWith(InputStream, OutputStream: TStream); /// Server identity and protocol options; assign before Run. Without it the /// processor uses the defaults (settings.ini next to the executable). property Settings: TMCPSettings read GetSettings write SetSettings; + /// How long Run waits for in-flight requests after stdin closed before + /// cancelling them. Default DEFAULT_SHUTDOWN_DRAIN_MS. + property ShutdownDrainMs: Integer read FShutdownDrainMs write FShutdownDrainMs; end; implementation +uses + MCPServer.Errors; + +type + TMCPStdioWorker = class(TThread) + strict private + FTransport: TMCPStdioTransport; + protected + procedure Execute; override; + public + constructor Create(Transport: TMCPStdioTransport); + end; + +{ TMCPStdioWorker } + +constructor TMCPStdioWorker.Create(Transport: TMCPStdioTransport); +begin + inherited Create(False); + FTransport := Transport; + FreeOnTerminate := True; +end; + +procedure TMCPStdioWorker.Execute; +begin + FTransport.WorkerLoop; +end; + +{ TMCPStdioRequestTracker } + +constructor TMCPStdioRequestTracker.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FEntries := TDictionary.Create; +end; + +destructor TMCPStdioRequestTracker.Destroy; +begin + FEntries.Free; + FLock.Free; + inherited; +end; + +class function TMCPStdioRequestTracker.KeyOf(const RequestId: TMCPRequestId): string; +begin + // 1 and "1" are different ids. + 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; + // The cancellation arrived before the handler started. + if CancelNow then + Context.Cancel; +end; + +procedure TMCPStdioRequestTracker.Untrack(const Context: IMCPRequestContext); +begin + Release(Context.RequestId); +end; + +function TMCPStdioRequestTracker.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +var + Entry: TEntry; +begin + var Context: IMCPRequestContext := nil; + FLock.Enter; + try + Result := FEntries.TryGetValue(KeyOf(RequestId), Entry); + if Result then + begin + Entry.Cancelled := True; + FEntries[KeyOf(RequestId)] := Entry; + Context := Entry.Context; + end; + finally + FLock.Leave; + end; + + if not Result then + Exit; + if Assigned(Context) then + Context.Cancel; + if Reason <> '' then + TLogger.Info(Format('Request %s cancelled by the client: %s', [RequestId.AsText, Reason])) + else + TLogger.Info('Request ' + RequestId.AsText + ' cancelled by the client'); +end; + +function TMCPStdioRequestTracker.CancelAll(const Reason: string): Integer; +begin + var Contexts := TList.Create; + try + FLock.Enter; + try + Result := FEntries.Count; + for var Key in FEntries.Keys.ToArray do + begin + var Entry := FEntries[Key]; + Entry.Cancelled := True; + FEntries[Key] := Entry; + if Assigned(Entry.Context) then + Contexts.Add(Entry.Context); + end; + finally + FLock.Leave; + end; + for var Context in Contexts do + Context.Cancel; + finally + Contexts.Free; + end; + if Result > 0 then + TLogger.Warning(Format('%d request(s) cancelled: %s', [Result, Reason])); +end; + { TMCPStdioTransport } constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); @@ -41,6 +266,9 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core FCoreManager := CoreManager; FJsonRpcProcessor := TMCPJsonRpcProcessor.Create(ManagerRegistry); FLegacySession := TMCPLegacySession.Create; + FTracker := TMCPStdioRequestTracker.Create; + FTrackerIntf := FTracker; + FShutdownDrainMs := DEFAULT_SHUTDOWN_DRAIN_MS; // stdout carries MCP messages only; every log line must go to stderr, // also for library consumers that never set UseStdErr themselves. @@ -52,6 +280,7 @@ destructor TMCPStdioTransport.Destroy; begin FJsonRpcProcessor.Free; FLegacySession.Free; + FTrackerIntf := nil; inherited; end; @@ -65,62 +294,219 @@ procedure TMCPStdioTransport.SetSettings(const Value: TMCPSettings); FJsonRpcProcessor.Settings := Value; end; -procedure TMCPStdioTransport.Run; -var - ErrorJson: TJSONObject; - ErrorObj: TJSONObject; - InputLine: string; - Response: string; +function TMCPStdioTransport.Hints: TMCPTransportHints; begin - TLogger.Info('STDIO transport started - reading from stdin, writing to stdout'); - TLogger.Info('Logging to stderr'); + Result := TMCPTransportHints.ForStdio(FLegacySession, FWriter, FTrackerIntf); +end; - InputLine := ''; - while not Eof(Input) do - begin - try - Readln(Input, InputLine); +function TMCPStdioTransport.WorkerCount: Integer; +begin + Result := Settings.MaxConcurrentRequests; + if Result < 1 then + Result := 1; +end; - if InputLine.Trim = '' then - Continue; +procedure TMCPStdioTransport.SendResponse(const Body: string); +begin + if Body = '' then + Exit; + FWriter.Send(Body); + TLogger.Debug('Sent: ' + TLogger.RedactJson(Body)); +end; - TLogger.Info('Received: ' + InputLine); +procedure TMCPStdioTransport.SendError(const RequestId: TMCPRequestId; Code: Integer; const Message: string); +begin + var Error := EMCPError.Create(Code, Message); + try + SendResponse(FJsonRpcProcessor.BuildErrorResponse(RequestId, Error)); + finally + Error.Free; + end; +end; - Response := FJsonRpcProcessor.ProcessRequestEx(InputLine, TMCPTransportHints.ForStdio(FLegacySession)).Body; +procedure TMCPStdioTransport.ProcessInline(const Message: TJSONValue); +begin + SendResponse(FJsonRpcProcessor.ProcessRequestEx(Message, Hints).Body); +end; + +procedure TMCPStdioTransport.DispatchLine(const Message: TJSONValue); +begin + // Malformed shapes, notifications, client responses and legacy ping are + // answered on the reader thread; every other request is queued. + var Queued := False; + try + if Message is TJSONObject then + begin + var Request := TJSONObject(Message); + var RequestId := TMCPRequestId.FromJson(Request.GetValue('id')); + var MethodValue := Request.GetValue('method'); + var Method := ''; + if MethodValue is TJSONString then + Method := TJSONString(MethodValue).Value; - if Response <> '' then + if RequestId.IsPresent and (Method <> '') and (Method <> 'ping') then begin - Writeln(Output, Response); - Flush(Output); - TLogger.Info('Sent: ' + Response); + if not FTracker.Reserve(RequestId) then + begin + SendError(RequestId, JSONRPC_INVALID_REQUEST, 'Request id ' + RequestId.AsText + ' is still in flight'); + Exit; + end; + if FQueue.PushItem(Message) <> TWaitResult.wrSignaled then + begin + FTracker.Release(RequestId); + SendError(RequestId, JSONRPC_INTERNAL_ERROR, 'Server is shutting down'); + Exit; + end; + Queued := True; + Exit; end; + end; - except - on E: Exception do - begin - TLogger.Error('Error processing STDIO request: ' + E.Message); - - // 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; - 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; + 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('id')); + try + var Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, Hints); + if Outcome.Cancelled then + TLogger.Info('No response for cancelled request ' + RequestId.AsText) + else + SendResponse(Outcome.Body); + finally + FTracker.Release(RequestId); + Message.Free; + end; +end; + +procedure TMCPStdioTransport.WorkerLoop; +var + Message: TJSONValue; +begin + try + while FQueue.PopItem(Message) = TWaitResult.wrSignaled do + begin + // A nil sentinel (one per worker, pushed by DrainAndStop) is the + // shutdown signal: everything queued ahead of it is real work and + // gets processed first, since the queue is FIFO. + 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 + FWorkersDone.Signal; + end; +end; + +procedure TMCPStdioTransport.StartWorkers; +begin + var Count := WorkerCount; + FQueue := TThreadedQueue.Create(QUEUE_DEPTH, INFINITE, INFINITE); + FWorkersDone := TCountdownEvent.Create(Count); + for var I := 1 to Count do + TMCPStdioWorker.Create(Self); + TLogger.Info(Format('STDIO transport started: %d worker thread(s), logging to stderr', [Count])); +end; + +procedure TMCPStdioTransport.DrainAndStop; +begin + // One sentinel per worker: whatever real work is already queued runs + // first (the queue is FIFO), then each worker pops its sentinel and + // stops. No new work is pushed after this point (the reader loop has + // already returned). + for var I := 1 to WorkerCount do + FQueue.PushItem(nil); + + if FWorkersDone.WaitFor(FShutdownDrainMs) <> TWaitResult.wrSignaled then + begin + FTracker.CancelAll('stdin closed'); + FWorkersDone.WaitFor(SHUTDOWN_CANCEL_GRACE_MS); + end; + + // A worker that is still stuck in a handler owns nothing we free here; it + // ends with the process. Once every worker took its sentinel the queue + // holds nothing else, so it is safe to free here. + if FWorkersDone.IsSet then + begin + FWorkersDone.Free; + FQueue.Free; + end + else + TLogger.Warning('A request handler did not stop; leaving it to the process exit'); + FWorkersDone := nil; + FQueue := nil; +end; + +procedure TMCPStdioTransport.ReadLoop(InputStream: TStream); +var + Line: string; + Status: TMCPLineStatus; +begin + var Reader := TMCPLineReader.Create(InputStream, Settings.MaxRequestBodyBytes); + try + while Reader.ReadLine(Line, Status) do + begin + try + case Status of + TMCPLineStatus.TooLong: + SendError(TMCPRequestId.FromJson(nil), JSONRPC_INVALID_REQUEST, + Format('Message exceeds %d bytes', [Settings.MaxRequestBodyBytes])); + TMCPLineStatus.InvalidUtf8: + SendError(TMCPRequestId.FromJson(nil), JSONRPC_PARSE_ERROR, 'Message is not valid UTF-8'); + else + if Line.Trim = '' then + Continue; + TLogger.Debug('Received: ' + TLogger.RedactJson(Line)); + DispatchLine(TJSONObject.ParseJSONValue(Line)); end; - Flush(Output); + except + // Never on stdout: a failure here has no request to answer. + on E: Exception do + TLogger.Error('Error reading stdio request: ' + E.Message); end; end; + finally + Reader.Free; end; +end; - TLogger.Info('STDIO transport stopped - EOF reached'); +procedure TMCPStdioTransport.RunWith(InputStream, OutputStream: TStream); +begin + FWriter := TMCPLineWriter.Create(OutputStream); + try + StartWorkers; + try + ReadLoop(InputStream); + TLogger.Info('STDIO transport: stdin closed'); + finally + DrainAndStop; + end; + finally + FWriter := nil; + end; + TLogger.Info('STDIO transport stopped'); +end; + +procedure TMCPStdioTransport.Run; +begin + var InputStream := StandardInputStream; + var OutputStream := StandardOutputStream; + try + RunWith(InputStream, OutputStream); + finally + OutputStream.Free; + InputStream.Free; + end; end; end. From 06b977b3dd6ece95fc655b2579b4ad576b609413 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 15:56:37 +0200 Subject: [PATCH 23/56] test: cover the rewritten stdio transport Line framing (LF splitting, CR stripping, BOM skipping, UTF-8 decoding, overlong and invalid-UTF-8 lines), the message writer, cancellation and progress on the request context, and the transport end to end over in-memory streams (handshake, UTF-8 round trip, duplicate ids, cancelled requests, progress ordering, modern requests, shutdown draining). --- tests/MCPServer.Tests.Cancellation.pas | 274 +++++++++++++++++++++++++ tests/MCPServer.Tests.Registration.pas | 2 +- tests/MCPServer.Tests.Stdio.pas | 268 ++++++++++++++++++++++++ tests/MCPServer.Tests.StdioChannel.pas | 207 +++++++++++++++++++ tests/MCPServerTests.dpr | 6 +- tests/MCPServerTests.dproj | 4 + 6 files changed, 759 insertions(+), 2 deletions(-) create mode 100644 tests/MCPServer.Tests.Cancellation.pas create mode 100644 tests/MCPServer.Tests.Stdio.pas create mode 100644 tests/MCPServer.Tests.StdioChannel.pas diff --git a/tests/MCPServer.Tests.Cancellation.pas b/tests/MCPServer.Tests.Cancellation.pas new file mode 100644 index 0000000..72a685b --- /dev/null +++ b/tests/MCPServer.Tests.Cancellation.pas @@ -0,0 +1,274 @@ +unit MCPServer.Tests.Cancellation; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.Tests.Harness; + +type + /// Collects what a context sends through the sink. + TRecordingSink = class(TInterfacedObject, IMCPMessageSink) + private + FMessages: TStrings; + public + constructor Create(Messages: TStrings); + procedure Send(const Json: string); + end; + + /// A tracker that cancels every request as soon as it is tracked and + /// records the cancellations it is asked for. + 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 Processor_CancelledRequest_HasNoResponse; + [Test] procedure Processor_CancelledNotification_ReachesTracker; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.JsonRpcProcessor; + +{ TRecordingSink } + +constructor TRecordingSink.Create(Messages: TStrings); +begin + inherited Create; + FMessages := Messages; +end; + +procedure TRecordingSink.Send(const Json: string); +begin + FMessages.Add(Json); +end; + +{ TCancellingTracker } + +constructor TCancellingTracker.Create(CancelOnTrack: Boolean; CancelledIds, Reasons: TStrings); +begin + inherited Create; + FCancelOnTrack := CancelOnTrack; + FCancelledIds := CancelledIds; + FReasons := Reasons; +end; + +procedure TCancellingTracker.Track(const Context: IMCPRequestContext); +begin + if FCancelOnTrack then + Context.Cancel; +end; + +procedure TCancellingTracker.Untrack(const Context: IMCPRequestContext); +begin +end; + +function TCancellingTracker.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +begin + FCancelledIds.Add(RequestId.AsText); + FReasons.Add(Reason); + Result := True; +end; + +{ TCancellationTests } + +procedure TCancellationTests.Setup; +begin + FMessages := TStringList.Create; + FSink := TRecordingSink.Create(FMessages); +end; + +procedure TCancellationTests.TearDown; +begin + FSink := nil; + FMessages.Free; +end; + +function TCancellationTests.NewContext(const MetaJson: string): IMCPRequestContext; +begin + var Meta: TJSONObject := nil; + if MetaJson <> '' then + Meta := TJSONObject.ParseJSONValue(MetaJson) as TJSONObject; + try + Result := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, 'tools/call', + TMCPRequestId.FromNumber(7), Meta, nil, nil, FSink); + finally + Meta.Free; + end; +end; + +procedure TCancellationTests.Cancel_SetsIsCancelled_And_CheckRaises; +begin + var Context := NewContext(''); + Assert.IsFalse(Context.IsCancelled); + Context.CheckCancelled; + Context.Cancel; + Assert.IsTrue(Context.IsCancelled); + var Check: TProc := procedure begin Context.CheckCancelled end; + Assert.WillRaise(Check, EMCPRequestCancelled); +end; + +procedure TCancellationTests.Progress_WithoutToken_SendsNothing; +begin + var Context := NewContext('{"io.modelcontextprotocol/protocolVersion":"2026-07-28"}'); + Assert.IsFalse(Context.HasProgressToken); + Context.ReportProgress(1, 2, 'half'); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Progress_NotificationShape; +begin + var Context := NewContext('{"progressToken":"abc"}'); + Assert.IsTrue(Context.HasProgressToken); + Context.ReportProgress(1, 4, 'quarter'); + Assert.AreEqual(1, FMessages.Count); + var Json := TJSONObject.ParseJSONValue(FMessages[0]) as TJSONObject; + try + Assert.AreEqual('2.0', Json.GetValue('jsonrpc')); + Assert.AreEqual('notifications/progress', Json.GetValue('method')); + Assert.AreEqual('abc', Json.GetValue('params.progressToken')); + Assert.AreEqual(1.0, Json.GetValue('params.progress'), 0.0001); + Assert.AreEqual(4.0, Json.GetValue('params.total'), 0.0001); + Assert.AreEqual('quarter', Json.GetValue('params.message')); + Assert.IsNull(Json.GetValue('id')); + finally + Json.Free; + end; +end; + +procedure TCancellationTests.Progress_IntegerToken_IsKept; +begin + var Context := NewContext('{"progressToken":42}'); + Context.ReportProgress(0.5); + var Json := TJSONObject.ParseJSONValue(FMessages[0]) as TJSONObject; + try + Assert.AreEqual(42, Json.GetValue('params.progressToken')); + Assert.AreEqual(0.5, Json.GetValue('params.progress'), 0.0001); + Assert.IsNull(Json.FindValue('params.total'), 'unknown total is omitted'); + finally + Json.Free; + end; +end; + +procedure TCancellationTests.Progress_Monotonic_And_Throttled; +begin + var Context := NewContext('{"progressToken":"t"}'); + Context.ReportProgress(1, 10); + Context.ReportProgress(0.5, 10); + Assert.AreEqual(1, FMessages.Count, 'a smaller value is dropped'); + Context.ReportProgress(2, 10); + Assert.AreEqual(1, FMessages.Count, 'a burst within the interval is dropped'); + Context.ReportProgress(10, 10); + Assert.AreEqual(2, FMessages.Count, 'reaching the total is always sent'); + Sleep(PROGRESS_MIN_INTERVAL_MS + 20); + Context.ReportProgress(11); + Assert.AreEqual(3, FMessages.Count, 'after the interval the next value goes out'); +end; + +procedure TCancellationTests.Progress_AfterCancel_SendsNothing; +begin + var Context := NewContext('{"progressToken":"t"}'); + Context.Cancel; + Context.ReportProgress(1, 2); + Assert.AreEqual(0, FMessages.Count); +end; + +procedure TCancellationTests.Progress_WithoutSink_IsNoOp; +begin + var Meta := TJSONObject.ParseJSONValue('{"progressToken":"t"}') as TJSONObject; + try + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Legacy, + MCP_LATEST_LEGACY_PROTOCOL_VERSION, 'tools/call', TMCPRequestId.FromNumber(1), Meta, nil, nil); + Context.ReportProgress(1, 2); + Assert.IsTrue(Context.HasProgressToken); + finally + Meta.Free; + end; +end; + +procedure TCancellationTests.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; + +initialization + TDUnitX.RegisterTestFixture(TCancellationTests); + +end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index ac46632..12fee0d 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -34,7 +34,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(10, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(11, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; diff --git a/tests/MCPServer.Tests.Stdio.pas b/tests/MCPServer.Tests.Stdio.pas new file mode 100644 index 0000000..97d11e8 --- /dev/null +++ b/tests/MCPServer.Tests.Stdio.pas @@ -0,0 +1,268 @@ +unit MCPServer.Tests.Stdio; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + MCPServer.Types, + MCPServer.StdioTransport, + MCPServer.Tests.Harness; + +type + /// Drives TMCPStdioTransport.RunWith over in-memory streams: the bytes a + /// client would write to stdin in, the bytes it would read from stdout out. + [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; + 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; + end; + +implementation + +uses + System.Diagnostics; + +const + INITIALIZE = '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-06-18","capabilities":{},"clientInfo":{"name":"t","version":"1"}}}'; + INITIALIZED = '{"jsonrpc":"2.0","method":"notifications/initialized"}'; + +{ TStdioTransportTests } + +procedure TStdioTransportTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TStdioTransportTests.TearDown; +begin + FHarness.Free; +end; + +function TStdioTransportTests.Run(const Lines: array of string; DrainMs: Integer; + const Separator: string): TArray; +begin + var Input := ''; + for var Line in Lines do + Input := Input + Line + Separator; + + var InputStream := TBytesStream.Create(TEncoding.UTF8.GetBytes(Input)); + var OutputStream := TBytesStream.Create; + var Transport := TMCPStdioTransport.Create(FHarness.ManagerRegistry, FHarness.CoreManager); + try + Transport.Settings := FHarness.Settings; + Transport.ShutdownDrainMs := DrainMs; + var Watch := TStopwatch.StartNew; + Transport.RunWith(InputStream, OutputStream); + FElapsedMs := Watch.ElapsedMilliseconds; + + FOutputBytes := Copy(OutputStream.Bytes, 0, OutputStream.Size); + Result := TEncoding.UTF8.GetString(FOutputBytes).Split([#10], TStringSplitOptions.ExcludeEmpty); + finally + Transport.Free; + OutputStream.Free; + InputStream.Free; + end; +end; + +function TStdioTransportTests.ParseLine(const Line: string): TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Line) as TJSONObject; + Assert.IsNotNull(Result, 'stdout line is JSON: ' + Line); +end; + +function TStdioTransportTests.FindById(const Lines: TArray; const Id: string): TJSONObject; +begin + for var Line in Lines do + begin + var Json := ParseLine(Line); + var IdValue := Json.GetValue('id'); + if Assigned(IdValue) and (IdValue.Value = Id) then + Exit(Json); + Json.Free; + end; + Result := nil; +end; + +procedure TStdioTransportTests.Handshake_And_ToolsList; +begin + var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"tools/list"}']); + Assert.AreEqual(2, Integer(Length(Lines))); + var Init := FindById(Lines, '1'); + var Tools := FindById(Lines, '2'); + try + Assert.AreEqual('2025-06-18', Init.GetValue('result.protocolVersion')); + Assert.AreEqual('echo', Tools.GetValue('result.tools[0].name')); + finally + Init.Free; + Tools.Free; + end; +end; + +procedure TStdioTransportTests.Utf8_RoundTrip_LfFraming_NoBom; +begin + var Probe := 'h' + Char($00E9) + 'llo w' + Char($00F6) + 'rld ' + Char($D83D) + Char($DE00); + var Lines := Run([INITIALIZE, INITIALIZED, + '{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"' + Probe + '"}}}']); + var Echo := FindById(Lines, '3'); + try + Assert.AreEqual('Echo: ' + Probe, Echo.GetValue('result.content[0].text')); + finally + Echo.Free; + end; + Assert.AreEqual($7B, Integer(FOutputBytes[0]), 'no byte-order mark'); + Assert.AreEqual(10, Integer(FOutputBytes[High(FOutputBytes)]), 'ends with LF'); + for var B in FOutputBytes do + Assert.AreNotEqual(13, Integer(B), 'no CR on stdout'); +end; + +procedure TStdioTransportTests.CrLf_Input_IsAccepted; +begin + var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"ping"}'], 2000, #13#10); + var Pong := FindById(Lines, '2'); + try + Assert.IsNotNull(Pong); + Assert.IsNotNull(Pong.GetValue('result')); + finally + Pong.Free; + end; +end; + +procedure TStdioTransportTests.InvalidJson_IsParseError_WithNullId; +begin + var Lines := Run(['this is not json', '{"jsonrpc":"2.0","id":2,"method":"ping"}']); + Assert.AreEqual(2, Integer(Length(Lines))); + var Error := ParseLine(Lines[0]); + try + Assert.IsTrue(Error.GetValue('id') is TJSONNull); + Assert.AreEqual(JSONRPC_PARSE_ERROR, Error.GetValue('error.code')); + finally + Error.Free; + end; +end; + +procedure TStdioTransportTests.Notification_ProducesNoOutput; +begin + var Lines := Run([INITIALIZED, '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":99}}']); + Assert.AreEqual(0, Integer(Length(Lines))); +end; + +procedure TStdioTransportTests.DuplicateId_WhileInFlight_IsInvalidRequest; +begin + var Slow := '{"jsonrpc":"2.0","id":7,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":4,"stepMs":100}}}'; + var Lines := Run([Slow, '{"jsonrpc":"2.0","id":7,"method":"ping"}']); + // ping is answered inline and is never a duplicate; the second queued + // request with the same id is. + Lines := Run([Slow, Slow]); + Assert.AreEqual(2, Integer(Length(Lines))); + var First := ParseLine(Lines[0]); + var Second := ParseLine(Lines[1]); + try + Assert.AreEqual(JSONRPC_INVALID_REQUEST, First.GetValue('error.code'), 'the duplicate is refused at once'); + Assert.IsNotNull(Second.GetValue('result'), 'the first request still completes'); + finally + First.Free; + Second.Free; + end; +end; + +procedure TStdioTransportTests.Cancelled_GetsNoResponse_PingIsStillAnswered; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":50,"stepMs":100}}}', + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":5,"reason":"test"}}', + '{"jsonrpc":"2.0","id":6,"method":"ping"}']); + Assert.AreEqual(1, Integer(Length(Lines)), 'only the ping is answered'); + var Pong := FindById(Lines, '6'); + try + Assert.IsNotNull(Pong); + finally + Pong.Free; + end; + Assert.IsTrue(FElapsedMs < 3000, 'the cancelled tool stopped early: ' + FElapsedMs.ToString + ' ms'); +end; + +procedure TStdioTransportTests.Progress_IsSentBeforeTheResponse; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":8,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":80},"_meta":{"progressToken":"p1"}}}']); + Assert.IsTrue(Length(Lines) >= 4, 'at least three progress notifications and the response'); + + var LastProgress := -1.0; + var ProgressCount := 0; + for var I := 0 to High(Lines) do + begin + var Json := ParseLine(Lines[I]); + try + if I = High(Lines) then + begin + Assert.AreEqual('8', Json.GetValue('id').Value, 'the response comes last'); + Assert.AreEqual('Completed 3 steps', Json.GetValue('result.content[0].text')); + end + else + begin + Assert.AreEqual('notifications/progress', Json.GetValue('method')); + Assert.AreEqual('p1', Json.GetValue('params.progressToken')); + var Progress := Json.GetValue('params.progress'); + Assert.IsTrue(Progress > LastProgress, 'progress increases'); + LastProgress := Progress; + Inc(ProgressCount); + end; + finally + Json.Free; + end; + end; + Assert.IsTrue(ProgressCount >= 3); + Assert.AreEqual(3.0, LastProgress, 0.0001, 'the final notification reaches the total'); +end; + +procedure TStdioTransportTests.ModernRequest_OverStdio; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":1,"method":"tools/list","params":{"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}']); + var Json := FindById(Lines, '1'); + try + Assert.AreEqual('complete', Json.GetValue('result.resultType')); + Assert.AreEqual(0, Json.GetValue('result.ttlMs')); + finally + Json.Free; + end; +end; + +procedure TStdioTransportTests.Eof_WithRunningRequest_ReturnsAfterDrain; +begin + var Lines := Run([ + '{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":100,"stepMs":100}}}'], + 300); + Assert.AreEqual(0, Integer(Length(Lines)), 'the request was cancelled at shutdown and got no response'); + Assert.IsTrue(FElapsedMs < 3000, 'Run returned after the drain timeout: ' + FElapsedMs.ToString + ' ms'); +end; + +initialization + TDUnitX.RegisterTestFixture(TStdioTransportTests); + +end. diff --git a/tests/MCPServer.Tests.StdioChannel.pas b/tests/MCPServer.Tests.StdioChannel.pas new file mode 100644 index 0000000..a19de03 --- /dev/null +++ b/tests/MCPServer.Tests.StdioChannel.pas @@ -0,0 +1,207 @@ +unit MCPServer.Tests.StdioChannel; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + MCPServer.Types, + MCPServer.StdioChannel; + +type + [TestFixture] + TStdioChannelTests = class + private + function ReadAll(const Bytes: TBytes; MaxLineBytes: Integer; out Statuses: TArray): TArray; + public + [Test] procedure Reader_SplitsOnLf_DropsCr_LastLineWithoutNewline; + [Test] procedure Reader_SkipsByteOrderMark; + [Test] procedure Reader_DecodesUtf8; + [Test] procedure Reader_ReportsOverlongLine_AndContinues; + [Test] procedure Reader_ReportsInvalidUtf8_AndContinues; + [Test] procedure Reader_EmptyStream_HasNoLines; + [Test] procedure Writer_OneLinePerMessage_Utf8_NoBom; + [Test] procedure Writer_ReplacesEmbeddedNewlines; + [Test] procedure Writer_ConcurrentSends_DoNotInterleave; + end; + +implementation + +uses + System.SyncObjs, + System.Generics.Collections; + +{ TStdioChannelTests } + +function TStdioChannelTests.ReadAll(const Bytes: TBytes; MaxLineBytes: Integer; + out Statuses: TArray): TArray; +var + Line: string; + Status: TMCPLineStatus; +begin + Result := nil; + Statuses := nil; + var Stream := TBytesStream.Create(Bytes); + var Reader := TMCPLineReader.Create(Stream, MaxLineBytes); + try + while Reader.ReadLine(Line, Status) do + begin + Result := Result + [Line]; + Statuses := Statuses + [Status]; + end; + finally + Reader.Free; + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Reader_SplitsOnLf_DropsCr_LastLineWithoutNewline; +var + Statuses: TArray; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes('one'#13#10'two'#10#10'three'), 1024, Statuses); + Assert.AreEqual(4, Integer(Length(Lines))); + Assert.AreEqual('one', Lines[0]); + Assert.AreEqual('two', Lines[1]); + Assert.AreEqual('', Lines[2]); + Assert.AreEqual('three', Lines[3]); + for var Status in Statuses do + Assert.IsTrue(Status = TMCPLineStatus.Ok); +end; + +procedure TStdioChannelTests.Reader_SkipsByteOrderMark; +var + Statuses: TArray; +begin + var Bytes := TBytes.Create($EF, $BB, $BF) + TEncoding.UTF8.GetBytes('{"a":1}'#10); + var Lines := ReadAll(Bytes, 1024, Statuses); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.AreEqual('{"a":1}', Lines[0]); +end; + +procedure TStdioChannelTests.Reader_DecodesUtf8; +var + Statuses: TArray; +begin + var Probe := 'h' + Char($00E9) + 'llo w' + Char($00F6) + 'rld ' + Char($D83D) + Char($DE00); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Probe + #10), 1024, Statuses); + Assert.AreEqual(Probe, Lines[0]); +end; + +procedure TStdioChannelTests.Reader_ReportsOverlongLine_AndContinues; +var + Statuses: TArray; +begin + var Long := StringOfChar('x', 100); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'short'#10), 50, Statuses); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0]); + Assert.IsTrue(Statuses[1] = TMCPLineStatus.Ok); + Assert.AreEqual('short', Lines[1]); +end; + +procedure TStdioChannelTests.Reader_ReportsInvalidUtf8_AndContinues; +var + Statuses: TArray; +begin + var Bytes := TBytes.Create($FF, $FE, $41) + TEncoding.UTF8.GetBytes(#10'ok'#10); + var Lines := ReadAll(Bytes, 1024, Statuses); + Assert.AreEqual(2, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.InvalidUtf8, 'first line is not UTF-8'); + Assert.AreEqual('ok', Lines[1]); +end; + +procedure TStdioChannelTests.Reader_EmptyStream_HasNoLines; +var + Statuses: TArray; +begin + var Lines := ReadAll(nil, 1024, Statuses); + Assert.AreEqual(0, Integer(Length(Lines))); +end; + +procedure TStdioChannelTests.Writer_OneLinePerMessage_Utf8_NoBom; +begin + var Stream := TMemoryStream.Create; + try + var SinkIntf: IMCPMessageSink := TMCPLineWriter.Create(Stream); + SinkIntf.Send('{"a":"' + Char($00E9) + '"}'); + SinkIntf.Send('{"b":2}'); + + var Bytes: TBytes; + SetLength(Bytes, Stream.Size); + Move(Stream.Memory^, Bytes[0], Stream.Size); + 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], Stream.Size); + Assert.AreEqual('a b'#10, TEncoding.UTF8.GetString(Bytes)); + finally + Stream.Free; + end; +end; + +procedure TStdioChannelTests.Writer_ConcurrentSends_DoNotInterleave; +const + THREADS = 4; + MESSAGES_PER_THREAD = 200; +begin + var Stream := TMemoryStream.Create; + var Done := TCountdownEvent.Create(THREADS); + try + var SinkIntf: IMCPMessageSink := TMCPLineWriter.Create(Stream); + for var T := 1 to THREADS do + begin + var ThreadNo := T; + TThread.CreateAnonymousThread( + procedure + begin + try + for var I := 1 to MESSAGES_PER_THREAD do + SinkIntf.Send('{"thread":' + ThreadNo.ToString + ',"payload":"' + StringOfChar('x', 300) + '"}'); + finally + Done.Signal; + end; + end).Start; + end; + Assert.IsTrue(Done.WaitFor(10000) = TWaitResult.wrSignaled); + + var Bytes: TBytes; + SetLength(Bytes, Stream.Size); + Move(Stream.Memory^, Bytes[0], Stream.Size); + 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; + +initialization + TDUnitX.RegisterTestFixture(TStdioChannelTests); + +end. diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index 7012490..02385fa 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -27,6 +27,7 @@ uses MCPServer.ToolsManager in '..\src\Managers\MCPServer.ToolsManager.pas', MCPServer.ResourcesManager in '..\src\Managers\MCPServer.ResourcesManager.pas', MCPServer.StdioTransport in '..\src\Server\MCPServer.StdioTransport.pas', + MCPServer.StdioChannel in '..\src\Server\MCPServer.StdioChannel.pas', // The built-in tools and resources register themselves in their // initialization sections. Keep the order identical to MCPServer.dpr so the // registry (and therefore tools/list and resources/list) matches the server. @@ -57,7 +58,10 @@ uses MCPServer.Tests.Serializer in 'MCPServer.Tests.Serializer.pas', MCPServer.Tests.Schema in 'MCPServer.Tests.Schema.pas', MCPServer.Tests.ToolsManager in 'MCPServer.Tests.ToolsManager.pas', - MCPServer.Tests.ResourcesManager in 'MCPServer.Tests.ResourcesManager.pas'; + MCPServer.Tests.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'; procedure RunTests; begin diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 15e414a..9d8092f 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -91,6 +91,10 @@ + + + + From b6d69e03b20c3a54977b5119b9a46e9492601e59 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 15:56:37 +0200 Subject: [PATCH 24/56] feat: add a progress-reporting sample tool test_tool_with_progress reports notifications/progress for each step and stops when the client cancels; the tools and resources managers now also let a cancelled request propagate instead of turning it into a protocol error. --- src/Managers/MCPServer.ResourcesManager.pas | 2 + src/Managers/MCPServer.ToolsManager.pas | 2 + src/Tools/MCPServer.Tool.ContentSamples.pas | 66 +++++++++++++++++++++ 3 files changed, 70 insertions(+) diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 17b58f7..ae2b0b0 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -267,6 +267,8 @@ function TMCPResourcesManager.ReadResource(const Params: TJSONObject; Era: TMCPP except on E: EMCPError do raise; + on E: EMCPRequestCancelled do + raise; on E: Exception do raise EMCPError.InternalError('Error reading resource: ' + E.Message); end; diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 746ac3c..71c0038 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -244,6 +244,8 @@ function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJS Exit(ErrorResult('Invalid arguments: ' + E.Message, Era)); on E: EMCPError do raise; + on E: EMCPRequestCancelled do + raise; on E: Exception do Exit(ErrorResult('Error executing tool: ' + E.Message, Era)); end; diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas index a32cebb..4f25bde 100644 --- a/src/Tools/MCPServer.Tool.ContentSamples.pas +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -55,6 +55,33 @@ TMultipleContentTypesTool = class(TMCPToolBase) end; /// Always fails with a tool execution error (isError: true). + 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; + + /// Reports progress for every step and stops when the client cancels. + 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; @@ -166,6 +193,40 @@ function TErrorHandlingTool.ExecuteWithParams(const Params: TNoParams): string; raise EMCPToolError.Create('This tool always fails, as an example of a tool execution error'); end; +{ TProgressTool } + +constructor TProgressTool.Create; +begin + inherited; + FName := 'test_tool_with_progress'; + FDescription := 'Runs a few steps and reports progress for each; honours cancellation'; +end; + +function TProgressTool.ExecuteWithContext(const Params: TProgressToolParams; + const Context: IMCPRequestContext): TValue; +begin + var Steps := Params.Steps; + if (Steps <= 0) or (Steps > MAX_STEPS) then + Steps := DEFAULT_STEPS; + var StepMs := Params.StepMs; + if (StepMs <= 0) or (StepMs > MAX_STEP_MS) then + StepMs := DEFAULT_STEP_MS; + + for var Step := 1 to Steps do + begin + if Assigned(Context) then + begin + Context.CheckCancelled; + Context.ReportProgress(Step - 1, Steps, Format('Step %d of %d', [Step, Steps])); + end; + Sleep(StepMs); + end; + if Assigned(Context) then + Context.ReportProgress(Steps, Steps, 'Done'); + + Result := Format('Completed %d steps', [Steps]); +end; + initialization TMCPRegistry.RegisterTool('test_simple_text', function: IMCPTool @@ -192,6 +253,11 @@ initialization begin Result := TMultipleContentTypesTool.Create; end); + TMCPRegistry.RegisterTool('test_tool_with_progress', + function: IMCPTool + begin + Result := TProgressTool.Create; + end); TMCPRegistry.RegisterTool('test_error_handling', function: IMCPTool begin From a50ac05a56443b041083e2da54e79d22fad28d54 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 15:56:37 +0200 Subject: [PATCH 25/56] test: extend the stdio smoke test and re-record affected goldens The smoke test now drives a progress token, a cancellation and a ping through the real executable and checks framing, ordering, and that the process exits promptly. Goldens re-recorded for the new sample tool. --- scripts/run-stdio-smoke.ps1 | 87 ++++++++++++++++++----- tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/legacy/tools-list.json | 17 +++++ tests/golden/modern/tools-list.json | 17 +++++ 6 files changed, 111 insertions(+), 22 deletions(-) diff --git a/scripts/run-stdio-smoke.ps1 b/scripts/run-stdio-smoke.ps1 index 13afd19..6f2c03d 100644 --- a/scripts/run-stdio-smoke.ps1 +++ b/scripts/run-stdio-smoke.ps1 @@ -4,15 +4,16 @@ .DESCRIPTION Feeds a fixed set of JSON-RPC lines (initialize, initialized, tools/list, - tools/call echo with non-ASCII text) to "MCPServer.exe --stdio" through - cmd.exe redirection, exactly as a client spawning the process would, and - checks: + tools/call echo with non-ASCII text, a tools/call with a progressToken, a + slow tools/call followed by notifications/cancelled, and ping) to + "MCPServer.exe --stdio" through cmd.exe redirection, exactly as a client + spawning the process would, and checks: - stdout holds one JSON object per line and nothing else, - - every request id gets exactly one response, + - every request id gets exactly one response, except the cancelled one, + - the non-ASCII text comes back unchanged, + - the progress notifications precede their response and increase, + - the server exits promptly once stdin is closed, - all log lines went to stderr. - It also reports whether the non-ASCII text survived the round trip; this - is an observation for the stdio work (Text I/O decodes stdin with the - ANSI code page on Windows) and does not fail the run. .PARAMETER ServerExe Path to the executable. Default: Win64\Release\MCPServer.exe. @@ -45,6 +46,10 @@ $lines = @( '{"jsonrpc":"2.0","method":"notifications/initialized"}' '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' ('{"jsonrpc":"2.0","id":3,"method":"tools/call","params":{"name":"echo","arguments":{"message":"' + $probe + '"}}}') + '{"jsonrpc":"2.0","id":4,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":80},"_meta":{"progressToken":"smoke-progress"}}}' + '{"jsonrpc":"2.0","id":5,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":50,"stepMs":100}}}' + '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":5,"reason":"smoke test"}}' + '{"jsonrpc":"2.0","id":6,"method":"ping"}' ) $utf8 = New-Object System.Text.UTF8Encoding($false) [System.IO.File]::WriteAllBytes($inputFile, $utf8.GetBytes(($lines -join "`n") + "`n")) @@ -53,20 +58,34 @@ $utf8 = New-Object System.Text.UTF8Encoding($false) $batchFile = Join-Path $resultsDir 'run.cmd' $command = "@`"$ServerExe`" --stdio < `"$inputFile`" > `"$stdoutFile`" 2> `"$stderrFile`"" Set-Content -Path $batchFile -Value $command -Encoding ASCII +$stopwatch = [System.Diagnostics.Stopwatch]::StartNew() $process = Start-Process -FilePath 'cmd.exe' -ArgumentList @('/c', "`"$batchFile`"") -WorkingDirectory (Split-Path -Parent $ServerExe) ` -PassThru -NoNewWindow -Wait +$stopwatch.Stop() if ($process.ExitCode -ne 0) { Write-Host "Server exited with code $($process.ExitCode)" } +Write-Host "server run time: $($stopwatch.ElapsedMilliseconds) ms" $stdout = $utf8.GetString([System.IO.File]::ReadAllBytes($stdoutFile)) $stderr = $utf8.GetString([System.IO.File]::ReadAllBytes($stderrFile)) $failures = 0 -$stdoutLines = @($stdout -split "`r?`n" | Where-Object { $_ -ne '' }) +$stdoutLines = @($stdout -split "`n" | Where-Object { $_ -ne '' }) +if ($stdout.Contains("`r")) { + Write-Host 'carriage return found on stdout; the framing is a bare LF' + $failures++ +} +if ($stdout.Length -gt 0 -and [int][char]$stdout[0] -eq 0xFEFF) { + Write-Host 'byte-order mark found on stdout' + $failures++ +} Write-Host "stdout lines: $($stdoutLines.Count)" $responses = @{} +$progress = @() +$lineIndex = 0 +$responseIndexes = @{} foreach ($line in $stdoutLines) { try { $message = $line | ConvertFrom-Json @@ -80,17 +99,54 @@ foreach ($line in $stdoutLines) { $failures++ continue } - if ($null -ne $message.id) { $responses[[string]$message.id] = $message } + if ($null -ne $message.id) { + $responses[[string]$message.id] = $message + $responseIndexes[[string]$message.id] = $lineIndex + } elseif ($message.method -eq 'notifications/progress') { + $progress += [pscustomobject]@{ Index = $lineIndex; Params = $message.params } + } else { + Write-Host "unexpected message on stdout: $line" + $failures++ + } + $lineIndex++ } -foreach ($id in '1', '2', '3') { +foreach ($id in '1', '2', '3', '4', '6') { if (-not $responses.ContainsKey($id)) { Write-Host "missing response for id $id" $failures++ } } -if ($stdoutLines.Count -ne 3) { - Write-Host "expected exactly 3 responses on stdout, got $($stdoutLines.Count)" +if ($responses.ContainsKey('5')) { + Write-Host 'the cancelled request (id 5) got a response' + $failures++ +} + +$smokeProgress = @($progress | Where-Object { $_.Params.progressToken -eq 'smoke-progress' }) +if ($smokeProgress.Count -lt 3) { + Write-Host "expected at least 3 progress notifications for id 4, got $($smokeProgress.Count)" + $failures++ +} else { + $previous = -1 + foreach ($item in $smokeProgress) { + if ($item.Params.progress -le $previous) { + Write-Host "progress did not increase: $($item.Params.progress) after $previous" + $failures++ + } + $previous = $item.Params.progress + if ($responseIndexes.ContainsKey('4') -and $item.Index -gt $responseIndexes['4']) { + Write-Host 'a progress notification arrived after its response' + $failures++ + } + } +} +if (@($progress | Where-Object { $_.Params.progressToken -ne 'smoke-progress' }).Count -gt 0) { + Write-Host 'progress notification with an unknown token' + $failures++ +} + +if ($stopwatch.ElapsedMilliseconds -gt 4000) { + Write-Host "the server took $($stopwatch.ElapsedMilliseconds) ms to exit; the cancelled tool should not hold it" $failures++ } @@ -105,10 +161,9 @@ if ($stderr.Trim().Length -eq 0) { if ($responses.ContainsKey('3')) { $echoText = $responses['3'].result.content[0].text - if ($echoText -eq "Echo: $probe") { - Write-Host "observation: non-ASCII input survived the stdio round trip" - } else { - Write-Host "observation: non-ASCII input was altered on the stdio round trip: $echoText" + if ($echoText -ne "Echo: $probe") { + Write-Host "non-ASCII input was altered on the stdio round trip: $echoText" + $failures++ } } diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index a57b3de..2a77504 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 2261 +Content-Length: 2598 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 26e132a..158979a 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 2132 +Content-Length: 2469 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index 88cd3b5..067c79f 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 2109 +Content-Length: 2446 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json index 54a9dcc..d84afe0 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -140,6 +140,23 @@ "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", diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json index ef6ef5d..7409f3f 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -151,6 +151,23 @@ "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", From a50ccb5dc188eabe134e21c98d168229372fe6d0 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 15:56:37 +0200 Subject: [PATCH 26/56] docs: describe the stdio transport rewrite --- CHANGELOG.md | 25 +++++++++++++++++++++++++ MIGRATION.md | 28 ++++++++++++++++++++++++++++ README.md | 29 +++++++++++++++++++++++------ 3 files changed, 76 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ffc0ba2..3142d0b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,25 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### Added +- 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` @@ -110,6 +129,12 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### Changed +- 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. diff --git a/MIGRATION.md b/MIGRATION.md index 7efa376..a310c38 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -87,6 +87,34 @@ depended on the previous dictionary order should use the names instead. 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. + ## Library use - `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are diff --git a/README.md b/README.md index 28aa1b9..9104e08 100644 --- a/README.md +++ b/README.md @@ -119,9 +119,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) @@ -130,6 +133,19 @@ 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, and `ReportProgress` sends a +`notifications/progress` when the request carries a progress token. See +`test_tool_with_progress` in `MCPServer.Tool.ContentSamples` for a worked +example. + ## 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. @@ -513,9 +529,10 @@ The Inspector provides a web interface to interact with your MCP server, making - **calculate**: Perform basic arithmetic calculations - **test_simple_text**, **test_image_content**, **test_audio_content**, **test_embedded_resource**, **test_multiple_content_types**, - **test_error_handling**: one small tool per content type and one that - fails, from `MCPServer.Tool.ContentSamples`; the conformance suite calls - these by name + **test_error_handling**, **test_tool_with_progress**: one small tool per + content type, one that fails, and one that reports progress and honours + cancellation, from `MCPServer.Tool.ContentSamples`; the conformance suite + calls these by name ## Available Example resources From d0052836c436feb2a065f9ab34563ca6821c1ff5 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 16:59:59 +0200 Subject: [PATCH 27/56] refactor: share content block builders between tools and prompts MCPServer.ContentBlocks holds the text/image/audio/resource-link/embedded- resource block builders and EncodeBase64Blob, used by TMCPToolResult and, in the next commit, TMCPPromptMessages, so both produce byte-identical content blocks instead of two copies of the same formatting code. --- src/Managers/MCPServer.ResourcesManager.pas | 82 ++++++++++++++++- src/Protocol/MCPServer.ContentBlocks.pas | 97 +++++++++++++++++++++ src/Tools/MCPServer.Tool.Result.pas | 58 ++---------- 3 files changed, 184 insertions(+), 53 deletions(-) create mode 100644 src/Protocol/MCPServer.ContentBlocks.pas diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index ae2b0b0..7960033 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -23,14 +23,19 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap private FResources: TDictionary; FOrder: TList; + FTemplates: TList; FListTtlMs: Integer; FListCacheScope: string; 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; + /// Exact match first, then the first matching template; nil when neither. + function FindResource(const URI: string): IMCPResource; function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; public constructor Create; @@ -38,6 +43,11 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap /// Adds a resource to this manager only (next to the ones from TMCPRegistry). procedure AddResource(const Resource: IMCPResource); + /// Adds a resource template to this manager only. + procedure AddResourceTemplate(const Template: IMCPResourceTemplate); + /// Exact registration lookups, for completion/complete. + 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; @@ -64,7 +74,7 @@ implementation MCPServer.Registration, MCPServer.RequestContext, MCPServer.Errors, - MCPServer.Tool.Result; + MCPServer.ContentBlocks; { TMCPResourcesManager } @@ -73,15 +83,18 @@ constructor TMCPResourcesManager.Create; inherited; FResources := TDictionary.Create; FOrder := TList.Create; + FTemplates := TList.Create; FListTtlMs := 0; FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; RegisterBuiltInResources; + RegisterBuiltInResourceTemplates; end; destructor TMCPResourcesManager.Destroy; begin FResources.Free; FOrder.Free; + FTemplates.Free; inherited; end; @@ -144,11 +157,56 @@ procedure TMCPResourcesManager.RegisterBuiltInResources; RegisterResource(TMCPRegistry.CreateResource(ResourceURI)); end; +procedure TMCPResourcesManager.RegisterBuiltInResourceTemplates; +begin + for var UriTemplate in TMCPRegistry.GetResourceTemplateURIs do + FTemplates.Add(TMCPRegistry.CreateResourceTemplate(UriTemplate)); +end; + procedure TMCPResourcesManager.AddResource(const Resource: IMCPResource); begin RegisterResource(Resource); end; +procedure TMCPResourcesManager.AddResourceTemplate(const Template: IMCPResourceTemplate); +begin + FTemplates.Add(Template); +end; + +function TMCPResourcesManager.TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; +begin + Result := FResources.TryGetValue(URI, Resource); +end; + +function TMCPResourcesManager.TryGetResourceTemplate(const UriTemplate: string; + out Template: IMCPResourceTemplate): Boolean; +begin + for var Candidate in FTemplates do + if Candidate.UriTemplate = UriTemplate then + begin + Template := Candidate; + Exit(True); + end; + Template := nil; + Result := False; +end; + +function TMCPResourcesManager.FindResource(const URI: string): IMCPResource; +begin + if FResources.TryGetValue(URI, Result) then + Exit; + + var Vars := TMCPTemplateVars.Create; + try + for var Template in FTemplates do + if Template.Matches(URI, Vars) then + Exit(Template.CreateResource(URI, Vars)); + finally + Vars.Free; + end; + Result := nil; +end; + procedure TMCPResourcesManager.CheckCursor(const Params: TJSONObject); begin // Every list fits in one page; a cursor is never one this server issued. @@ -191,6 +249,19 @@ function TMCPResourcesManager.CreateResourceJSON(const Resource: IMCPResource): end; end; +function TMCPResourcesManager.CreateResourceTemplateJSON(const Template: IMCPResourceTemplate): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('uriTemplate', Template.UriTemplate); + Result.AddPair('name', Template.Name); + if Template.Title <> '' then + Result.AddPair('title', Template.Title); + if Template.Description <> '' then + Result.AddPair('description', Template.Description); + if Template.MimeType <> '' then + Result.AddPair('mimeType', Template.MimeType); +end; + function TMCPResourcesManager.CreateContentsItem(const Resource: IMCPResource): TJSONObject; var Binary: IMCPBinaryResource; @@ -255,7 +326,8 @@ function TMCPResourcesManager.ReadResource(const Params: TJSONObject; Era: TMCPP TLogger.Info('MCP ReadResource called for URI: ' + URI); - if not FResources.TryGetValue(URI, Resource) then + Resource := FindResource(URI); + if not Assigned(Resource) then raise EMCPError.ResourceNotFound(URI, Era); var ResultJSON := TJSONObject.Create; @@ -305,8 +377,10 @@ function TMCPResourcesManager.ListResourceTemplates(const Params: TJSONObject; E var ResultJSON := TJSONObject.Create; try - // This server has no resource templates. - ResultJSON.AddPair('resourceTemplates', TJSONArray.Create); + var TemplatesArray := TJSONArray.Create; + ResultJSON.AddPair('resourceTemplates', TemplatesArray); + for var Template in FTemplates do + TemplatesArray.AddElement(CreateResourceTemplateJSON(Template)); AddListCacheHints(ResultJSON, Era); Result := TValue.From(ResultJSON); except diff --git a/src/Protocol/MCPServer.ContentBlocks.pas b/src/Protocol/MCPServer.ContentBlocks.pas new file mode 100644 index 0000000..c3fca43 --- /dev/null +++ b/src/Protocol/MCPServer.ContentBlocks.pas @@ -0,0 +1,97 @@ +unit MCPServer.ContentBlocks; + +/// Content block builders shared by tools/call results (an array of blocks) +/// and prompts/get messages (one block per message): the wire shape for +/// text, image, audio, resource link and embedded resource content is the +/// same in both places. + +interface + +uses + System.SysUtils, + System.JSON; + +function CreateTextBlock(const Text: string): TJSONObject; +function CreateImageBlock(const Base64Data, MimeType: string): TJSONObject; +function CreateAudioBlock(const Base64Data, MimeType: string): TJSONObject; +function CreateResourceLinkBlock(const Uri, Name: string; const Description: string = ''; + const MimeType: string = ''): TJSONObject; +function CreateEmbeddedTextBlock(const Uri, MimeType, Text: string): TJSONObject; +function CreateEmbeddedBlobBlock(const Uri, MimeType, Base64Blob: string): TJSONObject; + +/// Base64 without line breaks, as the schema requires for blobs. +function EncodeBase64Blob(const Data: TBytes): string; + +implementation + +uses + System.NetEncoding; + +function EncodeBase64Blob(const Data: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Data); + finally + Encoding.Free; + end; +end; + +function CreateTextBlock(const Text: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'text'); + Result.AddPair('text', Text); +end; + +function CreateImageBlock(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'image'); + Result.AddPair('data', Base64Data); + Result.AddPair('mimeType', MimeType); +end; + +function CreateAudioBlock(const Base64Data, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'audio'); + Result.AddPair('data', Base64Data); + Result.AddPair('mimeType', MimeType); +end; + +function CreateResourceLinkBlock(const Uri, Name, Description, MimeType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'resource_link'); + Result.AddPair('uri', Uri); + Result.AddPair('name', Name); + if Description <> '' then + Result.AddPair('description', Description); + if MimeType <> '' then + Result.AddPair('mimeType', MimeType); +end; + +function CreateEmbeddedTextBlock(const Uri, MimeType, Text: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('text', Text); + Result := TJSONObject.Create; + Result.AddPair('type', 'resource'); + Result.AddPair('resource', Resource); +end; + +function CreateEmbeddedBlobBlock(const Uri, MimeType, Base64Blob: string): TJSONObject; +begin + var Resource := TJSONObject.Create; + Resource.AddPair('uri', Uri); + Resource.AddPair('mimeType', MimeType); + Resource.AddPair('blob', Base64Blob); + Result := TJSONObject.Create; + Result.AddPair('type', 'resource'); + Result.AddPair('resource', Resource); +end; + +end. diff --git a/src/Tools/MCPServer.Tool.Result.pas b/src/Tools/MCPServer.Tool.Result.pas index 76ff2ab..01df478 100644 --- a/src/Tools/MCPServer.Tool.Result.pas +++ b/src/Tools/MCPServer.Tool.Result.pas @@ -6,7 +6,9 @@ interface System.SysUtils, System.Classes, System.JSON, - MCPServer.Types; + System.Generics.Collections, + MCPServer.Types, + MCPServer.ContentBlocks; type /// Builds a tools/call result: content blocks of every kind, optional @@ -19,7 +21,6 @@ TMCPToolResult = class FStructuredContent: TJSONValue; FMeta: TJSONObject; FIsError: Boolean; - function AddBlock(const BlockType: string): TJSONObject; function BuildContent(Era: TMCPProtocolEra): TJSONArray; public constructor Create; @@ -56,24 +57,8 @@ TMCPToolResult = class property StructuredContent: TJSONValue read FStructuredContent; end; - /// Base64 without line breaks, as the schema requires for blobs. - function EncodeBase64Blob(const Data: TBytes): string; - implementation -uses - System.NetEncoding; - -function EncodeBase64Blob(const Data: TBytes): string; -begin - var Encoding := TBase64Encoding.Create(0); - try - Result := Encoding.EncodeBytesToString(Data); - finally - Encoding.Free; - end; -end; - { TMCPToolResult } constructor TMCPToolResult.Create; @@ -90,16 +75,9 @@ destructor TMCPToolResult.Destroy; inherited; end; -function TMCPToolResult.AddBlock(const BlockType: string): TJSONObject; -begin - Result := TJSONObject.Create; - Result.AddPair('type', BlockType); - FContent.AddElement(Result); -end; - function TMCPToolResult.AddText(const Text: string): TMCPToolResult; begin - AddBlock('text').AddPair('text', Text); + FContent.AddElement(CreateTextBlock(Text)); Result := Self; end; @@ -110,9 +88,7 @@ function TMCPToolResult.AddImage(const Data: TBytes; const MimeType: string): TM function TMCPToolResult.AddImage(const Base64Data, MimeType: string): TMCPToolResult; begin - var Block := AddBlock('image'); - Block.AddPair('data', Base64Data); - Block.AddPair('mimeType', MimeType); + FContent.AddElement(CreateImageBlock(Base64Data, MimeType)); Result := Self; end; @@ -123,41 +99,25 @@ function TMCPToolResult.AddAudio(const Data: TBytes; const MimeType: string): TM function TMCPToolResult.AddAudio(const Base64Data, MimeType: string): TMCPToolResult; begin - var Block := AddBlock('audio'); - Block.AddPair('data', Base64Data); - Block.AddPair('mimeType', MimeType); + FContent.AddElement(CreateAudioBlock(Base64Data, MimeType)); Result := Self; end; function TMCPToolResult.AddResourceLink(const Uri, Name, Description, MimeType: string): TMCPToolResult; begin - var Block := AddBlock('resource_link'); - Block.AddPair('uri', Uri); - Block.AddPair('name', Name); - if Description <> '' then - Block.AddPair('description', Description); - if MimeType <> '' then - Block.AddPair('mimeType', MimeType); + FContent.AddElement(CreateResourceLinkBlock(Uri, Name, Description, MimeType)); Result := Self; end; function TMCPToolResult.AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; begin - var Resource := TJSONObject.Create; - Resource.AddPair('uri', Uri); - Resource.AddPair('mimeType', MimeType); - Resource.AddPair('text', Text); - AddBlock('resource').AddPair('resource', Resource); + FContent.AddElement(CreateEmbeddedTextBlock(Uri, MimeType, Text)); Result := Self; end; function TMCPToolResult.AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; begin - var Resource := TJSONObject.Create; - Resource.AddPair('uri', Uri); - Resource.AddPair('mimeType', MimeType); - Resource.AddPair('blob', EncodeBase64Blob(Data)); - AddBlock('resource').AddPair('resource', Resource); + FContent.AddElement(CreateEmbeddedBlobBlock(Uri, MimeType, EncodeBase64Blob(Data))); Result := Self; end; From 46bb696e59ce969f491942149e6020b95ce18616 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 16:59:59 +0200 Subject: [PATCH 28/56] feat: add prompts and resource templates to the type system IMCPPromptMetadata, IMCPCompletable and TMCPCompletion in MCPServer.Types; EMCPError.UnknownPrompt. MCPServer.Prompt.Base: TMCPPromptArgument, TMCPPromptMessages (one role plus one content block per message, unlike tools/call's content array), IMCPPrompt, TMCPPromptBase and the generic TMCPPromptBase with RTTI-derived arguments. MCPServer.Resource.Base: TMCPTemplateVars, IMCPResourceTemplate and TMCPResourceTemplateBase (RFC 6570 level 1 and a level 2 subset, '{var}' and '{+var}'). --- src/Prompts/MCPServer.Prompt.Base.pas | 336 ++++++++++++++++++ .../MCPServer.Prompt.ContentSamples.pas | 155 ++++++++ .../MCPServer.Prompt.SummarizeLogs.pas | 118 ++++++ src/Protocol/MCPServer.Errors.pas | 8 + src/Protocol/MCPServer.Types.pas | 168 ++++++++- src/Resources/MCPServer.Resource.Base.pas | 163 +++++++++ 6 files changed, 947 insertions(+), 1 deletion(-) create mode 100644 src/Prompts/MCPServer.Prompt.Base.pas create mode 100644 src/Prompts/MCPServer.Prompt.ContentSamples.pas create mode 100644 src/Prompts/MCPServer.Prompt.SummarizeLogs.pas diff --git a/src/Prompts/MCPServer.Prompt.Base.pas b/src/Prompts/MCPServer.Prompt.Base.pas new file mode 100644 index 0000000..096957a --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.Base.pas @@ -0,0 +1,336 @@ +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; + + /// Builds the messages of a prompts/get result: one role plus one content + /// block per message, the same block shapes tools/call uses (text, image, + /// audio, resource_link, embedded resource). + TMCPPromptMessages = class + strict private + FMessages: TJSONArray; + function AddMessage(const Role: string; const Content: TJSONObject): TMCPPromptMessages; + public + constructor Create; + destructor Destroy; override; + + function AddText(const Role, Text: string): TMCPPromptMessages; + /// Data is the raw content; it is Base64-encoded here. + 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; + /// Reads Resource (text, or blob for an IMCPBinaryResource) and embeds + /// it under Role. + function AddEmbeddedResource(const Role: string; const Resource: IMCPResource): TMCPPromptMessages; + /// Annotations for the message added last (audience, priority, lastModified). + function WithAnnotations(const Annotations: TJSONObject): TMCPPromptMessages; + + /// The messages array for the result; the caller owns the clone. + function ToJson: TJSONArray; + end; + + IMCPPrompt = interface + ['{6B8DFAF4-D0E3-4A56-8637-8DFAF4D0E3A5}'] + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetArguments: TArray; + /// Arguments is never nil (an empty object when the request omitted + /// it). Builds the messages into Messages; returns the optional + /// result-level description. + 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; + + /// Prompt with a hand-written argument list and raw JSON arguments. + 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; + + /// Prompt whose arguments are the string properties of a class T; the + /// argument list comes from T's RTTI, [SchemaDescription] and [Optional] + /// (a required property that is missing from arguments is -32602). + /// + /// T must declare only string properties: prompts/get arguments are + /// always plain strings on the wire. + TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) + protected + FName: string; + FTitle: string; + FDescription: string; + FIcons: TJSONArray; + function ExecuteWithParams(const Params: T; Messages: TMCPPromptMessages): string; virtual; abstract; + public + constructor Create; virtual; + destructor Destroy; override; + + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetArguments: TArray; + function GetIcons: TJSONArray; + function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; + end; + +implementation + +uses + System.Classes, + System.Generics.Collections, + MCPServer.ContentBlocks, + MCPServer.Serializer; + +{ TMCPPromptMessages } + +constructor TMCPPromptMessages.Create; +begin + inherited Create; + FMessages := TJSONArray.Create; +end; + +destructor TMCPPromptMessages.Destroy; +begin + FMessages.Free; + inherited; +end; + +function TMCPPromptMessages.AddMessage(const Role: string; const Content: TJSONObject): TMCPPromptMessages; +begin + var Message := TJSONObject.Create; + Message.AddPair('role', Role); + Message.AddPair('content', Content); + FMessages.AddElement(Message); + Result := Self; +end; + +function TMCPPromptMessages.AddText(const Role, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateTextBlock(Text)); +end; + +function TMCPPromptMessages.AddImage(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddImage(Role, EncodeBase64Blob(Data), MimeType); +end; + +function TMCPPromptMessages.AddImage(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateImageBlock(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddAudio(const Role: string; const Data: TBytes; + const MimeType: string): TMCPPromptMessages; +begin + Result := AddAudio(Role, EncodeBase64Blob(Data), MimeType); +end; + +function TMCPPromptMessages.AddAudio(const Role, Base64Data, MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateAudioBlock(Base64Data, MimeType)); +end; + +function TMCPPromptMessages.AddResourceLink(const Role, Uri, Name, Description, + MimeType: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateResourceLinkBlock(Uri, Name, Description, MimeType)); +end; + +function TMCPPromptMessages.AddEmbeddedText(const Role, Uri, MimeType, Text: string): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateEmbeddedTextBlock(Uri, MimeType, Text)); +end; + +function TMCPPromptMessages.AddEmbeddedBlob(const Role, Uri, MimeType: string; + const Data: TBytes): TMCPPromptMessages; +begin + Result := AddMessage(Role, CreateEmbeddedBlobBlock(Uri, MimeType, EncodeBase64Blob(Data))); +end; + +function TMCPPromptMessages.AddEmbeddedResource(const Role: string; const Resource: IMCPResource): TMCPPromptMessages; +var + Binary: IMCPBinaryResource; +begin + if Supports(Resource, IMCPBinaryResource, Binary) then + Result := AddEmbeddedBlob(Role, Resource.URI, Resource.MimeType, Binary.ReadBinary) + else + Result := AddEmbeddedText(Role, Resource.URI, Resource.MimeType, Resource.Read); +end; + +function TMCPPromptMessages.WithAnnotations(const Annotations: TJSONObject): TMCPPromptMessages; +begin + if FMessages.Count = 0 then + begin + Annotations.Free; + raise EInvalidOperation.Create('WithAnnotations needs a message to attach to'); + end; + var LastMessage := TJSONObject(FMessages.Items[FMessages.Count - 1]); + TJSONObject(LastMessage.GetValue('content')).AddPair('annotations', Annotations); + Result := Self; +end; + +function TMCPPromptMessages.ToJson: TJSONArray; +begin + Result := TJSONArray(FMessages.Clone); +end; + +{ TMCPPromptBase } + +constructor TMCPPromptBase.Create; +begin + inherited Create; +end; + +destructor TMCPPromptBase.Destroy; +begin + FIcons.Free; + inherited; +end; + +function TMCPPromptBase.GetName: string; +begin + Result := FName; +end; + +function TMCPPromptBase.GetTitle: string; +begin + if FTitle <> '' then + Result := FTitle + else + Result := FName; +end; + +function TMCPPromptBase.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPPromptBase.GetArguments: TArray; +begin + Result := FArguments; +end; + +function TMCPPromptBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +{ TMCPPromptBase } + +constructor TMCPPromptBase.Create; +begin + inherited Create; +end; + +destructor TMCPPromptBase.Destroy; +begin + FIcons.Free; + inherited; +end; + +function TMCPPromptBase.GetName: string; +begin + Result := FName; +end; + +function TMCPPromptBase.GetTitle: string; +begin + if FTitle <> '' then + Result := FTitle + else + Result := FName; +end; + +function TMCPPromptBase.GetDescription: string; +begin + Result := FDescription; +end; + +function TMCPPromptBase.GetIcons: TJSONArray; +begin + Result := FIcons; +end; + +function TMCPPromptBase.GetArguments: TArray; +begin + var Ctx := TRttiContext.Create; + try + var List := TList.Create; + try + for var Prop in Ctx.GetType(T).GetProperties do + begin + if not (Prop.IsReadable and Prop.IsWritable) then + Continue; + + var Arg: TMCPPromptArgument; + Arg.Name := LowerCase(Prop.Name); + 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..c24476c --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.ContentSamples.pas @@ -0,0 +1,155 @@ +unit MCPServer.Prompt.ContentSamples; + +/// One prompt per content type, matching the fixtures the official +/// conformance suite calls by name (test_simple_prompt and friends), the +/// same role MCPServer.Tool.ContentSamples plays for tools. + +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; + +implementation + +uses + MCPServer.Registration; + +{ TSimplePrompt } + +constructor TSimplePrompt.Create; +begin + inherited; + FName := 'test_simple_prompt'; + FDescription := 'A simple prompt with no arguments'; +end; + +function TSimplePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', 'This is a simple prompt for testing.'); + Result := 'Simple prompt'; +end; + +{ TArgumentsPrompt } + +constructor TArgumentsPrompt.Create; +begin + inherited; + FName := 'test_prompt_with_arguments'; + FDescription := 'A prompt that substitutes its arguments into the message'; +end; + +function TArgumentsPrompt.ExecuteWithParams(const Params: TArgumentsPromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', Format('Prompt with arguments: arg1=''%s'', arg2=''%s''', [Params.Arg1, Params.Arg2])); + Result := 'Prompt with arguments'; +end; + +{ TEmbeddedResourcePrompt } + +constructor TEmbeddedResourcePrompt.Create; +begin + inherited; + FName := 'test_prompt_with_embedded_resource'; + FDescription := 'A prompt that embeds the resource named by its argument'; +end; + +function TEmbeddedResourcePrompt.ExecuteWithParams(const Params: TEmbeddedResourcePromptParams; + Messages: TMCPPromptMessages): string; +begin + Messages.AddEmbeddedText('user', Params.ResourceUri, 'text/plain', 'Embedded resource content for testing.'); + Messages.AddText('user', 'Please process the embedded resource above.'); + Result := 'Prompt with embedded resource'; +end; + +{ TImagePrompt } + +constructor TImagePrompt.Create; +begin + inherited; + FName := 'test_prompt_with_image'; + FDescription := 'A prompt that returns an image content block'; +end; + +function TImagePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddImage('user', SAMPLE_PNG_BASE64, 'image/png'); + Messages.AddText('user', 'Please analyze the image above.'); + Result := 'Prompt with image'; +end; + +initialization + TMCPRegistry.RegisterPrompt('test_simple_prompt', + function: IMCPPrompt + begin + Result := TSimplePrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_arguments', + function: IMCPPrompt + begin + Result := TArgumentsPrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_embedded_resource', + function: IMCPPrompt + begin + Result := TEmbeddedResourcePrompt.Create; + end); + TMCPRegistry.RegisterPrompt('test_prompt_with_image', + function: IMCPPrompt + begin + Result := TImagePrompt.Create; + end); + +end. diff --git a/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas new file mode 100644 index 0000000..247ea29 --- /dev/null +++ b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas @@ -0,0 +1,118 @@ +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; + + /// Asks the model to summarize the server's recent log entries, embedding + /// logs://recent (or a level-filtered view of it) as a resource. The + /// level argument completes against the levels actually present in the + /// log buffer. + TSummarizeLogsPrompt = class(TMCPPromptBase, IMCPCompletable) + protected + function ExecuteWithParams(const Params: TSummarizeLogsParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + function Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; + end; + +implementation + +uses + System.Classes, + MCPServer.Registration, + MCPServer.Resource.Logs; + +{ TSummarizeLogsPrompt } + +constructor TSummarizeLogsPrompt.Create; +begin + inherited; + FName := 'summarize_logs'; + FDescription := 'Summarizes the server''s recent log entries, optionally filtered by level'; +end; + +function TSummarizeLogsPrompt.ExecuteWithParams(const Params: TSummarizeLogsParams; + Messages: TMCPPromptMessages): string; +var + Entries: TObjectList; + ResourceUri, ResourceText: string; +begin + if Params.Level = '' then + begin + Messages.AddText('user', 'Summarize the server''s recent log entries, calling out anything unusual.'); + ResourceUri := 'logs://recent'; + end + else + begin + Messages.AddText('user', Format( + 'Summarize the server''s recent "%s" log entries, calling out anything unusual.', [Params.Level])); + ResourceUri := 'logs://' + Params.Level; + end; + + Entries := TLogBuffer.Instance.GetLogs(100, Params.Level); + try + var Lines := TStringList.Create; + try + for var Entry in Entries do + Lines.Add(Format('[%s] [%s] %s: %s', [FormatDateTime('yyyy-mm-dd hh:nn:ss', Entry.Timestamp), + Entry.Level, Entry.Category, Entry.Message])); + ResourceText := Lines.Text; + finally + Lines.Free; + end; + finally + Entries.Free; + end; + + Messages.AddEmbeddedText('user', ResourceUri, 'text/plain', ResourceText); + Result := 'Log summary request'; +end; + +function TSummarizeLogsPrompt.Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; +begin + if ArgumentName <> 'level' then + Exit(TMCPCompletion.Create(nil)); + + var Levels := TStringList.Create; + try + Levels.Sorted := True; + Levels.Duplicates := dupIgnore; + var Entries := TLogBuffer.Instance.GetLogs(1000); + try + for var Entry in Entries do + if Entry.Level.StartsWith(Value, True) then + Levels.Add(Entry.Level); + finally + Entries.Free; + end; + Result := TMCPCompletion.Create(Levels.ToStringArray, Levels.Count); + finally + Levels.Free; + end; +end; + +initialization + TMCPRegistry.RegisterPrompt('summarize_logs', + function: IMCPPrompt + begin + Result := TSummarizeLogsPrompt.Create; + end); + +end. diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index 55333a8..ac5101c 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -39,6 +39,7 @@ EMCPError = class(Exception) class function UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; /// -32602 with data.name: tools/call names a tool the server does not have. class function UnknownTool(const Name: string): EMCPError; + class function UnknownPrompt(const Name: string): EMCPError; /// Resource not found with data.uri: -32602 in the modern era, -32002 in /// the initialize-based revisions. class function ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; @@ -146,6 +147,13 @@ class function EMCPError.UnknownTool(const Name: string): EMCPError; Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown tool: ' + Name, Data); end; +class function EMCPError.UnknownPrompt(const Name: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('name', Name); + Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown prompt: ' + Name, Data); +end; + class function EMCPError.ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; begin var Data := TJSONObject.Create; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 3983905..6b023ca 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -5,7 +5,8 @@ interface uses System.SysUtils, System.JSON, - System.Rtti; + System.Rtti, + System.Generics.Collections; const /// Protocol version answered by the initialize handshake. Kept under its @@ -138,6 +139,72 @@ SchemaEnumAttribute = class(TCustomAttribute) property Values: TArray read FValues; end; + /// JSON Schema "minLength" of a string parameter. + SchemaMinLengthAttribute = class(TCustomAttribute) + private + FMinLength: Integer; + public + constructor Create(const AMinLength: Integer); + property MinLength: Integer read FMinLength; + end; + + /// JSON Schema "maxLength" of a string parameter. + SchemaMaxLengthAttribute = class(TCustomAttribute) + private + FMaxLength: Integer; + public + constructor Create(const AMaxLength: Integer); + property MaxLength: Integer read FMaxLength; + end; + + /// JSON Schema "pattern" of a string parameter (an ECMA-262 regex). + SchemaPatternAttribute = class(TCustomAttribute) + private + FPattern: string; + public + constructor Create(const APattern: string); + property Pattern: string read FPattern; + end; + + /// JSON Schema "default" of a parameter, given as its JSON text + /// (for example '"red"', '0', 'true'). + SchemaDefaultAttribute = class(TCustomAttribute) + private + FJson: string; + public + constructor Create(const AJson: string); + property Json: string read FJson; + end; + + /// Explicit JSON property name, overriding the default (lowercased + /// property name) the generator and the serializer otherwise use. + SchemaNameAttribute = class(TCustomAttribute) + private + FName: string; + public + constructor Create(const AName: string); + property Name: string read FName; + end; + + /// Class-level: forbids properties the schema does not list. Applies to a + /// tool's or prompt's parameter class; default is to allow them. + SchemaAdditionalPropertiesAttribute = class(TCustomAttribute) + private + FAllowed: Boolean; + public + constructor Create(const AAllowed: Boolean); + property Allowed: Boolean read FAllowed; + end; + + /// Class-level: the JSON Schema dialect ($schema) of a generated schema. + SchemaDialectAttribute = class(TCustomAttribute) + private + FUri: string; + public + constructor Create(const AUri: string); + property Uri: string read FUri; + end; + TMCPToolsCapability = class; IMCPCapabilityManager = interface @@ -333,6 +400,30 @@ TMCPLegacySession = class property CacheScope: string read GetCacheScope; end; + /// Optional icons for prompts/list. May be nil; the prompt keeps ownership. + IMCPPromptMetadata = interface + ['{16C8DAEC-5F70-4192-D3E4-6F708192A3B4}'] + function GetIcons: TJSONArray; + property Icons: TJSONArray read GetIcons; + end; + + /// One suggestion set from completion/complete: at most 100 values, an + /// optional total (-1 when unknown) and whether more exist beyond Values. + TMCPCompletion = record + Values: TArray; + Total: Integer; + HasMore: Boolean; + class function Create(const Values: TArray; Total: Integer = -1): TMCPCompletion; static; + end; + + /// Implemented by a prompt or resource template that offers argument + /// completion; checked with Supports before completion/complete calls it. + IMCPCompletable = interface + ['{27D9EBFD-6081-42A3-E4F5-708192A3B4C5}'] + function Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; + end; + TMCPCapabilities = class private FTools: TMCPToolsCapability; @@ -581,6 +672,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 8dea987..4a090e0 100644 --- a/src/Resources/MCPServer.Resource.Base.pas +++ b/src/Resources/MCPServer.Resource.Base.pas @@ -6,6 +6,8 @@ interface System.SysUtils, System.Rtti, System.JSON, + System.Generics.Collections, + System.RegularExpressions, MCPServer.Types; type @@ -70,9 +72,66 @@ TResourceContent = class property Text: string read FText write FText; end; + /// Variables captured from a URI matched against a template. + TMCPTemplateVars = TDictionary; + + IMCPResourceTemplate = interface + ['{3A5C7E91-8042-4A5B-B6C7-D8E9F0A1B2C3}'] + function GetUriTemplate: string; + function GetName: string; + function GetTitle: string; + function GetDescription: string; + function GetMimeType: string; + /// True when URI matches the template; the captured variables + /// (percent-decoded) are added to Vars. + function Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; + /// Builds the resource for a URI already confirmed to match, with its + /// captured variables. + 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; + + /// Resource template matched by URI, RFC 6570 level 1 (simple string + /// expansion, "{var}", one path segment) and a level 2 subset (reserved + /// expansion, "{+var}", matches the rest of the URI including "/"). + /// "{/var}" and "{?var}" are not supported. + /// + /// Set FUriTemplate, FName and the optional FTitle/FDescription/FMimeType + /// in the constructor of a descendant, as with TMCPResourceBase. + TMCPResourceTemplateBase = class(TInterfacedObject, IMCPResourceTemplate) + strict private + FRegex: TRegEx; + FVariableNames: TArray; + FCompiled: Boolean; + procedure EnsureCompiled; + class function CompilePattern(const UriTemplate: string; out VariableNames: TArray): string; static; + protected + FUriTemplate: string; + FName: string; + FTitle: string; + FDescription: string; + FMimeType: string; + public + constructor Create; virtual; + + 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 + System.NetEncoding, MCPServer.Serializer; { TMCPResourceBase } @@ -181,4 +240,108 @@ function TMCPResourceBase.Read: string; end; end; +{ TMCPResourceTemplateBase } + +constructor TMCPResourceTemplateBase.Create; +begin + inherited Create; + FMimeType := ''; +end; + +class function TMCPResourceTemplateBase.CompilePattern(const UriTemplate: string; + out VariableNames: TArray): string; +var + Names: TList; + Position: Integer; + CloseBrace: Integer; + Expr, VarName, LiteralRun: string; +begin + Names := TList.Create; + try + Result := ''; + Position := 1; + while Position <= Length(UriTemplate) do + begin + if UriTemplate[Position] = '{' then + begin + CloseBrace := System.Pos('}', UriTemplate, Position); + if CloseBrace = 0 then + raise EArgumentException.CreateFmt('Unterminated "{" in URI template "%s"', [UriTemplate]); + + Expr := Copy(UriTemplate, Position + 1, CloseBrace - Position - 1); + if (Expr <> '') and (Expr[1] = '+') then + begin + VarName := Copy(Expr, 2, MaxInt); + Result := Result + Format('(?<%s>.+)', [VarName]); + end + else + begin + VarName := Expr; + Result := Result + Format('(?<%s>[^/]+)', [VarName]); + end; + if VarName = '' then + raise EArgumentException.CreateFmt('Empty variable name in URI template "%s"', [UriTemplate]); + + Names.Add(VarName); + Position := CloseBrace + 1; + end + else + begin + var LiteralStart := Position; + while (Position <= Length(UriTemplate)) and (UriTemplate[Position] <> '{') do + Inc(Position); + LiteralRun := Copy(UriTemplate, LiteralStart, Position - LiteralStart); + Result := Result + TRegEx.Escape(LiteralRun); + end; + end; + Result := '^' + Result + '$'; + VariableNames := Names.ToArray; + finally + Names.Free; + end; +end; + +procedure TMCPResourceTemplateBase.EnsureCompiled; +begin + if FCompiled then + Exit; + FRegex := TRegEx.Create(CompilePattern(FUriTemplate, FVariableNames)); + FCompiled := True; +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 := FRegex.Match(URI); + Result := Match.Success; + if Result then + for var VarName in FVariableNames do + Vars.AddOrSetValue(VarName, TNetEncoding.URL.Decode(Match.Groups[VarName].Value)); +end; + end. From 3a21ecf3af7f086f62f8c76958ca13f404a4ff2a Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:00 +0200 Subject: [PATCH 29/56] feat: add the prompts and completion managers TMCPRegistry gains ordered prompt and resource-template registration. TMCPPromptsManager: prompts/list (pagination, modern cache hints) and prompts/get (-32602 for an unknown prompt or a missing required argument, mapped from the prompt's own EArgumentException since prompts/get has no isError to report it through). TMCPCompletionManager: completion/complete for ref/prompt and ref/resource (a resource template's uriTemplate first, then an exact resource), capped at 100 values with hasMore; a target without IMCPCompletable answers an empty values array rather than an error. --- src/Core/MCPServer.Registration.pas | 80 +++++- src/Managers/MCPServer.CompletionManager.pas | 219 +++++++++++++++ src/Managers/MCPServer.PromptsManager.pas | 281 +++++++++++++++++++ 3 files changed, 578 insertions(+), 2 deletions(-) create mode 100644 src/Managers/MCPServer.CompletionManager.pas create mode 100644 src/Managers/MCPServer.PromptsManager.pas diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index c63411b..f1ff4a5 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -7,6 +7,7 @@ interface System.Generics.Collections, MCPServer.Tool.Base, MCPServer.Resource.Base, + MCPServer.Prompt.Base, MCPServer.Logger; type @@ -14,9 +15,11 @@ TMCPToolClass = class of TMCPToolBase; TMCPToolFactory = reference to function: IMCPTool; TMCPResourceFactory = reference to function: IMCPResource; + TMCPPromptFactory = reference to function: IMCPPrompt; + TMCPResourceTemplateFactory = reference to function: IMCPResourceTemplate; - /// Process-wide registry of tool and resource factories, enumerated in - /// registration order. + /// Process-wide registry of tool, resource, prompt and resource-template + /// factories, enumerated in registration order. /// /// The dictionaries exist from the class constructor on, so registration /// from unit initialization sections needs no lazy checks. Registration is @@ -30,26 +33,39 @@ TMCPRegistry = class class var FToolOrder: TList; class var FResources: TDictionary; 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); /// Removes a registration again (no-op for an unknown URI). Like /// registration, only meaningful before the managers are created. 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; /// Names in registration order. class function GetToolNames: TArray; /// URIs in registration order. class function GetResourceURIs: TArray; + /// Names in registration order. + class function GetPromptNames: TArray; + /// Template strings in registration order. + 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 @@ -62,6 +78,10 @@ implementation FToolOrder := TList.Create; FResources := TDictionary.Create; FResourceOrder := TList.Create; + FPrompts := TDictionary.Create; + FPromptOrder := TList.Create; + FResourceTemplates := TDictionary.Create; + FResourceTemplateOrder := TList.Create; end; class destructor TMCPRegistry.Destroy; @@ -70,6 +90,10 @@ implementation FreeAndNil(FToolOrder); FreeAndNil(FResources); FreeAndNil(FResourceOrder); + FreeAndNil(FPrompts); + FreeAndNil(FPromptOrder); + FreeAndNil(FResourceTemplates); + FreeAndNil(FResourceTemplateOrder); end; class procedure TMCPRegistry.RegisterTool(const Name: string; Factory: TMCPToolFactory); @@ -88,6 +112,23 @@ class procedure TMCPRegistry.RegisterResource(const URI: string; Factory: TMCPRe 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 @@ -118,6 +159,26 @@ class function TMCPRegistry.CreateResource(const URI: string): IMCPResource; raise Exception.CreateFmt('Resource not found: %s', [URI]); end; +class function TMCPRegistry.CreatePrompt(const Name: string): IMCPPrompt; +var + Factory: TMCPPromptFactory; +begin + if FPrompts.TryGetValue(Name, Factory) then + Result := Factory() + else + raise Exception.CreateFmt('Prompt not found: %s', [Name]); +end; + +class function TMCPRegistry.CreateResourceTemplate(const UriTemplate: string): IMCPResourceTemplate; +var + Factory: TMCPResourceTemplateFactory; +begin + if FResourceTemplates.TryGetValue(UriTemplate, Factory) then + Result := Factory() + else + raise Exception.CreateFmt('Resource template not found: %s', [UriTemplate]); +end; + class function TMCPRegistry.GetToolNames: TArray; begin Result := FToolOrder.ToArray; @@ -128,6 +189,16 @@ class function TMCPRegistry.GetResourceURIs: TArray; Result := FResourceOrder.ToArray; end; +class function TMCPRegistry.GetPromptNames: TArray; +begin + Result := FPromptOrder.ToArray; +end; + +class function TMCPRegistry.GetResourceTemplateURIs: TArray; +begin + Result := FResourceTemplateOrder.ToArray; +end; + class function TMCPRegistry.HasTool(const Name: string): Boolean; begin Result := FTools.ContainsKey(Name); @@ -138,4 +209,9 @@ class function TMCPRegistry.HasResource(const URI: string): Boolean; Result := FResources.ContainsKey(URI); end; +class function TMCPRegistry.HasPrompt(const Name: string): Boolean; +begin + Result := FPrompts.ContainsKey(Name); +end; + end. diff --git a/src/Managers/MCPServer.CompletionManager.pas b/src/Managers/MCPServer.CompletionManager.pas new file mode 100644 index 0000000..ff9be7b --- /dev/null +++ b/src/Managers/MCPServer.CompletionManager.pas @@ -0,0 +1,219 @@ +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 + /// completion/complete for a prompt argument (ref/prompt) or a resource + /// template variable (ref/resource, tried as a template's uriTemplate + /// first, then as an exact resource's URI). + /// + /// A target that does not implement IMCPCompletable answers no + /// suggestions rather than an error, since not offering completion for a + /// known prompt or resource is a valid choice. + TMCPCompletionManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) + strict private + FPrompts: TMCPPromptsManager; + FResources: TMCPResourcesManager; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; + function ResolveTarget(const Ref: TJSONObject): IInterface; + function ParseContext(const Params: TJSONObject): TArray>; + function BuildCompletionJSON(const Completion: TMCPCompletion): TJSONObject; + public + constructor Create(const Prompts: TMCPPromptsManager; const Resources: TMCPResourcesManager); + + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); + + function Complete(const Params: System.JSON.TJSONObject): TValue; overload; + function Complete(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.RequestContext, + MCPServer.Prompt.Base, + MCPServer.Resource.Base; + +{ TMCPCompletionManager } + +constructor TMCPCompletionManager.Create(const Prompts: TMCPPromptsManager; const Resources: TMCPResourcesManager); +begin + inherited Create; + FPrompts := Prompts; + FResources := Resources; +end; + +function TMCPCompletionManager.GetCapabilityName: string; +begin + Result := 'completions'; +end; + +function TMCPCompletionManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = 'completion/complete'; +end; + +procedure TMCPCompletionManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + Capabilities.AddPair('completions', TJSONObject.Create); +end; + +function TMCPCompletionManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPCompletionManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPCompletionManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = 'completion/complete' then + Result := Complete(Params, EraOf(Context)) + else + raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); +end; + +function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject): IInterface; +var + Prompt: IMCPPrompt; + Template: IMCPResourceTemplate; + Resource: IMCPResource; +begin + var TypeValue := Ref.GetValue('type'); + if not (TypeValue is TJSONString) then + raise EMCPError.InvalidParams('params.ref.type is required'); + var RefType := TJSONString(TypeValue).Value; + + if RefType = 'ref/prompt' then + begin + var NameValue := Ref.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.ref.name is required for ref/prompt'); + var PromptName := TJSONString(NameValue).Value; + if not FPrompts.TryGetPrompt(PromptName, Prompt) then + raise EMCPError.UnknownPrompt(PromptName); + Result := Prompt; + end + else if RefType = 'ref/resource' then + begin + var UriValue := Ref.GetValue('uri'); + if not (UriValue is TJSONString) or (TJSONString(UriValue).Value = '') then + raise EMCPError.InvalidParams('params.ref.uri is required for ref/resource'); + var Uri := TJSONString(UriValue).Value; + if FResources.TryGetResourceTemplate(Uri, Template) then + Result := Template + else if FResources.TryGetResource(Uri, Resource) then + Result := Resource + else + raise EMCPError.ResourceNotFound(Uri, TMCPProtocolEra.Modern); + end + else + raise EMCPError.InvalidParams('params.ref.type must be "ref/prompt" or "ref/resource"'); +end; + +function TMCPCompletionManager.ParseContext(const Params: TJSONObject): TArray>; +begin + Result := nil; + var ContextValue := Params.GetValue('context'); + if not (ContextValue is TJSONObject) then + Exit; + var ArgumentsValue := TJSONObject(ContextValue).GetValue('arguments'); + if not (ArgumentsValue is TJSONObject) then + Exit; + + var List := TList>.Create; + try + for var Pair in TJSONObject(ArgumentsValue) do + if Pair.JsonValue is TJSONString then + List.Add(TPair.Create(Pair.JsonString.Value, TJSONString(Pair.JsonValue).Value)); + Result := List.ToArray; + finally + List.Free; + end; +end; + +function TMCPCompletionManager.BuildCompletionJSON(const Completion: TMCPCompletion): TJSONObject; +begin + var Values := TJSONArray.Create; + for var Value in Completion.Values do + Values.Add(Value); + + Result := TJSONObject.Create; + Result.AddPair('values', Values); + if Completion.Total >= 0 then + Result.AddPair('total', TJSONNumber.Create(Completion.Total)); + Result.AddPair('hasMore', TJSONBool.Create(Completion.HasMore)); +end; + +function TMCPCompletionManager.Complete(const Params: System.JSON.TJSONObject): TValue; +begin + Result := Complete(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPCompletionManager.Complete(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +var + Completable: IMCPCompletable; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.ref is required'); + + var RefValue := Params.GetValue('ref'); + if not (RefValue is TJSONObject) then + raise EMCPError.InvalidParams('params.ref is required and must be an object'); + + var ArgumentValue := Params.GetValue('argument'); + if not (ArgumentValue is TJSONObject) then + raise EMCPError.InvalidParams('params.argument is required and must be an object'); + var Argument := TJSONObject(ArgumentValue); + var ArgumentNameValue := Argument.GetValue('name'); + if not (ArgumentNameValue is TJSONString) or (TJSONString(ArgumentNameValue).Value = '') then + raise EMCPError.InvalidParams('params.argument.name is required and must be a non-empty string'); + var ArgumentValueValue := Argument.GetValue('value'); + if not (ArgumentValueValue is TJSONString) then + raise EMCPError.InvalidParams('params.argument.value is required and must be a string'); + + TLogger.Info('MCP Complete called for argument: ' + TJSONString(ArgumentNameValue).Value); + + var Target := ResolveTarget(TJSONObject(RefValue)); + 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.PromptsManager.pas b/src/Managers/MCPServer.PromptsManager.pas new file mode 100644 index 0000000..3234cee --- /dev/null +++ b/src/Managers/MCPServer.PromptsManager.pas @@ -0,0 +1,281 @@ +unit MCPServer.PromptsManager; + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON, + System.Rtti, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Logger, + MCPServer.Prompt.Base; + +type + /// prompts/list and prompts/get over the prompts registered in + /// TMCPRegistry, listed in registration order. + /// + /// A missing or unknown prompt name is -32602 (EMCPError.UnknownPrompt); + /// a missing required argument or a wrong argument type is -32602 too + /// (mapped from the prompt's own EArgumentException), since prompts/get + /// has no isError concept to report it through instead. + TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) + strict private + FPrompts: TDictionary; + FOrder: TList; + FListTtlMs: Integer; + FListCacheScope: string; + procedure RegisterPrompt(const Prompt: IMCPPrompt); + procedure RegisterBuiltInPrompts; + procedure CheckCursor(const Params: TJSONObject); + function CreatePromptJSON(const Prompt: IMCPPrompt): TJSONObject; + function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; + public + constructor Create; + destructor Destroy; override; + + /// Adds a prompt to this manager only (next to the ones from TMCPRegistry). + procedure AddPrompt(const Prompt: IMCPPrompt); + /// The prompt registered under Name, or nil. + 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; + + /// Cache hints on prompts/list for modern clients; 0 and 'private' unless set. + property ListTtlMs: Integer read FListTtlMs write FListTtlMs; + property ListCacheScope: string read FListCacheScope write FListCacheScope; + end; + +implementation + +uses + MCPServer.Registration, + MCPServer.RequestContext, + MCPServer.Errors; + +{ TMCPPromptsManager } + +constructor TMCPPromptsManager.Create; +begin + inherited; + FPrompts := TDictionary.Create; + FOrder := TList.Create; + FListTtlMs := 0; + FListCacheScope := MCP_CACHE_SCOPE_PRIVATE; + RegisterBuiltInPrompts; +end; + +destructor TMCPPromptsManager.Destroy; +begin + FPrompts.Free; + FOrder.Free; + inherited; +end; + +function TMCPPromptsManager.GetCapabilityName: string; +begin + Result := 'prompts'; +end; + +function TMCPPromptsManager.HandlesMethod(const Method: string): Boolean; +begin + Result := (Method = 'prompts/list') or (Method = 'prompts/get'); +end; + +procedure TMCPPromptsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); +begin + var Prompts := TJSONObject.Create; + Prompts.AddPair('listChanged', TJSONBool.Create(False)); + Capabilities.AddPair('prompts', Prompts); +end; + +function TMCPPromptsManager.EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; +begin + if Assigned(Context) then + Result := Context.Era + else + Result := TMCPProtocolEra.Legacy; +end; + +function TMCPPromptsManager.ExecuteMethod(const Method: string; const Params: System.JSON.TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, TMCPRequestContext.Current); +end; + +function TMCPPromptsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method = 'prompts/list' then + Result := ListPrompts(Params, EraOf(Context)) + else if Method = 'prompts/get' then + Result := GetPrompt(Params, EraOf(Context)) + else + raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); +end; + +procedure TMCPPromptsManager.RegisterPrompt(const Prompt: IMCPPrompt); +begin + if not FPrompts.ContainsKey(Prompt.Name) then + FOrder.Add(Prompt.Name); + FPrompts.AddOrSetValue(Prompt.Name, Prompt); +end; + +procedure TMCPPromptsManager.RegisterBuiltInPrompts; +begin + for var PromptName in TMCPRegistry.GetPromptNames do + RegisterPrompt(TMCPRegistry.CreatePrompt(PromptName)); +end; + +procedure TMCPPromptsManager.AddPrompt(const Prompt: IMCPPrompt); +begin + RegisterPrompt(Prompt); +end; + +function TMCPPromptsManager.TryGetPrompt(const Name: string; out Prompt: IMCPPrompt): Boolean; +begin + Result := FPrompts.TryGetValue(Name, Prompt); +end; + +procedure TMCPPromptsManager.CheckCursor(const Params: TJSONObject); +begin + // Every list fits in one page; a cursor is never one this server issued. + if Assigned(Params) and Assigned(Params.GetValue('cursor')) then + raise EMCPError.InvalidParams('Invalid cursor'); +end; + +function TMCPPromptsManager.CreatePromptJSON(const Prompt: IMCPPrompt): TJSONObject; +var + Metadata: IMCPPromptMetadata; +begin + Result := TJSONObject.Create; + Result.AddPair('name', Prompt.Name); + if Prompt.Title <> Prompt.Name then + Result.AddPair('title', Prompt.Title); + if Prompt.Description <> '' then + Result.AddPair('description', Prompt.Description); + + var Arguments := Prompt.Arguments; + if Length(Arguments) > 0 then + begin + var ArgumentsArray := TJSONArray.Create; + Result.AddPair('arguments', ArgumentsArray); + for var Arg in Arguments do + begin + var ArgObject := TJSONObject.Create; + ArgumentsArray.AddElement(ArgObject); + ArgObject.AddPair('name', Arg.Name); + if Arg.Description <> '' then + ArgObject.AddPair('description', Arg.Description); + ArgObject.AddPair('required', TJSONBool.Create(Arg.Required)); + end; + end; + + if Supports(Prompt, IMCPPromptMetadata, Metadata) and Assigned(Metadata.Icons) then + Result.AddPair('icons', TJSONArray(Metadata.Icons.Clone)); +end; + +function TMCPPromptsManager.ListPrompts: TValue; +begin + Result := ListPrompts(nil, TMCPProtocolEra.Legacy); +end; + +function TMCPPromptsManager.ListPrompts(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +begin + TLogger.Info('MCP ListPrompts called'); + CheckCursor(Params); + + var ResultJSON := TJSONObject.Create; + try + var PromptsArray := TJSONArray.Create; + ResultJSON.AddPair('prompts', PromptsArray); + for var Name in FOrder do + PromptsArray.AddElement(CreatePromptJSON(FPrompts[Name])); + + if Era = TMCPProtocolEra.Modern then + begin + ResultJSON.AddPair('ttlMs', TJSONNumber.Create(FListTtlMs)); + ResultJSON.AddPair('cacheScope', FListCacheScope); + end; + + Result := TValue.From(ResultJSON); + except + ResultJSON.Free; + raise; + end; +end; + +function TMCPPromptsManager.GetPrompt(const Params: System.JSON.TJSONObject): TValue; +begin + Result := GetPrompt(Params, TMCPProtocolEra.Legacy); +end; + +function TMCPPromptsManager.GetPrompt(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; +var + Prompt: IMCPPrompt; +begin + if not Assigned(Params) then + raise EMCPError.InvalidParams('params.name is required'); + var NameValue := Params.GetValue('name'); + if not (NameValue is TJSONString) or (TJSONString(NameValue).Value = '') then + raise EMCPError.InvalidParams('params.name is required and must be a non-empty string'); + var PromptName := TJSONString(NameValue).Value; + + var ArgumentsValue := Params.GetValue('arguments'); + if Assigned(ArgumentsValue) and not (ArgumentsValue is TJSONObject) and not (ArgumentsValue is TJSONNull) then + raise EMCPError.InvalidParams('params.arguments must be an object'); + var OwnedArguments: TJSONObject := nil; + var Arguments: TJSONObject; + if ArgumentsValue is TJSONObject then + Arguments := TJSONObject(ArgumentsValue) + else + begin + OwnedArguments := TJSONObject.Create; + Arguments := OwnedArguments; + end; + + try + if not FPrompts.TryGetValue(PromptName, Prompt) then + raise EMCPError.UnknownPrompt(PromptName); + + TLogger.Info('MCP GetPrompt called for prompt: ' + PromptName); + + var Messages := TMCPPromptMessages.Create; + try + var Description: string; + try + Description := Prompt.Get(Arguments, Messages); + except + on E: EArgumentException do + raise EMCPError.InvalidParams('Invalid arguments: ' + E.Message); + end; + + var ResultJSON := TJSONObject.Create; + try + if Description <> '' then + ResultJSON.AddPair('description', Description); + ResultJSON.AddPair('messages', Messages.ToJson); + Result := TValue.From(ResultJSON); + except + ResultJSON.Free; + raise; + end; + finally + Messages.Free; + end; + finally + OwnedArguments.Free; + end; +end; + +end. From 0a297caad3c9933d7dff897551eb1db1c7ad11c3 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:00 +0200 Subject: [PATCH 30/56] feat: resolve resources/read against registered templates TMCPResourcesManager tries an exact resource first, then each registered template in order; resources/templates/list lists them for real instead of a hard-coded empty array. logs://{level} filters the existing log buffer by level; test://template/{id}/data is the official conformance fixture. --- src/Resources/MCPServer.Resource.Logs.pas | 98 ++++++++++++++++++++ src/Resources/MCPServer.Resource.Samples.pas | 68 ++++++++++++++ 2 files changed, 166 insertions(+) diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index 554f7ab..f340916 100644 --- a/src/Resources/MCPServer.Resource.Logs.pas +++ b/src/Resources/MCPServer.Resource.Logs.pas @@ -64,6 +64,26 @@ TLogsRecentResource = class(TMCPResourceBase) constructor Create; override; end; + /// A single log level, e.g. "logs://INFO"; matched by TLogsByLevelTemplate. + TLogsByLevelResource = class(TMCPResourceBase) + private + FLevel: string; + protected + function GetResourceData: TLogEntries; override; + public + constructor CreateForLevel(const AUri, ALevel: string); reintroduce; + end; + + /// logs://{level}: the same recent-log data as logs://recent, filtered to + /// one level. Completes the level argument against the levels actually + /// present in the buffer. + 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 @@ -226,6 +246,77 @@ function TLogsRecentResource.GetResourceData: TLogEntries; end; +{ TLogsByLevelResource } + +constructor TLogsByLevelResource.CreateForLevel(const AUri, ALevel: string); +begin + inherited Create; + FLevel := ALevel; + FURI := AUri; + FName := 'Recent logs (' + ALevel + ')'; + FDescription := 'Recent log entries at level ' + ALevel; + FMimeType := 'application/json'; + FTtlMs := 0; + FCacheScope := MCP_CACHE_SCOPE_PRIVATE; +end; + +function TLogsByLevelResource.GetResourceData: TLogEntries; +var + Logs: TObjectList; +begin + Result := TLogEntries.Create; + + Logs := TLogBuffer.Instance.GetLogs(MAX_RECENT_LOG_ENTRIES, FLevel); + try + Result.Entries.AddRange(Logs); + Result.TotalCount := Logs.Count; + Result.FilteredCount := Logs.Count; + Logs.OwnsObjects := False; + finally + Logs.Free; + end; +end; + +{ TLogsByLevelTemplate } + +constructor TLogsByLevelTemplate.Create; +begin + inherited; + FUriTemplate := 'logs://{level}'; + FName := 'Recent logs by level'; + FDescription := 'Recent log entries at the given level, e.g. logs://INFO'; + FMimeType := 'application/json'; +end; + +function TLogsByLevelTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TLogsByLevelResource.CreateForLevel(URI, Vars['level']); +end; + +function TLogsByLevelTemplate.Complete(const ArgumentName, Value: string; + const Context: TArray>): TMCPCompletion; +begin + if ArgumentName <> 'level' then + Exit(TMCPCompletion.Create(nil)); + + var Levels := TStringList.Create; + try + Levels.Sorted := True; + Levels.Duplicates := dupIgnore; + var Entries := TLogBuffer.Instance.GetLogs(1000); + try + for var Entry in Entries do + if Entry.Level.StartsWith(Value, True) then + Levels.Add(Entry.Level); + finally + Entries.Free; + end; + Result := TMCPCompletion.Create(Levels.ToStringArray, Levels.Count); + finally + Levels.Free; + end; +end; + initialization TLogBuffer.FLock := TCriticalSection.Create; @@ -243,6 +334,13 @@ initialization Result := TLogsRecentResource.Create; end ); + + TMCPRegistry.RegisterResourceTemplate('logs://{level}', + function: IMCPResourceTemplate + begin + Result := TLogsByLevelTemplate.Create; + end + ); finalization diff --git a/src/Resources/MCPServer.Resource.Samples.pas b/src/Resources/MCPServer.Resource.Samples.pas index 042dfec..b6bd283 100644 --- a/src/Resources/MCPServer.Resource.Samples.pas +++ b/src/Resources/MCPServer.Resource.Samples.pas @@ -33,6 +33,33 @@ TStaticBinaryResource = class(TMCPResourceBase, IMCPBinaryResourc 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; + + /// test://template/{id}/data, matched by TTemplateDataResourceTemplate. + 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 @@ -89,6 +116,42 @@ function TStaticBinaryResource.ReadBinary: TBytes; Result := TNetEncoding.Base64.DecodeStringToBytes(SAMPLE_PNG_BASE64); end; +{ TTemplateDataResource } + +constructor TTemplateDataResource.CreateForId(const AUri, AId: string); +begin + inherited Create; + FId := AId; + FURI := AUri; + FName := 'Template data'; + FDescription := 'Data keyed by the id captured from the template'; + FMimeType := 'application/json'; +end; + +function TTemplateDataResource.GetResourceData: TTemplateData; +begin + Result := TTemplateData.Create; + Result.Id := FId; + Result.TemplateTest := True; + Result.Data := 'Data for ID: ' + FId; +end; + +{ TTemplateDataResourceTemplate } + +constructor TTemplateDataResourceTemplate.Create; +begin + inherited; + FUriTemplate := 'test://template/{id}/data'; + FName := 'Template data'; + FDescription := 'Data keyed by an id path segment'; + FMimeType := 'application/json'; +end; + +function TTemplateDataResourceTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TTemplateDataResource.CreateForId(URI, Vars['id']); +end; + initialization TMCPRegistry.RegisterResource(SAMPLE_TEXT_RESOURCE_URI, function: IMCPResource @@ -100,5 +163,10 @@ initialization begin Result := TStaticBinaryResource.Create; end); + TMCPRegistry.RegisterResourceTemplate('test://template/{id}/data', + function: IMCPResourceTemplate + begin + Result := TTemplateDataResourceTemplate.Create; + end); end. From a591773eb23732b52e5fd03f4e4e3a74def108f7 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:00 +0200 Subject: [PATCH 31/56] feat: add a JSON Schema validator and the remaining schema attributes MCPServer.Schema.Validator: a 2020-12 subset (type, enum, const, required, properties, items, additionalProperties, minimum, maximum, minLength, maxLength, pattern, a same-document $ref, a depth cap). TMCPToolBase (the hand-written-schema base) validates Arguments against BuildSchema before calling the renamed DoExecute, the only validation those tools get since they never go through TMCPSerializer; in DEBUG builds the tools manager also warns when structuredContent does not match outputSchema. SchemaMinLength, SchemaMaxLength, SchemaPattern, SchemaDefault, SchemaName (honoured by the serializer in both directions, not just the generator) and the class-level SchemaAdditionalProperties and SchemaDialect. --- src/Protocol/MCPServer.Schema.Generator.pas | 38 ++- src/Protocol/MCPServer.Schema.Validator.pas | 323 ++++++++++++++++++++ src/Protocol/MCPServer.Serializer.pas | 21 +- src/Tools/MCPServer.Tool.Base.pas | 23 +- 4 files changed, 393 insertions(+), 12 deletions(-) create mode 100644 src/Protocol/MCPServer.Schema.Validator.pas diff --git a/src/Protocol/MCPServer.Schema.Generator.pas b/src/Protocol/MCPServer.Schema.Generator.pas index 890f62d..0332371 100644 --- a/src/Protocol/MCPServer.Schema.Generator.pas +++ b/src/Protocol/MCPServer.Schema.Generator.pas @@ -23,8 +23,11 @@ interface /// TJSONArray / TJSONObject array / object (free form) /// other classes nested object schema /// - /// Attributes: [SchemaDescription], [SchemaTitle], [SchemaFormat], - /// [SchemaMinimum], [SchemaMaximum], [SchemaEnum] and [Optional]. + /// Property attributes: [SchemaDescription], [SchemaTitle], [SchemaFormat], + /// [SchemaMinimum], [SchemaMaximum], [SchemaMinLength], [SchemaMaxLength], + /// [SchemaPattern], [SchemaDefault], [SchemaEnum], [SchemaName] (overrides + /// the wire name) and [Optional]. Class attributes: + /// [SchemaAdditionalProperties] and [SchemaDialect] (root schema only). TMCPSchemaGenerator = class private const MAX_NESTING_DEPTH = 8; @@ -64,6 +67,9 @@ class function TMCPSchemaGenerator.GenerateSchemaFromInstance(Instance: TObject) class function TMCPSchemaGenerator.GetPropertyJsonName(Prop: TRttiProperty): string; begin + for var Attr in Prop.GetAttributes do + if Attr is SchemaNameAttribute then + Exit(SchemaNameAttribute(Attr).Name); Result := LowerCase(Prop.Name); end; @@ -228,7 +234,15 @@ class procedure TMCPSchemaGenerator.ApplyAttributes(Prop: TRttiProperty; const P for var Value in SchemaEnumAttribute(Attr).Values do EnumArray.Add(Value); PropSchema.AddPair('enum', EnumArray); - end; + end + else if Attr is SchemaMinLengthAttribute then + PropSchema.AddPair('minLength', TJSONNumber.Create(SchemaMinLengthAttribute(Attr).MinLength)) + else if Attr is SchemaMaxLengthAttribute then + PropSchema.AddPair('maxLength', TJSONNumber.Create(SchemaMaxLengthAttribute(Attr).MaxLength)) + else if Attr is SchemaPatternAttribute then + PropSchema.AddPair('pattern', SchemaPatternAttribute(Attr).Pattern) + else if Attr is SchemaDefaultAttribute then + PropSchema.AddPair('default', TJSONObject.ParseJSONValue(SchemaDefaultAttribute(Attr).Json)); end; end; @@ -236,6 +250,11 @@ class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Inte begin Result := TJSONObject.Create; try + if Depth = 0 then + for var Attr in RttiType.GetAttributes do + if Attr is SchemaDialectAttribute then + Result.AddPair('$schema', SchemaDialectAttribute(Attr).Uri); + Result.AddPair('type', 'object'); var Properties := TJSONObject.Create; Result.AddPair('properties', Properties); @@ -260,8 +279,17 @@ class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Inte else RequiredArray.Free; - // A tool without parameters accepts an empty object and nothing else. - if Properties.Count = 0 then + var ExplicitAdditionalProperties := False; + for var Attr in RttiType.GetAttributes do + if Attr is SchemaAdditionalPropertiesAttribute then + begin + Result.AddPair('additionalProperties', TJSONBool.Create(SchemaAdditionalPropertiesAttribute(Attr).Allowed)); + ExplicitAdditionalProperties := True; + end; + + // A tool without parameters accepts an empty object and nothing else, + // unless the class said otherwise. + if not ExplicitAdditionalProperties and (Properties.Count = 0) then Result.AddPair('additionalProperties', TJSONBool.Create(False)); except Result.Free; diff --git a/src/Protocol/MCPServer.Schema.Validator.pas b/src/Protocol/MCPServer.Schema.Validator.pas new file mode 100644 index 0000000..3108452 --- /dev/null +++ b/src/Protocol/MCPServer.Schema.Validator.pas @@ -0,0 +1,323 @@ +unit MCPServer.Schema.Validator; + +/// A JSON Schema (2020-12) subset validator for hand-written schemas and for +/// checking a tool's structuredContent against its outputSchema. +/// +/// Covers: type (string or array, including "null"), enum, const, required, +/// properties (recursive), additionalProperties (boolean), items +/// (recursive), minimum/maximum, minLength/maxLength, pattern. A same- +/// document "$ref" ("#/$defs/Name" or "#/definitions/Name") is resolved; +/// anything else (a network reference, "#/properties/..." and similar) is a +/// validation error rather than a crash or a silent no-op, since the +/// specification forbids network references. Nesting deeper than +/// MAX_DEPTH is a validation error, not a stack overflow. + +interface + +uses + System.SysUtils, + System.Classes, + System.JSON; + +type + TMCPSchemaValidator = class + public + const MAX_DEPTH = 32; + + /// True when Instance satisfies Schema; Errors lists every violation + /// found (empty when Result is True). + class function Validate(const Schema: TJSONObject; const Instance: TJSONValue; + out Errors: TArray): Boolean; + private + class function ValidateNode(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; + class function ResolveRef(const RootSchema: TJSONObject; const Ref: string; + out Resolved: TJSONObject): Boolean; + class function MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; + class function CheckType(const Schema: TJSONObject; const Instance: TJSONValue; + out ErrorMessage: string): Boolean; + class function JsonEquals(A, B: TJSONValue): Boolean; + class procedure AddError(Errors: TStrings; const Path, Message: string); + end; + +implementation + +uses + System.Generics.Collections, + System.RegularExpressions; + +{ TMCPSchemaValidator } + +class procedure TMCPSchemaValidator.AddError(Errors: TStrings; const Path, Message: string); +begin + if Path = '' then + Errors.Add(Message) + else + Errors.Add(Path + ': ' + Message); +end; + +class function TMCPSchemaValidator.MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; +begin + // TJSONNumber descends from TJSONString, so "string" must exclude it + // explicitly and "integer"/"number" must be checked before it. + if TypeName = 'null' then + Result := not Assigned(Instance) or (Instance is TJSONNull) + else if TypeName = 'boolean' then + Result := Instance is TJSONBool + else if TypeName = 'integer' then + Result := (Instance is TJSONNumber) and (Frac(TJSONNumber(Instance).AsDouble) = 0) + else if TypeName = 'number' then + Result := Instance is TJSONNumber + else if TypeName = 'string' then + Result := (Instance is TJSONString) and not (Instance is TJSONNumber) + else if TypeName = 'object' then + Result := Instance is TJSONObject + else if TypeName = 'array' then + Result := Instance is TJSONArray + else + Result := False; +end; + +class function TMCPSchemaValidator.CheckType(const Schema: TJSONObject; const Instance: TJSONValue; + out ErrorMessage: string): Boolean; +begin + Result := True; + ErrorMessage := ''; + var TypeValue := Schema.GetValue('type'); + if not Assigned(TypeValue) then + Exit; + + if (TypeValue is TJSONString) and not (TypeValue is TJSONNumber) then + begin + Result := MatchesType(Instance, TJSONString(TypeValue).Value); + if not Result then + ErrorMessage := 'expected ' + TJSONString(TypeValue).Value; + Exit; + end; + + if TypeValue is TJSONArray then + begin + var Names := TStringList.Create; + try + for var Item in TJSONArray(TypeValue) do + if (Item is TJSONString) and not (Item is TJSONNumber) then + begin + Names.Add(TJSONString(Item).Value); + if MatchesType(Instance, TJSONString(Item).Value) then + Exit(True); + end; + Result := False; + ErrorMessage := 'expected one of: ' + Names.CommaText; + finally + Names.Free; + end; + end; +end; + +class function TMCPSchemaValidator.JsonEquals(A, B: TJSONValue): Boolean; +begin + if not Assigned(A) or not Assigned(B) then + Exit(not Assigned(A) and not Assigned(B)); + if (A is TJSONNull) or (B is TJSONNull) then + Exit((A is TJSONNull) and (B is TJSONNull)); + if (A is TJSONBool) or (B is TJSONBool) then + Exit((A is TJSONBool) and (B is TJSONBool) and (TJSONBool(A).AsBoolean = TJSONBool(B).AsBoolean)); + if (A is TJSONNumber) or (B is TJSONNumber) then + Exit((A is TJSONNumber) and (B is TJSONNumber) and (TJSONNumber(A).AsDouble = TJSONNumber(B).AsDouble)); + if (A is TJSONString) or (B is TJSONString) then + Exit((A is TJSONString) and (B is TJSONString) and (TJSONString(A).Value = TJSONString(B).Value)); + // Objects and arrays: canonical text is good enough for the schemas this + // server generates or ships with. + Result := A.ToJSON = B.ToJSON; +end; + +class function TMCPSchemaValidator.ResolveRef(const RootSchema: TJSONObject; const Ref: string; + out Resolved: TJSONObject): Boolean; +const + DEFS_PREFIX = '#/$defs/'; + DEFINITIONS_PREFIX = '#/definitions/'; +begin + Resolved := nil; + + var DefsValue: TJSONValue; + var Name := ''; + if Ref.StartsWith(DEFS_PREFIX) then + begin + Name := Copy(Ref, Length(DEFS_PREFIX) + 1, MaxInt); + DefsValue := RootSchema.GetValue('$defs'); + end + else if Ref.StartsWith(DEFINITIONS_PREFIX) then + begin + Name := Copy(Ref, Length(DEFINITIONS_PREFIX) + 1, MaxInt); + DefsValue := RootSchema.GetValue('definitions'); + end + else + Exit(False); + + if not (DefsValue is TJSONObject) then + Exit(False); + var Entry := TJSONObject(DefsValue).GetValue(Name); + if not (Entry is TJSONObject) then + Exit(False); + + Resolved := TJSONObject(Entry); + Result := True; +end; + +class function TMCPSchemaValidator.ValidateNode(const Schema: TJSONObject; const Instance: TJSONValue; + const Path: string; Depth: Integer; const RootSchema: TJSONObject; Errors: TStrings): Boolean; +begin + Result := True; + if Depth > MAX_DEPTH then + begin + AddError(Errors, Path, 'schema nested too deeply'); + Exit(False); + end; + + var ResolvedSchema := Schema; + var RefValue := Schema.GetValue('$ref'); + if (RefValue is TJSONString) and not (RefValue is TJSONNumber) then + begin + if not ResolveRef(RootSchema, TJSONString(RefValue).Value, ResolvedSchema) then + begin + AddError(Errors, Path, 'unsupported $ref "' + TJSONString(RefValue).Value + '"'); + Exit(False); + end; + end; + + var ConstValue := ResolvedSchema.GetValue('const'); + if Assigned(ConstValue) and not JsonEquals(ConstValue, Instance) then + begin + AddError(Errors, Path, 'does not match const'); + Result := False; + end; + + var EnumValue := ResolvedSchema.GetValue('enum'); + if EnumValue is TJSONArray then + begin + var Found := False; + for var Item in TJSONArray(EnumValue) do + if JsonEquals(Item, Instance) then + begin + Found := True; + Break; + end; + if not Found then + begin + AddError(Errors, Path, 'not one of the allowed values'); + Result := False; + end; + end; + + var TypeError: string; + if not CheckType(ResolvedSchema, Instance, TypeError) then + begin + AddError(Errors, Path, TypeError); + // The wrong JSON kind makes structural checks below meaningless. + Exit(False); + end; + + if (Instance is TJSONString) and not (Instance is TJSONNumber) then + begin + var Text := TJSONString(Instance).Value; + var MinLengthValue := ResolvedSchema.GetValue('minLength'); + if (MinLengthValue is TJSONNumber) and (Length(Text) < TJSONNumber(MinLengthValue).AsInt) then + begin + AddError(Errors, Path, 'shorter than minLength'); + Result := False; + end; + var MaxLengthValue := ResolvedSchema.GetValue('maxLength'); + if (MaxLengthValue is TJSONNumber) and (Length(Text) > TJSONNumber(MaxLengthValue).AsInt) then + begin + AddError(Errors, Path, 'longer than maxLength'); + Result := False; + end; + var PatternValue := ResolvedSchema.GetValue('pattern'); + if (PatternValue is TJSONString) and not (PatternValue is TJSONNumber) + and not TRegEx.IsMatch(Text, TJSONString(PatternValue).Value) then + begin + AddError(Errors, Path, 'does not match pattern'); + Result := False; + end; + end; + + if Instance is TJSONNumber then + begin + var NumberValue := TJSONNumber(Instance).AsDouble; + var MinimumValue := ResolvedSchema.GetValue('minimum'); + if (MinimumValue is TJSONNumber) and (NumberValue < TJSONNumber(MinimumValue).AsDouble) then + begin + AddError(Errors, Path, 'less than minimum'); + Result := False; + end; + var MaximumValue := ResolvedSchema.GetValue('maximum'); + if (MaximumValue is TJSONNumber) and (NumberValue > TJSONNumber(MaximumValue).AsDouble) then + begin + AddError(Errors, Path, 'greater than maximum'); + Result := False; + end; + end; + + if Instance is TJSONObject then + begin + var Obj := TJSONObject(Instance); + + var RequiredValue := ResolvedSchema.GetValue('required'); + if RequiredValue is TJSONArray then + for var Item in TJSONArray(RequiredValue) do + if (Item is TJSONString) and not (Item is TJSONNumber) + and not Assigned(Obj.GetValue(TJSONString(Item).Value)) then + begin + AddError(Errors, Path, 'missing required property "' + TJSONString(Item).Value + '"'); + Result := False; + end; + + var PropSchemas: TJSONObject := nil; + var PropertiesValue := ResolvedSchema.GetValue('properties'); + if PropertiesValue is TJSONObject then + PropSchemas := TJSONObject(PropertiesValue); + + if Assigned(PropSchemas) then + for var Pair in Obj do + begin + var PropSchemaValue := PropSchemas.GetValue(Pair.JsonString.Value); + if PropSchemaValue is TJSONObject then + if not ValidateNode(TJSONObject(PropSchemaValue), Pair.JsonValue, Path + '.' + Pair.JsonString.Value, + Depth + 1, RootSchema, Errors) then + Result := False; + end; + + var AdditionalValue := ResolvedSchema.GetValue('additionalProperties'); + if (AdditionalValue is TJSONBool) and not TJSONBool(AdditionalValue).AsBoolean then + for var Pair in Obj do + if not (Assigned(PropSchemas) and Assigned(PropSchemas.GetValue(Pair.JsonString.Value))) then + begin + AddError(Errors, Path, 'unexpected property "' + Pair.JsonString.Value + '"'); + Result := False; + end; + end; + + if Instance is TJSONArray then + begin + var ItemsValue := ResolvedSchema.GetValue('items'); + if ItemsValue is TJSONObject then + for var I := 0 to TJSONArray(Instance).Count - 1 do + if not ValidateNode(TJSONObject(ItemsValue), TJSONArray(Instance).Items[I], Format('%s[%d]', [Path, I]), + Depth + 1, RootSchema, Errors) then + Result := False; + end; +end; + +class function TMCPSchemaValidator.Validate(const Schema: TJSONObject; const Instance: TJSONValue; + out Errors: TArray): Boolean; +begin + var ErrorList := TStringList.Create; + try + Result := ValidateNode(Schema, Instance, 'value', 0, Schema, ErrorList); + Errors := ErrorList.ToStringArray; + finally + ErrorList.Free; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.Serializer.pas b/src/Protocol/MCPServer.Serializer.pas index f3c2ce1..dd7c25a 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -37,6 +37,9 @@ TMCPSerializer = class // Single normalization rule shared by lookup and validation class function NormalizeKey(const Name: string): string; inline; class function IsRequiredProperty(const Prop: TRttiProperty): Boolean; + /// The wire name: [SchemaName] when present, otherwise the lowercased + /// property name, matching the schema generator. + class function GetWireName(const Prop: TRttiProperty): string; public class constructor Create; class destructor Destroy; @@ -113,7 +116,7 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: try for RttiProp in RttiType.GetProperties do if RttiProp.IsWritable then - KnownNorms.Add(NormalizeKey(RttiProp.Name)); + KnownNorms.Add(NormalizeKey(GetWireName(RttiProp))); for Pair in Json do begin @@ -132,13 +135,13 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: if not RttiProp.IsWritable then Continue; - JsonValue := GetJsonValueCaseInsensitive(Json, RttiProp.Name); + JsonValue := GetJsonValueCaseInsensitive(Json, GetWireName(RttiProp)); // Absent and null both mean "not given"; a required parameter must be given. if not Assigned(JsonValue) or (JsonValue is TJSONNull) then begin if IsRequiredProperty(RttiProp) then - raise EArgumentException.CreateFmt('Missing required parameter "%s"', [LowerCase(RttiProp.Name)]); + raise EArgumentException.CreateFmt('Missing required parameter "%s"', [GetWireName(RttiProp)]); Continue; end; @@ -146,7 +149,7 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: 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 @@ -166,6 +169,14 @@ class function TMCPSerializer.IsRequiredProperty(const Prop: TRttiProperty): Boo Result := True; end; +class function TMCPSerializer.GetWireName(const Prop: TRttiProperty): string; +begin + for var Attr in Prop.GetAttributes do + if Attr is SchemaNameAttribute then + Exit(SchemaNameAttribute(Attr).Name); + Result := LowerCase(Prop.Name); +end; + class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); var JsonValue: TJSONValue; @@ -181,7 +192,7 @@ 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} diff --git a/src/Tools/MCPServer.Tool.Base.pas b/src/Tools/MCPServer.Tool.Base.pas index a53cf03..cb80248 100644 --- a/src/Tools/MCPServer.Tool.Base.pas +++ b/src/Tools/MCPServer.Tool.Base.pas @@ -31,7 +31,11 @@ interface /// Tool with a hand-written schema and raw JSON arguments. /// /// The protected fields FAnnotations and FIcons (nil by default) are - /// reported in tools/list when set; the tool owns them. + /// reported in tools/list when set; the tool owns them. Execute validates + /// Arguments against BuildSchema (raising EArgumentException, which the + /// tools manager reports as an isError result) before calling DoExecute; + /// this is the only validation a hand-written schema gets, since it does + /// not go through TMCPSerializer. TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; @@ -40,6 +44,7 @@ TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) FAnnotations: TJSONObject; FIcons: TJSONArray; function BuildSchema: TJSONObject; virtual; abstract; + function DoExecute(const Arguments: TJSONObject): TValue; virtual; abstract; public constructor Create; virtual; destructor Destroy; override; @@ -51,7 +56,7 @@ TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) function GetOutputSchema: TJSONObject; function GetAnnotations: TJSONObject; function GetIcons: TJSONArray; - function Execute(const Arguments: TJSONObject): TValue; virtual; abstract; + function Execute(const Arguments: TJSONObject): TValue; end; /// Tool whose parameters are a class T; the schema comes from T's RTTI. @@ -112,6 +117,7 @@ implementation uses MCPServer.Schema.Generator, + MCPServer.Schema.Validator, MCPServer.Serializer, MCPServer.RequestContext, MCPServer.Tool.Result; @@ -168,6 +174,19 @@ function TMCPToolBase.GetIcons: TJSONArray; Result := FIcons; end; +function TMCPToolBase.Execute(const Arguments: TJSONObject): TValue; +begin + var Schema := BuildSchema; + try + var Errors: TArray; + if not TMCPSchemaValidator.Validate(Schema, Arguments, Errors) then + raise EArgumentException.Create(string.Join('; ', Errors)); + finally + Schema.Free; + end; + Result := DoExecute(Arguments); +end; + { TMCPToolBase } constructor TMCPToolBase.Create; From 4504f89cfe40c2595a449bf1c6b9f12263a4eb01 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:00 +0200 Subject: [PATCH 32/56] feat: add the JSON Schema 2020-12 conformance fixture tool json_schema_2020_12_tool's hand-written schema exercises $schema, $defs, $anchor, $ref, allOf/anyOf and if/then/else, which the conformance suite checks are preserved verbatim in tools/list. --- src/Tools/MCPServer.Tool.ContentSamples.pas | 53 +++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas index 4f25bde..47efe50 100644 --- a/src/Tools/MCPServer.Tool.ContentSamples.pas +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -89,6 +89,17 @@ TErrorHandlingTool = class(TMCPToolBase) constructor Create; override; end; + /// A hand-written schema exercising the JSON Schema 2020-12 keywords the + /// conformance suite checks for verbatim preservation: $schema, $defs, + /// $anchor, $ref, allOf/anyOf, if/then/else and additionalProperties. + 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.'; @@ -227,6 +238,43 @@ function TProgressTool.ExecuteWithContext(const Params: TProgressToolParams; Result := Format('Completed %d steps', [Steps]); end; +{ TJsonSchema202012Tool } + +constructor TJsonSchema202012Tool.Create; +begin + inherited; + FName := 'json_schema_2020_12_tool'; + FDescription := 'Tool with JSON Schema 2020-12 features'; +end; + +function TJsonSchema202012Tool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{'+ + '"$schema":"https://json-schema.org/draft/2020-12/schema",'+ + '"type":"object",'+ + '"$defs":{"address":{"$anchor":"addressDef","type":"object",'+ + '"properties":{"street":{"type":"string"},"city":{"type":"string"}}}},'+ + '"properties":{'+ + '"name":{"type":"string"},'+ + '"address":{"$ref":"#/$defs/address"},'+ + '"contactMethod":{"type":"string","enum":["phone","email"]},'+ + '"phone":{"type":"string"},'+ + '"email":{"type":"string"}'+ + '},'+ + '"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],'+ + '"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},'+ + '"then":{"required":["phone"]},'+ + '"else":{"required":["email"]},'+ + '"additionalProperties":false'+ + '}') as TJSONObject; +end; + +function TJsonSchema202012Tool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From('ok'); +end; + initialization TMCPRegistry.RegisterTool('test_simple_text', function: IMCPTool @@ -263,5 +311,10 @@ initialization begin Result := TErrorHandlingTool.Create; end); + TMCPRegistry.RegisterTool('json_schema_2020_12_tool', + function: IMCPTool + begin + Result := TJsonSchema202012Tool.Create; + end); end. From 7a4a3c8d52da83a530274fa317a224181b8535f2 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:22 +0200 Subject: [PATCH 33/56] feat: warn when a tool's structuredContent does not match outputSchema DEBUG-only, using MCPServer.Schema.Validator; belongs with the previous commit's validator addition but was missed from it. --- src/Managers/MCPServer.ToolsManager.pas | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 71c0038..495398b 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -68,11 +68,27 @@ implementation MCPServer.Registration, MCPServer.RequestContext, MCPServer.Errors, - MCPServer.Tool.Result; + MCPServer.Tool.Result, + MCPServer.Schema.Validator; const TOOL_NAME_PATTERN = '^[A-Za-z0-9_.\-]{1,128}$'; +{$IFDEF DEBUG} +procedure WarnIfStructuredContentMismatchesSchema(const Tool: IMCPTool; const Result: TJSONObject); +begin + var OutputSchema := Tool.OutputSchema; + var StructuredContent := Result.GetValue('structuredContent'); + if not Assigned(OutputSchema) or not Assigned(StructuredContent) then + Exit; + + var Errors: TArray; + if not TMCPSchemaValidator.Validate(OutputSchema, StructuredContent, Errors) then + TLogger.Warning(Format('Tool "%s" structuredContent does not match its outputSchema: %s', + [Tool.Name, string.Join('; ', Errors)])); +end; +{$ENDIF} + { TMCPToolsManager } constructor TMCPToolsManager.Create; @@ -250,6 +266,9 @@ function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJS Exit(ErrorResult('Error executing tool: ' + E.Message, Era)); end; Result := ResultToJson(ResultValue, Era); + {$IFDEF DEBUG} + WarnIfStructuredContentMismatchesSchema(Tool, Result); + {$ENDIF} finally OwnedArguments.Free; end; From 623734e4661498c5a83bf44d21ef37fb165558b8 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:00:41 +0200 Subject: [PATCH 34/56] build: wire the prompts, templates and validator units into both projects Adds src\Prompts to the compiler's unit search path (build.bat, build-tests.bat, both .dproj files) and registers PromptsManager and CompletionManager alongside the existing managers in MCPServer.dpr, for both the HTTP and the stdio entry point. --- build-tests.bat | 2 +- build.bat | 4 ++-- src/MCPServer.dpr | 21 +++++++++++++++++++-- src/MCPServer.dproj | 9 ++++++++- tests/MCPServerTests.dpr | 13 ++++++++++++- tests/MCPServerTests.dproj | 13 ++++++++++++- 6 files changed, 54 insertions(+), 8 deletions(-) diff --git a/build-tests.bat b/build-tests.bat index 7a59de7..dbcb356 100644 --- a/build-tests.bat +++ b/build-tests.bat @@ -47,7 +47,7 @@ if not "!TAURUS_PATH!"=="" ( 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;tests!EXTRA_UNITS! +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% diff --git a/build.bat b/build.bat index b4ceb4c..eab88e3 100644 --- a/build.bat +++ b/build.bat @@ -70,10 +70,10 @@ if not "!TAURUS_PATH!"=="" ( ) if "%PLATFORM%"=="Win32" ( - !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC32! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win32\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;src\Prompts!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Win64" ( - !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr + !DCC64! -B -H -W -NSWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap -U"!DELPHI_PATH!\lib\Win64\debug";src;src\Managers;src\Server;src\Tools;src\Core;src\Protocol;src\Libraries;src\Resources;src\Prompts!EXTRA_UNITS! -Isrc;!TAURUS_PATH! -R!TAURUS_PATH! -E.\%PLATFORM%\%CONFIG% -N0.\%PLATFORM%\%CONFIG% -LE.\%PLATFORM%\%CONFIG% -LN.\%PLATFORM%\%CONFIG% -D%CONFIG% src\MCPServer.dpr goto :CheckBuildResult ) else if "%PLATFORM%"=="Linux64" ( REM Use MSBuild for Linux64 diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 99429a6..ea35a97 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -18,6 +18,8 @@ uses MCPServer.HttpHeaders in 'Server\MCPServer.HttpHeaders.pas', MCPServer.Serializer in 'Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in 'Protocol\MCPServer.Schema.Generator.pas', + MCPServer.Schema.Validator in 'Protocol\MCPServer.Schema.Validator.pas', + MCPServer.ContentBlocks in 'Protocol\MCPServer.ContentBlocks.pas', MCPServer.Logger in 'Core\MCPServer.Logger.pas', MCPServer.Settings in 'Core\MCPServer.Settings.pas', MCPServer.Registration in 'Core\MCPServer.Registration.pas', @@ -25,6 +27,7 @@ uses 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', @@ -32,6 +35,8 @@ uses 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.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', @@ -40,7 +45,9 @@ uses MCPServer.Resource.Logs in 'Resources\MCPServer.Resource.Logs.pas', MCPServer.Resource.Project in 'Resources\MCPServer.Resource.Project.pas', MCPServer.Tool.ContentSamples in 'Tools\MCPServer.Tool.ContentSamples.pas', - MCPServer.Resource.Samples in 'Resources\MCPServer.Resource.Samples.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; @@ -48,7 +55,9 @@ var ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager; ToolsManager: IMCPCapabilityManager; - ResourcesManager: IMCPCapabilityManager; + ResourcesManager: TMCPResourcesManager; + PromptsManager: TMCPPromptsManager; + CompletionManager: IMCPCapabilityManager; ShutdownEvent: TEvent; {$IFDEF MSWINDOWS} @@ -93,10 +102,14 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + PromptsManager := TMCPPromptsManager.Create; + CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); + ManagerRegistry.RegisterManager(PromptsManager); + ManagerRegistry.RegisterManager(CompletionManager); Server := TMCPIdHTTPServer.Create(nil); try @@ -136,10 +149,14 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + PromptsManager := TMCPPromptsManager.Create; + CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); + ManagerRegistry.RegisterManager(PromptsManager); + ManagerRegistry.RegisterManager(CompletionManager); StdioTransport := TMCPStdioTransport.Create(ManagerRegistry, CoreManager); try diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index 0f12633..f631626 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) @@ -135,16 +135,21 @@ + + + + + @@ -156,6 +161,8 @@ + + Base diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index 02385fa..dfecab4 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -16,16 +16,21 @@ uses MCPServer.IdHTTPServer in '..\src\Server\MCPServer.IdHTTPServer.pas', MCPServer.Serializer in '..\src\Protocol\MCPServer.Serializer.pas', MCPServer.Schema.Generator in '..\src\Protocol\MCPServer.Schema.Generator.pas', + MCPServer.Schema.Validator in '..\src\Protocol\MCPServer.Schema.Validator.pas', + MCPServer.ContentBlocks in '..\src\Protocol\MCPServer.ContentBlocks.pas', MCPServer.Logger in '..\src\Core\MCPServer.Logger.pas', MCPServer.Settings in '..\src\Core\MCPServer.Settings.pas', MCPServer.Registration in '..\src\Core\MCPServer.Registration.pas', MCPServer.ManagerRegistry in '..\src\Core\MCPServer.ManagerRegistry.pas', MCPServer.Tool.Base in '..\src\Tools\MCPServer.Tool.Base.pas', MCPServer.Resource.Base in '..\src\Resources\MCPServer.Resource.Base.pas', + MCPServer.Prompt.Base in '..\src\Prompts\MCPServer.Prompt.Base.pas', MCPServer.JsonRpcProcessor in '..\src\Protocol\MCPServer.JsonRpcProcessor.pas', MCPServer.CoreManager in '..\src\Managers\MCPServer.CoreManager.pas', MCPServer.ToolsManager in '..\src\Managers\MCPServer.ToolsManager.pas', MCPServer.ResourcesManager in '..\src\Managers\MCPServer.ResourcesManager.pas', + MCPServer.PromptsManager in '..\src\Managers\MCPServer.PromptsManager.pas', + MCPServer.CompletionManager in '..\src\Managers\MCPServer.CompletionManager.pas', MCPServer.StdioTransport in '..\src\Server\MCPServer.StdioTransport.pas', MCPServer.StdioChannel in '..\src\Server\MCPServer.StdioChannel.pas', // The built-in tools and resources register themselves in their @@ -40,6 +45,8 @@ uses MCPServer.Resource.Project in '..\src\Resources\MCPServer.Resource.Project.pas', MCPServer.Tool.ContentSamples in '..\src\Tools\MCPServer.Tool.ContentSamples.pas', MCPServer.Resource.Samples in '..\src\Resources\MCPServer.Resource.Samples.pas', + MCPServer.Prompt.SummarizeLogs in '..\src\Prompts\MCPServer.Prompt.SummarizeLogs.pas', + MCPServer.Prompt.ContentSamples in '..\src\Prompts\MCPServer.Prompt.ContentSamples.pas', MCPServer.Tool.Result in '..\src\Tools\MCPServer.Tool.Result.pas', MCPServer.Tests.Harness in 'MCPServer.Tests.Harness.pas', MCPServer.Tests.Golden in 'MCPServer.Tests.Golden.pas', @@ -61,7 +68,11 @@ uses 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.Stdio in 'MCPServer.Tests.Stdio.pas', + MCPServer.Tests.SchemaValidator in 'MCPServer.Tests.SchemaValidator.pas', + MCPServer.Tests.Prompt in 'MCPServer.Tests.Prompt.pas', + MCPServer.Tests.PromptsManager in 'MCPServer.Tests.PromptsManager.pas', + MCPServer.Tests.CompletionManager in 'MCPServer.Tests.CompletionManager.pas'; procedure RunTests; begin diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 9d8092f..de6b9ee 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -45,7 +45,7 @@ false MCPServerTests true - ..\src;..\src\Managers;..\src\Server;..\src\Tools;..\src\Core;..\src\Protocol;..\src\Libraries;..\src\Resources;$(DUnitX);$(BDS)\source\DUnitX;$(DCC_UnitSearchPath) + ..\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) @@ -80,21 +80,30 @@ + + + + + + + + + @@ -123,6 +132,8 @@ + + Base From 300b65f33fff9ad4e3e0e7dc45acbd9a2252cdb2 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:01:01 +0200 Subject: [PATCH 35/56] test: cover prompts, resource templates, completion and the validator The harness now builds prompts and completion managers alongside tools and resources, matching MCPServer.dpr. New fixtures for TMCPPromptMessages and TMCPPromptBase, TMCPPromptsManager, TMCPCompletionManager, resource template matching and reading, TMCPSchemaValidator, the new schema attributes and a hand-written tool exercising TMCPToolBase's own validation. Registration and capability-builder tests updated for the larger registry and the two new capabilities. --- tests/MCPServer.Tests.Capabilities.pas | 10 +- tests/MCPServer.Tests.CompletionManager.pas | 200 +++++++++++++ tests/MCPServer.Tests.Harness.pas | 28 +- tests/MCPServer.Tests.Prompt.pas | 209 ++++++++++++++ tests/MCPServer.Tests.PromptsManager.pas | 216 ++++++++++++++ tests/MCPServer.Tests.Registration.pas | 21 +- tests/MCPServer.Tests.ResourcesManager.pas | 115 +++++++- tests/MCPServer.Tests.Schema.pas | 75 +++++ tests/MCPServer.Tests.SchemaValidator.pas | 300 ++++++++++++++++++++ tests/MCPServer.Tests.Serializer.pas | 30 ++ tests/MCPServer.Tests.ToolResult.pas | 1 + tests/MCPServer.Tests.ToolsManager.pas | 75 ++++- 12 files changed, 1264 insertions(+), 16 deletions(-) create mode 100644 tests/MCPServer.Tests.CompletionManager.pas create mode 100644 tests/MCPServer.Tests.Prompt.pas create mode 100644 tests/MCPServer.Tests.PromptsManager.pas create mode 100644 tests/MCPServer.Tests.SchemaValidator.pas diff --git a/tests/MCPServer.Tests.Capabilities.pas b/tests/MCPServer.Tests.Capabilities.pas index 8d5d318..7d6f989 100644 --- a/tests/MCPServer.Tests.Capabilities.pas +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -9,7 +9,7 @@ interface [TestFixture] TCapabilityBuilderTests = class public - [Test] procedure Registry_YieldsToolsAndResourcesInRegistrationOrder; + [Test] procedure Registry_YieldsAllManagersInRegistrationOrder; [Test] procedure Registry_NeverEmitsLogging; [Test] procedure RegistryWithoutEnumeration_YieldsDefaults; end; @@ -43,18 +43,22 @@ function TOpaqueRegistry.GetManagerForMethod(const Method: string): IMCPCapabili { TCapabilityBuilderTests } -procedure TCapabilityBuilderTests.Registry_YieldsToolsAndResourcesInRegistrationOrder; +procedure TCapabilityBuilderTests.Registry_YieldsAllManagersInRegistrationOrder; begin var Harness := TMCPTestHarness.Create; try var Capabilities := TMCPCapabilityBuilder.Build(Harness.ManagerRegistry, TMCPProtocolEra.Modern); try - Assert.AreEqual(2, Capabilities.Count); + 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.IsFalse(Capabilities.GetValue('tools.listChanged')); Assert.IsFalse(Capabilities.GetValue('resources.subscribe')); Assert.IsFalse(Capabilities.GetValue('resources.listChanged')); + Assert.IsFalse(Capabilities.GetValue('prompts.listChanged')); + Assert.IsTrue(Capabilities.GetValue('completions') is TJSONObject); finally Capabilities.Free; end; diff --git a/tests/MCPServer.Tests.CompletionManager.pas b/tests/MCPServer.Tests.CompletionManager.pas new file mode 100644 index 0000000..b83c24f --- /dev/null +++ b/tests/MCPServer.Tests.CompletionManager.pas @@ -0,0 +1,200 @@ +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 MissingArgument_IsInvalidParams; + [Test] procedure UnknownRefType_IsInvalidParams; + [Test] procedure CapabilitiesInclude_Completions; + end; + +implementation + +uses + System.SysUtils, + MCPServer.Errors, + MCPServer.CompletionManager; + +{ TCompletionManagerTests } + +procedure TCompletionManagerTests.Setup; +begin + FHarness := TMCPTestHarness.Create; +end; + +procedure TCompletionManagerTests.TearDown; +begin + FHarness.Free; +end; + +procedure TCompletionManagerTests.RefPrompt_KnownArgument_ReturnsFilteredValues; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt","name":"summarize_logs"},"argument":{"name":"level","value":"IN"}}') as TJSONObject; + try + var Json := Manager.Complete(Params, TMCPProtocolEra.Modern).AsType; + try + var Values := Json.FindValue('completion.values') as TJSONArray; + for var Value in Values do + Assert.IsTrue(Value.Value.ToUpper.StartsWith('IN'), 'every suggestion starts with the typed prefix'); + Assert.IsFalse(Json.GetValue('completion.hasMore')); + finally + Json.Free; + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefPrompt_UnknownPrompt_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt","name":"nope"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefPrompt_MissingRefName_IsInvalidParams; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/prompt"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefResource_Template_Completes; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/resource","uri":"logs://{level}"},"argument":{"name":"level","value":""}}') as TJSONObject; + try + var Json := Manager.Complete(Params, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNotNull(Json.FindValue('completion.values')); + finally + Json.Free; + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.RefResource_UnknownUri_IsNotFound; +begin + var Manager := TMCPCompletionManager.Create(FHarness.PromptsManager, FHarness.ResourcesManager); + var Params := TJSONObject.ParseJSONValue( + '{"ref":{"type":"ref/resource","uri":"nope://missing"},"argument":{"name":"x","value":""}}') as TJSONObject; + try + try + Manager.Complete(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + Manager.Free; + end; +end; + +procedure TCompletionManagerTests.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; + +initialization + TDUnitX.RegisterTestFixture(TCompletionManagerTests); + +end. diff --git a/tests/MCPServer.Tests.Harness.pas b/tests/MCPServer.Tests.Harness.pas index 37de683..292e4e0 100644 --- a/tests/MCPServer.Tests.Harness.pas +++ b/tests/MCPServer.Tests.Harness.pas @@ -6,17 +6,24 @@ interface System.SysUtils, MCPServer.Types, MCPServer.Settings, + MCPServer.ToolsManager, + MCPServer.ResourcesManager, + MCPServer.PromptsManager, MCPServer.JsonRpcProcessor; type - /// Builds the same manager registry as MCPServer.dpr (core, tools and - /// resources managers on top of the built-in registrations) and drives the - /// transport-independent JSON-RPC processor directly. + /// Builds the same manager registry as MCPServer.dpr (core, tools, + /// resources, prompts and completion managers on top of the built-in + /// registrations) and drives the transport-independent JSON-RPC processor + /// directly. TMCPTestHarness = class private FSettings: TMCPSettings; FManagerRegistry: IMCPManagerRegistry; FCoreManager: IMCPCapabilityManager; + FToolsManager: TMCPToolsManager; + FResourcesManager: TMCPResourcesManager; + FPromptsManager: TMCPPromptsManager; FProcessor: TMCPJsonRpcProcessor; public constructor Create; @@ -29,6 +36,9 @@ TMCPTestHarness = class 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; end; implementation @@ -36,8 +46,7 @@ implementation uses MCPServer.ManagerRegistry, MCPServer.CoreManager, - MCPServer.ToolsManager, - MCPServer.ResourcesManager; + MCPServer.CompletionManager; { TMCPTestHarness } @@ -51,10 +60,15 @@ constructor TMCPTestHarness.Create; FManagerRegistry := TMCPManagerRegistry.Create; FCoreManager := TMCPCoreManager.Create(FSettings); + FToolsManager := TMCPToolsManager.Create; + FResourcesManager := TMCPResourcesManager.Create; + FPromptsManager := TMCPPromptsManager.Create; FManagerRegistry.RegisterManager(FCoreManager); - FManagerRegistry.RegisterManager(TMCPToolsManager.Create); - FManagerRegistry.RegisterManager(TMCPResourcesManager.Create); + FManagerRegistry.RegisterManager(FToolsManager); + FManagerRegistry.RegisterManager(FResourcesManager); + FManagerRegistry.RegisterManager(FPromptsManager); + FManagerRegistry.RegisterManager(TMCPCompletionManager.Create(FPromptsManager, FResourcesManager)); FProcessor := TMCPJsonRpcProcessor.Create(FManagerRegistry); end; diff --git a/tests/MCPServer.Tests.Prompt.pas b/tests/MCPServer.Tests.Prompt.pas new file mode 100644 index 0000000..d1bc439 --- /dev/null +++ b/tests/MCPServer.Tests.Prompt.pas @@ -0,0 +1,209 @@ +unit MCPServer.Tests.Prompt; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.JSON, + System.Generics.Collections, + MCPServer.Types, + MCPServer.Prompt.Base; + +type + TGreetingParams = class + private + FName: string; + FTone: string; + public + [SchemaDescription('Who to greet')] + property Name: string read FName write FName; + [Optional] + [SchemaDescription('Tone of voice')] + property Tone: string read FTone write FTone; + end; + + TGreetingPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TGreetingParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + [TestFixture] + TPromptMessagesTests = class + public + [Test] procedure AddText_ProducesOneMessage; + [Test] procedure ContentIsASingleObject_NotAnArray; + [Test] procedure Image_Audio_ResourceLink_Embedded_Blocks; + [Test] procedure WithAnnotations_AttachesToLastMessage; + [Test] procedure ToJson_ReturnsAClone; + end; + + [TestFixture] + TPromptBaseTests = class + public + [Test] procedure Arguments_DerivedFromRttiWithDescriptionAndRequired; + [Test] procedure Get_BuildsMessages_AndReturnsDescription; + [Test] procedure Get_MissingRequiredArgument_Raises; + end; + +implementation + +{ TGreetingPrompt } + +constructor TGreetingPrompt.Create; +begin + inherited; + FName := 'greeting'; + FDescription := 'Greets someone'; +end; + +function TGreetingPrompt.ExecuteWithParams(const Params: TGreetingParams; Messages: TMCPPromptMessages): string; +begin + var Tone := Params.Tone; + if Tone = '' then + Tone := 'friendly'; + Messages.AddText('user', Format('Write a %s greeting for %s.', [Tone, Params.Name])); + Result := 'Greeting request'; +end; + +{ TPromptMessagesTests } + +procedure TPromptMessagesTests.AddText_ProducesOneMessage; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hello'); + var Json := Messages.ToJson; + try + Assert.AreEqual(1, Json.Count); + Assert.AreEqual('user', Json.Items[0].GetValue('role')); + Assert.AreEqual('text', Json.Items[0].GetValue('content.type')); + Assert.AreEqual('hello', Json.Items[0].GetValue('content.text')); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.ContentIsASingleObject_NotAnArray; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hi'); + var Json := Messages.ToJson; + try + Assert.IsTrue((Json.Items[0] as TJSONObject).GetValue('content') is TJSONObject, + 'prompts/get content is one object per message, not an array'); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.Image_Audio_ResourceLink_Embedded_Blocks; +begin + var Messages := TMCPPromptMessages.Create + .AddImage('user', TEncoding.UTF8.GetBytes('png'), 'image/png') + .AddAudio('assistant', 'AAAA', 'audio/wav') + .AddResourceLink('user', 'file:///a.txt', 'a.txt', 'A file', 'text/plain') + .AddEmbeddedText('user', 'test://x', 'text/plain', 'body'); + var Json := Messages.ToJson; + try + Assert.AreEqual(4, Json.Count); + Assert.AreEqual('image', Json.Items[0].GetValue('content.type')); + Assert.AreEqual('cG5n', Json.Items[0].GetValue('content.data')); + Assert.AreEqual('assistant', Json.Items[1].GetValue('role')); + Assert.AreEqual('audio', Json.Items[1].GetValue('content.type')); + Assert.AreEqual('resource_link', Json.Items[2].GetValue('content.type')); + Assert.AreEqual('A file', Json.Items[2].GetValue('content.description')); + Assert.AreEqual('resource', Json.Items[3].GetValue('content.type')); + Assert.AreEqual('body', Json.Items[3].GetValue('content.resource.text')); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.WithAnnotations_AttachesToLastMessage; +begin + var Annotations := TJSONObject.Create; + Annotations.AddPair('priority', TJSONNumber.Create(0.5)); + var Messages := TMCPPromptMessages.Create.AddText('user', 'first').AddText('user', 'second'); + Messages.WithAnnotations(Annotations); + var Json := Messages.ToJson; + try + Assert.IsNull(Json.Items[0].FindValue('content.annotations')); + Assert.AreEqual(0.5, Json.Items[1].GetValue('content.annotations.priority'), 0.0001); + finally + Json.Free; + Messages.Free; + end; +end; + +procedure TPromptMessagesTests.ToJson_ReturnsAClone; +begin + var Messages := TMCPPromptMessages.Create.AddText('user', 'hi'); + var First := Messages.ToJson; + var Second := Messages.ToJson; + try + Assert.AreNotSame(First, Second); + finally + First.Free; + Second.Free; + Messages.Free; + end; +end; + +{ TPromptBaseTests } + +procedure TPromptBaseTests.Arguments_DerivedFromRttiWithDescriptionAndRequired; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Args := Prompt.Arguments; + Assert.AreEqual(2, Integer(Length(Args))); + var NameArg := Args[0]; + var ToneArg := Args[1]; + Assert.AreEqual('name', NameArg.Name); + Assert.AreEqual('Who to greet', NameArg.Description); + Assert.IsTrue(NameArg.Required); + Assert.AreEqual('tone', ToneArg.Name); + Assert.IsFalse(ToneArg.Required); +end; + +procedure TPromptBaseTests.Get_BuildsMessages_AndReturnsDescription; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Arguments := TJSONObject.ParseJSONValue('{"name":"Ada"}') as TJSONObject; + var Messages := TMCPPromptMessages.Create; + try + var Description := Prompt.Get(Arguments, Messages); + Assert.AreEqual('Greeting request', Description); + var Json := Messages.ToJson; + try + Assert.AreEqual('Write a friendly greeting for Ada.', Json.Items[0].GetValue('content.text')); + finally + Json.Free; + end; + finally + Arguments.Free; + Messages.Free; + end; +end; + +procedure TPromptBaseTests.Get_MissingRequiredArgument_Raises; +begin + var Prompt: IMCPPrompt := TGreetingPrompt.Create; + var Arguments := TJSONObject.Create; + var Messages := TMCPPromptMessages.Create; + try + var Call: TProc := procedure begin Prompt.Get(Arguments, Messages) end; + Assert.WillRaise(Call, EArgumentException); + finally + Arguments.Free; + Messages.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TPromptMessagesTests); + TDUnitX.RegisterTestFixture(TPromptBaseTests); + +end. diff --git a/tests/MCPServer.Tests.PromptsManager.pas b/tests/MCPServer.Tests.PromptsManager.pas new file mode 100644 index 0000000..ec57693 --- /dev/null +++ b/tests/MCPServer.Tests.PromptsManager.pas @@ -0,0 +1,216 @@ +unit MCPServer.Tests.PromptsManager; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.Prompt.Base, + MCPServer.PromptsManager; + +type + TNoteParams = class + private + FText: string; + public + [SchemaDescription('The note text')] + property Text: string read FText write FText; + end; + + TNotePrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoteParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + [TestFixture] + TPromptsManagerTests = class + private + FManager: TMCPPromptsManager; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure List_IsInRegistrationOrder_WithArguments; + [Test] procedure List_CacheHints_ModernOnly; + [Test] procedure List_Cursor_IsInvalidParams; + [Test] procedure Get_MissingName_IsInvalidParams; + [Test] procedure Get_UnknownPrompt_IsInvalidParams_WithName; + [Test] procedure Get_MissingRequiredArgument_IsInvalidParams; + [Test] procedure Get_ReturnsDescriptionAndMessages; + [Test] procedure Get_ResultHasNoCacheHints; + end; + +implementation + +uses + System.Rtti, + System.SysUtils, + System.Generics.Collections, + MCPServer.Errors; + +{ TNotePrompt } + +constructor TNotePrompt.Create; +begin + inherited; + FName := 'note'; + FDescription := 'Wraps a note'; +end; + +function TNotePrompt.ExecuteWithParams(const Params: TNoteParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', Params.Text); + Result := 'Note prompt'; +end; + +{ TPromptsManagerTests } + +procedure TPromptsManagerTests.Setup; +begin + FManager := TMCPPromptsManager.Create; + FManager.AddPrompt(TNotePrompt.Create); +end; + +procedure TPromptsManagerTests.TearDown; +begin + FManager.Free; +end; + +procedure TPromptsManagerTests.List_IsInRegistrationOrder_WithArguments; +begin + var Json := FManager.ListPrompts(nil, TMCPProtocolEra.Legacy).AsType; + try + var Prompts := Json.GetValue('prompts') as TJSONArray; + Assert.AreEqual('summarize_logs', Json.GetValue('prompts[0].name'), 'registration order'); + Assert.AreEqual('note', Prompts.Items[Prompts.Count - 1].GetValue('name')); + var NoteJson := Prompts.Items[Prompts.Count - 1] as TJSONObject; + Assert.AreEqual('text', NoteJson.GetValue('arguments[0].name')); + Assert.IsTrue(NoteJson.GetValue('arguments[0].required')); + finally + Json.Free; + end; +end; + +procedure TPromptsManagerTests.List_CacheHints_ModernOnly; +begin + FManager.ListTtlMs := 60000; + FManager.ListCacheScope := MCP_CACHE_SCOPE_PUBLIC; + + var Legacy := FManager.ListPrompts(nil, TMCPProtocolEra.Legacy).AsType; + var Modern := FManager.ListPrompts(nil, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Legacy.GetValue('ttlMs')); + Assert.AreEqual(60000, Modern.GetValue('ttlMs')); + Assert.AreEqual('public', Modern.GetValue('cacheScope')); + finally + Legacy.Free; + Modern.Free; + end; +end; + +procedure TPromptsManagerTests.List_Cursor_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"cursor":"abc"}') as TJSONObject; + try + try + FManager.ListPrompts(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_MissingName_IsInvalidParams; +begin + try + FManager.GetPrompt(nil, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + +procedure TPromptsManagerTests.Get_UnknownPrompt_IsInvalidParams_WithName; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"nope"}') as TJSONObject; + try + try + FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.AreEqual('nope', (E.Data as TJSONObject).GetValue('name')); + end; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_MissingRequiredArgument_IsInvalidParams; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note"}') as TJSONObject; + try + try + FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType.Free; + Assert.Fail('expected -32602'); + except + on E: EMCPError do + begin + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + Assert.IsTrue(E.Message.Contains('Missing required parameter "text"')); + end; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_ReturnsDescriptionAndMessages; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note","arguments":{"text":"hi"}}') as TJSONObject; + try + var Json := FManager.GetPrompt(Params, TMCPProtocolEra.Legacy).AsType; + try + Assert.AreEqual('Note prompt', Json.GetValue('description')); + Assert.AreEqual('hi', Json.GetValue('messages[0].content.text')); + finally + Json.Free; + end; + finally + Params.Free; + end; +end; + +procedure TPromptsManagerTests.Get_ResultHasNoCacheHints; +begin + var Params := TJSONObject.ParseJSONValue('{"name":"note","arguments":{"text":"hi"}}') as TJSONObject; + try + var Json := FManager.GetPrompt(Params, TMCPProtocolEra.Modern).AsType; + try + Assert.IsNull(Json.GetValue('ttlMs'), 'prompts/get is not a cacheable result'); + Assert.IsNull(Json.GetValue('cacheScope')); + finally + Json.Free; + end; + finally + Params.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TPromptsManagerTests); + +end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index 12fee0d..ef48c15 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -13,6 +13,8 @@ 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; @@ -34,7 +36,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(11, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(12, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; @@ -46,6 +48,23 @@ procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; Assert.AreEqual(6, Integer(Length(TMCPRegistry.GetResourceURIs))); end; +procedure TRegistryTests.BuiltInPrompts_AreRegisteredFromInitialization; +begin + Assert.IsTrue(TMCPRegistry.HasPrompt('summarize_logs')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_simple_prompt')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_arguments')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_embedded_resource')); + Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_image')); + Assert.AreEqual(5, Integer(Length(TMCPRegistry.GetPromptNames))); +end; + +procedure TRegistryTests.BuiltInResourceTemplates_AreRegisteredFromInitialization; +begin + Assert.AreEqual(2, Integer(Length(TMCPRegistry.GetResourceTemplateURIs))); + Assert.AreEqual('logs://{level}', TMCPRegistry.GetResourceTemplateURIs[0]); + Assert.AreEqual('test://template/{id}/data', TMCPRegistry.GetResourceTemplateURIs[1]); +end; + procedure TRegistryTests.ServerStatus_IsRegisteredByDefault; begin // Registered by the initialization section of MCPServer.Resource.Server. diff --git a/tests/MCPServer.Tests.ResourcesManager.pas b/tests/MCPServer.Tests.ResourcesManager.pas index 2875d58..c4c9986 100644 --- a/tests/MCPServer.Tests.ResourcesManager.pas +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -21,6 +21,31 @@ TFailingResource = class(TMCPResourceBase) constructor Create; override; end; + TEchoTemplateData = class + private + FValue: string; + public + property Value: string read FValue write FValue; + end; + + /// A resource matched by TEchoTemplate; echoes the captured variable. + TEchoResource = class(TMCPResourceBase) + private + FValue: string; + protected + function GetResourceData: TEchoTemplateData; override; + public + constructor CreateForValue(const AUri, AValue: string); + end; + + /// echo://{value}, used to test template matching independent of the + /// server's own logs://{level} template. + TEchoTemplate = class(TMCPResourceTemplateBase) + public + constructor Create; override; + function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; override; + end; + [TestFixture] TResourcesManagerTests = class private @@ -41,13 +66,17 @@ TResourcesManagerTests = class [Test] procedure Read_CacheHints_ModernOnly_FromResource; [Test] procedure List_HasMetadata_AndOmitsEmptyFields; [Test] procedure List_CacheHints_ModernOnly; - [Test] procedure Templates_AreEmpty_WithHints; + [Test] procedure Templates_ListsRegisteredTemplates_WithHints; + [Test] procedure Templates_Cursor_IsInvalidParams; + [Test] procedure Read_ViaTemplate_ResolvesWithActualUri; + [Test] procedure Read_TemplateMismatch_IsNotFound; end; implementation uses System.SysUtils, + System.Generics.Collections, MCPServer.Errors; { TFailingResource } @@ -65,12 +94,46 @@ function TFailingResource.GetResourceData: TFailingData; raise Exception.Create('disk on fire'); end; +{ TEchoResource } + +constructor TEchoResource.CreateForValue(const AUri, AValue: string); +begin + inherited Create; + FURI := AUri; + FName := 'Echo'; + FMimeType := 'application/json'; + FValue := AValue; +end; + +function TEchoResource.GetResourceData: TEchoTemplateData; +begin + Result := TEchoTemplateData.Create; + Result.Value := FValue; +end; + +{ TEchoTemplate } + +constructor TEchoTemplate.Create; +begin + inherited; + FUriTemplate := 'echo://{value}'; + FName := 'Echo template'; + FDescription := 'Echoes the captured value'; + FMimeType := 'application/json'; +end; + +function TEchoTemplate.CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; +begin + Result := TEchoResource.CreateForValue(URI, Vars['value']); +end; + { TResourcesManagerTests } procedure TResourcesManagerTests.Setup; begin FManager := TMCPResourcesManager.Create; FManager.AddResource(TFailingResource.Create); + FManager.AddResourceTemplate(TEchoTemplate.Create); end; procedure TResourcesManagerTests.TearDown; @@ -221,17 +284,63 @@ procedure TResourcesManagerTests.List_CacheHints_ModernOnly; end; end; -procedure TResourcesManagerTests.Templates_AreEmpty_WithHints; +procedure TResourcesManagerTests.Templates_ListsRegisteredTemplates_WithHints; begin var Modern := FManager.ListResourceTemplates(nil, TMCPProtocolEra.Modern).AsType; try - Assert.AreEqual(0, (Modern.GetValue('resourceTemplates') as TJSONArray).Count); + 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_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; + initialization TDUnitX.RegisterTestFixture(TResourcesManagerTests); diff --git a/tests/MCPServer.Tests.Schema.pas b/tests/MCPServer.Tests.Schema.pas index b0f39ee..c3ffa91 100644 --- a/tests/MCPServer.Tests.Schema.pas +++ b/tests/MCPServer.Tests.Schema.pas @@ -34,6 +34,7 @@ TSchemaParams = class FOrigin: TPoint; FCode: string; FScore: Integer; + FTag: string; public [SchemaDescription('How many')] [SchemaMinimum(1)] @@ -54,11 +55,33 @@ TSchemaParams = class 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 @@ -71,6 +94,10 @@ TSchemaGeneratorTests = class [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 @@ -195,6 +222,54 @@ procedure TSchemaGeneratorTests.NoParameters_ForbidsAdditionalProperties; 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; + initialization TDUnitX.RegisterTestFixture(TSchemaGeneratorTests); diff --git a/tests/MCPServer.Tests.SchemaValidator.pas b/tests/MCPServer.Tests.SchemaValidator.pas new file mode 100644 index 0000000..786d33a --- /dev/null +++ b/tests/MCPServer.Tests.SchemaValidator.pas @@ -0,0 +1,300 @@ +unit MCPServer.Tests.SchemaValidator; + +interface + +uses + DUnitX.TestFramework; + +type + [TestFixture] + TSchemaValidatorTests = class + public + [Test] procedure Type_Mismatch_Fails; + [Test] procedure Type_Array_AcceptsEitherAlternative; + [Test] procedure Integer_RejectsFraction; + [Test] procedure Required_MissingProperty_Fails; + [Test] procedure Properties_RecurseIntoNestedObject; + [Test] procedure AdditionalProperties_False_RejectsExtraKey; + [Test] procedure Items_RecurseIntoArrayElements; + [Test] procedure MinimumMaximum_OutOfRange_Fails; + [Test] procedure MinLengthMaxLengthPattern_Fail; + [Test] procedure Enum_RejectsValueNotListed; + [Test] procedure Const_RejectsDifferentValue; + [Test] procedure Ref_ResolvesSameDocumentDefs; + [Test] procedure Ref_UnsupportedShape_IsAnError; + [Test] procedure Valid_Instance_HasNoErrors; + [Test] procedure ExcessiveNesting_IsAnError; + end; + +implementation + +uses + System.SysUtils, + System.JSON, + MCPServer.Schema.Validator; + +{ TSchemaValidatorTests } + +procedure TSchemaValidatorTests.Type_Mismatch_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"string"}') as TJSONObject; + var Instance := TJSONNumber.Create(1); + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.AreEqual(1, Integer(Length(Errors))); + Assert.IsTrue(Errors[0].Contains('expected string')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Type_Array_AcceptsEitherAlternative; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":["string","null"]}') as TJSONObject; + var TextInstance := TJSONString.Create('x'); + var NullInstance := TJSONNull.Create; + var NumberInstance := TJSONNumber.Create(1); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, TextInstance, Errors)); + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, NullInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, NumberInstance, Errors)); + finally + Schema.Free; + TextInstance.Free; + NullInstance.Free; + NumberInstance.Free; + end; +end; + +procedure TSchemaValidatorTests.Integer_RejectsFraction; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"integer"}') as TJSONObject; + var WholeInstance := TJSONNumber.Create(3); + var FractionInstance := TJSONNumber.Create(3.5); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, WholeInstance, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, FractionInstance, Errors)); + finally + Schema.Free; + WholeInstance.Free; + FractionInstance.Free; + end; +end; + +procedure TSchemaValidatorTests.Required_MissingProperty_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"object","required":["a"]}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('missing required property "a"')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Properties_RecurseIntoNestedObject; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"child":{"type":"object","required":["x"]}}}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"child":{}}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('value.child')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.AdditionalProperties_False_RejectsExtraKey; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"a":{"type":"string"}},"additionalProperties":false}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"a":"x","b":1}') as TJSONObject; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('unexpected property "b"')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Items_RecurseIntoArrayElements; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"array","items":{"type":"integer"}}') as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('[1,2,"x"]') as TJSONArray; + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('value[2]')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.MinimumMaximum_OutOfRange_Fails; +begin + var Schema := TJSONObject.ParseJSONValue('{"type":"number","minimum":0,"maximum":10}') as TJSONObject; + var InRange := TJSONNumber.Create(5); + var BelowRange := TJSONNumber.Create(-1); + var AboveRange := TJSONNumber.Create(11); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, InRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, BelowRange, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, AboveRange, Errors)); + finally + Schema.Free; + InRange.Free; + BelowRange.Free; + AboveRange.Free; + end; +end; + +procedure TSchemaValidatorTests.MinLengthMaxLengthPattern_Fail; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"string","minLength":2,"maxLength":4,"pattern":"^[a-z]+$"}') as TJSONObject; + var Ok := TJSONString.Create('abc'); + var TooShort := TJSONString.Create('a'); + var TooLong := TJSONString.Create('abcde'); + var WrongPattern := TJSONString.Create('AB'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Ok, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, TooShort, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, TooLong, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, WrongPattern, Errors)); + finally + Schema.Free; + Ok.Free; + TooShort.Free; + TooLong.Free; + WrongPattern.Free; + end; +end; + +procedure TSchemaValidatorTests.Enum_RejectsValueNotListed; +begin + var Schema := TJSONObject.ParseJSONValue('{"enum":["a","b"]}') as TJSONObject; + var Allowed := TJSONString.Create('a'); + var NotAllowed := TJSONString.Create('c'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Allowed, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, NotAllowed, Errors)); + finally + Schema.Free; + Allowed.Free; + NotAllowed.Free; + end; +end; + +procedure TSchemaValidatorTests.Const_RejectsDifferentValue; +begin + var Schema := TJSONObject.ParseJSONValue('{"const":"fixed"}') as TJSONObject; + var SameValue := TJSONString.Create('fixed'); + var DifferentValue := TJSONString.Create('other'); + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, SameValue, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, DifferentValue, Errors)); + finally + Schema.Free; + SameValue.Free; + DifferentValue.Free; + end; +end; + +procedure TSchemaValidatorTests.Ref_ResolvesSameDocumentDefs; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","properties":{"a":{"$ref":"#/$defs/Positive"}},' + + '"$defs":{"Positive":{"type":"integer","minimum":1}}}') as TJSONObject; + var Valid := TJSONObject.ParseJSONValue('{"a":5}') as TJSONObject; + var Invalid := TJSONObject.ParseJSONValue('{"a":0}') as TJSONObject; + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Valid, Errors)); + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Invalid, Errors)); + finally + Schema.Free; + Valid.Free; + Invalid.Free; + end; +end; + +procedure TSchemaValidatorTests.Ref_UnsupportedShape_IsAnError; +begin + var Schema := TJSONObject.ParseJSONValue('{"$ref":"https://example.com/schema.json"}') as TJSONObject; + var Instance := TJSONString.Create('x'); + try + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[0].Contains('unsupported $ref')); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.Valid_Instance_HasNoErrors; +begin + var Schema := TJSONObject.ParseJSONValue( + '{"type":"object","required":["name"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}}}') + as TJSONObject; + var Instance := TJSONObject.ParseJSONValue('{"name":"a","age":3}') as TJSONObject; + try + var Errors: TArray; + Assert.IsTrue(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.AreEqual(0, Integer(Length(Errors))); + finally + Schema.Free; + Instance.Free; + end; +end; + +procedure TSchemaValidatorTests.ExcessiveNesting_IsAnError; +begin + var Schema := TJSONObject.Create; + var Instance := TJSONObject.Create; + try + var CurrentSchema := Schema; + var CurrentInstance := Instance; + for var I := 1 to TMCPSchemaValidator.MAX_DEPTH + 5 do + begin + CurrentSchema.AddPair('type', 'object'); + var ChildSchema := TJSONObject.Create; + var Properties := TJSONObject.Create; + Properties.AddPair('child', ChildSchema); + CurrentSchema.AddPair('properties', Properties); + var ChildInstance := TJSONObject.Create; + CurrentInstance.AddPair('child', ChildInstance); + CurrentSchema := ChildSchema; + CurrentInstance := ChildInstance; + end; + + var Errors: TArray; + Assert.IsFalse(TMCPSchemaValidator.Validate(Schema, Instance, Errors)); + Assert.IsTrue(Errors[Length(Errors) - 1].Contains('nested too deeply')); + finally + Schema.Free; + Instance.Free; + end; +end; + +initialization + TDUnitX.RegisterTestFixture(TSchemaValidatorTests); + +end. diff --git a/tests/MCPServer.Tests.Serializer.pas b/tests/MCPServer.Tests.Serializer.pas index 5b25a3f..33484c8 100644 --- a/tests/MCPServer.Tests.Serializer.pas +++ b/tests/MCPServer.Tests.Serializer.pas @@ -42,6 +42,14 @@ TSampleParams = class [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; @@ -74,6 +82,7 @@ TSerializerTests = class [Test] procedure Enum_ByName_AndInvalidRaises; [Test] procedure Serialize_Enum_Set_Array_DateTime; [Test] procedure Serialize_NilObject_IsNull; + [Test] procedure SchemaName_UsedForDeserializeAndSerialize; end; implementation @@ -226,6 +235,27 @@ procedure TSerializerTests.Serialize_NilObject_IsNull; 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; + initialization TDUnitX.RegisterTestFixture(TSerializerTests); diff --git a/tests/MCPServer.Tests.ToolResult.pas b/tests/MCPServer.Tests.ToolResult.pas index 67366e0..84b56e4 100644 --- a/tests/MCPServer.Tests.ToolResult.pas +++ b/tests/MCPServer.Tests.ToolResult.pas @@ -25,6 +25,7 @@ implementation System.SysUtils, System.JSON, MCPServer.Types, + MCPServer.ContentBlocks, MCPServer.Tool.Result; { TToolResultTests } diff --git a/tests/MCPServer.Tests.ToolsManager.pas b/tests/MCPServer.Tests.ToolsManager.pas index ebf608c..ea9d371 100644 --- a/tests/MCPServer.Tests.ToolsManager.pas +++ b/tests/MCPServer.Tests.ToolsManager.pas @@ -33,6 +33,16 @@ TDoublingTool = class(TMCPToolBase) constructor Create; override; end; + /// A hand-written schema, to exercise TMCPToolBase's own validation + /// (nothing goes through TMCPSerializer for this tool). + THandWrittenTool = class(TMCPToolBase) + protected + function BuildSchema: TJSONObject; override; + function DoExecute(const Arguments: TJSONObject): TValue; override; + public + constructor Create; override; + end; + [TestFixture] TToolsManagerTests = class private @@ -57,12 +67,16 @@ TToolsManagerTests = class [Test] procedure List_IsInRegistrationOrder_WithAnnotations; [Test] procedure List_CacheHints_ModernOnly; [Test] procedure List_Cursor_IsInvalidParams; + [Test] procedure HandWrittenTool_ValidArguments_Runs; + [Test] procedure HandWrittenTool_MissingRequired_IsErrorResult; + [Test] procedure HandWrittenTool_WrongType_IsErrorResult; end; implementation uses System.SysUtils, + System.Generics.Collections, MCPServer.Errors; { TDoublingTool } @@ -80,12 +94,33 @@ function TDoublingTool.ExecuteWithParams(const Params: TStructuredParams): TStru Result.Doubled := Params.Value * 2; end; +{ THandWrittenTool } + +constructor THandWrittenTool.Create; +begin + inherited; + FName := 'hand_written'; + FDescription := 'A tool with a hand-written schema'; +end; + +function THandWrittenTool.BuildSchema: TJSONObject; +begin + Result := TJSONObject.ParseJSONValue( + '{"type":"object","required":["count"],"properties":{"count":{"type":"integer"}}}') as TJSONObject; +end; + +function THandWrittenTool.DoExecute(const Arguments: TJSONObject): TValue; +begin + Result := TValue.From('count was ' + Arguments.GetValue('count').ToString); +end; + { TToolsManagerTests } procedure TToolsManagerTests.Setup; begin FManager := TMCPToolsManager.Create; FManager.AddTool(TDoublingTool.Create); + FManager.AddTool(THandWrittenTool.Create); end; procedure TToolsManagerTests.TearDown; @@ -216,13 +251,16 @@ procedure TToolsManagerTests.List_IsInRegistrationOrder_WithAnnotations; try var Tools := Json.GetValue('tools') as TJSONArray; Assert.AreEqual('echo', Json.GetValue('tools[0].name'), 'registration order starts with echo'); - Assert.AreEqual('doubling', Tools.Items[Tools.Count - 1].GetValue('name'), 'the added tool comes last'); + 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 - 1).ToString + '].inputSchema.properties.value.type')); + Assert.AreEqual('integer', + Json.GetValue('tools[' + (Tools.Count - 2).ToString + '].inputSchema.properties.value.type')); finally Json.Free; end; @@ -261,6 +299,39 @@ procedure TToolsManagerTests.List_Cursor_IsInvalidParams; 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; + initialization TDUnitX.RegisterTestFixture(TToolsManagerTests); From 68363e14a8dfb963fb92f299b75cf0ae4e5c11b0 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:01:01 +0200 Subject: [PATCH 36/56] test: stop using prompts/list as the unknown-method example prompts/list is a real method now; the unknown-method fixtures (unit tests, golden cases and the HTTP capture script) use a name that will never be implemented instead. --- scripts/capture-http-goldens.ps1 | 4 ++-- tests/MCPServer.Tests.Http.pas | 6 +++--- tests/MCPServer.Tests.Processor.pas | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/scripts/capture-http-goldens.ps1 b/scripts/capture-http-goldens.ps1 index 315b920..812573c 100644 --- a/scripts/capture-http-goldens.ps1 +++ b/scripts/capture-http-goldens.ps1 @@ -121,7 +121,7 @@ try { @{ Name = 'modern-discover'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: server/discover'); Body = '{"jsonrpc":"2.0","id":"d1","method":"server/discover","params":{' + $modernMeta + '}}' } @{ Name = 'modern-tools-list'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":20,"method":"tools/list","params":{' + $modernMeta + '}}' } @{ Name = 'modern-tools-call-name-base64'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call', 'Mcp-Name: =?base64?ZWNobw==?='); Body = '{"jsonrpc":"2.0","id":25,"method":"tools/call","params":{"name":"echo","arguments":{"message":"hello modern"},' + $modernMeta + '}}' } - @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: prompts/list'); Body = '{"jsonrpc":"2.0","id":21,"method":"prompts/list","params":{' + $modernMeta + '}}' } + @{ Name = 'modern-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: totally/bogus/method'); Body = '{"jsonrpc":"2.0","id":21,"method":"totally/bogus/method","params":{' + $modernMeta + '}}' } @{ Name = 'modern-missing-version-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, 'Mcp-Method: tools/list'); Body = '{"jsonrpc":"2.0","id":22,"method":"tools/list","params":{' + $modernMeta + '}}' } @{ Name = 'modern-missing-method-header'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader); Body = '{"jsonrpc":"2.0","id":26,"method":"tools/list","params":{' + $modernMeta + '}}' } @{ Name = 'modern-method-header-mismatch'; Method = 'POST'; Headers = @($jsonType, $jsonAccept, $modernHeader, 'Mcp-Method: tools/call'); Body = '{"jsonrpc":"2.0","id":27,"method":"tools/list","params":{' + $modernMeta + '}}' } @@ -140,7 +140,7 @@ try { @{ Name = 'post-client-response'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":1,"result":{}}' } @{ Name = 'post-batch-notifications'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","method":"notifications/initialized"}]' } @{ Name = 'post-batch-requests'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '[{"jsonrpc":"2.0","id":6,"method":"ping"}]' } - @{ Name = 'post-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":7,"method":"prompts/list"}' } + @{ Name = 'post-unknown-method'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":7,"method":"totally/bogus/method"}' } @{ Name = 'post-parse-error'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '{"jsonrpc":"2.0","id":8,"method":' } @{ Name = 'post-empty-body'; Method = 'POST'; Headers = @($jsonType, $jsonAccept); Body = '' } @{ Name = 'post-no-accept-header'; Method = 'POST'; Headers = @($jsonType); Body = '{"jsonrpc":"2.0","id":9,"method":"ping"}' } diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index 2927189..c7ec2c7 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -283,15 +283,15 @@ procedure THttpTransportTests.Cors_PreflightReflectsRequestedHeaders; procedure THttpTransportTests.Legacy_UnknownMethod_Is200; begin - var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"prompts/list"}', ['MCP-Protocol-Version: 2025-06-18']); + 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":"prompts/list","params":{' + MODERN_META + '}}', - [MODERN_VERSION_HEADER, 'Mcp-Method: prompts/list']); + 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 diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas index 6af9cac..74e38d4 100644 --- a/tests/MCPServer.Tests.Processor.pas +++ b/tests/MCPServer.Tests.Processor.pas @@ -126,7 +126,7 @@ function TProcessorTests.Parse(const Body: string): TJSONObject; procedure TProcessorTests.Modern_UnknownMethod_Is404; begin - var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"prompts/list","params":{' + META + '}}', TMCPTransportHints.None); + 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); @@ -139,7 +139,7 @@ procedure TProcessorTests.Modern_UnknownMethod_Is404; procedure TProcessorTests.Legacy_UnknownMethod_Is200; begin - var Outcome := Run('{"jsonrpc":"2.0","id":1,"method":"prompts/list"}', TMCPTransportHints.ForHttp(True, '2025-06-18')); + 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; From 34eb75413297a5f1a644b535985f9e3bc2739702 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:01:01 +0200 Subject: [PATCH 37/56] test: re-record goldens for the new capabilities and fixtures initialize and server/discover now advertise prompts and completions; tools-list carries json_schema_2020_12_tool; resources-templates-list carries the two registered templates; the unknown-method goldens use the new placeholder method name. --- tests/golden/http/modern-discover.txt | 4 +- tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/modern-unknown-method.txt | 4 +- tests/golden/http/post-initialize-sse.txt | 4 +- tests/golden/http/post-initialize.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/http/post-unknown-method.txt | 4 +- .../golden/legacy/initialize-2025-03-26.json | 5 ++ .../golden/legacy/initialize-2025-06-18.json | 5 ++ .../golden/legacy/initialize-2025-11-25.json | 5 ++ .../legacy/initialize-unknown-version.json | 5 ++ .../legacy/initialize-without-params.json | 5 ++ .../legacy/resources-templates-list.json | 12 +++ tests/golden/legacy/tools-list.json | 80 +++++++++++++++++++ tests/golden/legacy/unknown-method.json | 4 +- .../modern/resources-templates-list.json | 12 +++ tests/golden/modern/server-discover.json | 5 ++ tests/golden/modern/tools-list.json | 80 +++++++++++++++++++ tests/golden/modern/unknown-method.json | 4 +- 20 files changed, 234 insertions(+), 20 deletions(-) diff --git a/tests/golden/http/modern-discover.txt b/tests/golden/http/modern-discover.txt index f14cf4a..11034c6 100644 --- a/tests/golden/http/modern-discover.txt +++ b/tests/golden/http/modern-discover.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 322 +Content-Length: 371 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} +{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 2a77504..2439f42 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 2598 +Content-Length: 3336 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/modern-unknown-method.txt b/tests/golden/http/modern-unknown-method.txt index d0d4aa4..1a73b9c 100644 --- a/tests/golden/http/modern-unknown-method.txt +++ b/tests/golden/http/modern-unknown-method.txt @@ -1,11 +1,11 @@ HTTP/1.1 404 Not Found Connection: close Content-Type: application/json -Content-Length: 141 +Content-Length: 149 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":21,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} +{"jsonrpc":"2.0","id":21,"error":{"code":-32601,"message":"Method [totally/bogus/method] not found. The method does not exist or is not available."}} diff --git a/tests/golden/http/post-initialize-sse.txt b/tests/golden/http/post-initialize-sse.txt index 69c3b1b..fb4a535 100644 --- a/tests/golden/http/post-initialize-sse.txt +++ b/tests/golden/http/post-initialize-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 248 +Content-Length: 297 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} +data: {"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-initialize.txt b/tests/golden/http/post-initialize.txt index 3f1cc05..173703c 100644 --- a/tests/golden/http/post-initialize.txt +++ b/tests/golden/http/post-initialize.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 225 +Content-Length: 274 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} +{"jsonrpc":"2.0","id":1,"result":{"protocolVersion":"2025-06-18","capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 158979a..895d463 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 2469 +Content-Length: 3207 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index 067c79f..f16880a 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 2446 +Content-Length: 3184 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} diff --git a/tests/golden/http/post-unknown-method.txt b/tests/golden/http/post-unknown-method.txt index e2bae1a..4eded8b 100644 --- a/tests/golden/http/post-unknown-method.txt +++ b/tests/golden/http/post-unknown-method.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 140 +Content-Length: 148 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":7,"error":{"code":-32601,"message":"Method [prompts/list] not found. The method does not exist or is not available."}} +{"jsonrpc":"2.0","id":7,"error":{"code":-32601,"message":"Method [totally/bogus/method] not found. The method does not exist or is not available."}} diff --git a/tests/golden/legacy/initialize-2025-03-26.json b/tests/golden/legacy/initialize-2025-03-26.json index 89c4d50..4b70607 100644 --- a/tests/golden/legacy/initialize-2025-03-26.json +++ b/tests/golden/legacy/initialize-2025-03-26.json @@ -28,6 +28,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "serverInfo": { diff --git a/tests/golden/legacy/initialize-2025-06-18.json b/tests/golden/legacy/initialize-2025-06-18.json index 278630d..d7f0e52 100644 --- a/tests/golden/legacy/initialize-2025-06-18.json +++ b/tests/golden/legacy/initialize-2025-06-18.json @@ -28,6 +28,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "serverInfo": { diff --git a/tests/golden/legacy/initialize-2025-11-25.json b/tests/golden/legacy/initialize-2025-11-25.json index c535848..207bd34 100644 --- a/tests/golden/legacy/initialize-2025-11-25.json +++ b/tests/golden/legacy/initialize-2025-11-25.json @@ -28,6 +28,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "serverInfo": { diff --git a/tests/golden/legacy/initialize-unknown-version.json b/tests/golden/legacy/initialize-unknown-version.json index 563f783..07cb7bb 100644 --- a/tests/golden/legacy/initialize-unknown-version.json +++ b/tests/golden/legacy/initialize-unknown-version.json @@ -28,6 +28,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "serverInfo": { diff --git a/tests/golden/legacy/initialize-without-params.json b/tests/golden/legacy/initialize-without-params.json index d356655..8d495ae 100644 --- a/tests/golden/legacy/initialize-without-params.json +++ b/tests/golden/legacy/initialize-without-params.json @@ -19,6 +19,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "serverInfo": { diff --git a/tests/golden/legacy/resources-templates-list.json b/tests/golden/legacy/resources-templates-list.json index c933ac2..b7e47a8 100644 --- a/tests/golden/legacy/resources-templates-list.json +++ b/tests/golden/legacy/resources-templates-list.json @@ -9,6 +9,18 @@ "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/tools-list.json b/tests/golden/legacy/tools-list.json index d84afe0..be1fff3 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -166,6 +166,86 @@ }, "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 + } } ] } diff --git a/tests/golden/legacy/unknown-method.json b/tests/golden/legacy/unknown-method.json index 5f0db5c..0b3ffbc 100644 --- a/tests/golden/legacy/unknown-method.json +++ b/tests/golden/legacy/unknown-method.json @@ -2,14 +2,14 @@ "request": { "jsonrpc": "2.0", "id": 20, - "method": "prompts/list" + "method": "totally/bogus/method" }, "expected": { "jsonrpc": "2.0", "id": 20, "error": { "code": -32601, - "message": "Method [prompts/list] not found. The method does not exist or is not available." + "message": "Method [totally/bogus/method] not found. The method does not exist or is not available." } } } diff --git a/tests/golden/modern/resources-templates-list.json b/tests/golden/modern/resources-templates-list.json index 5c6fefa..56559a1 100644 --- a/tests/golden/modern/resources-templates-list.json +++ b/tests/golden/modern/resources-templates-list.json @@ -20,6 +20,18 @@ "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", diff --git a/tests/golden/modern/server-discover.json b/tests/golden/modern/server-discover.json index 62e591d..6aeddfb 100644 --- a/tests/golden/modern/server-discover.json +++ b/tests/golden/modern/server-discover.json @@ -30,6 +30,11 @@ "resources": { "subscribe": false, "listChanged": false + }, + "prompts": { + "listChanged": false + }, + "completions": { } }, "_meta": { diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json index 7409f3f..47eae7f 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -177,6 +177,86 @@ }, "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 + } } ], "ttlMs": 0, diff --git a/tests/golden/modern/unknown-method.json b/tests/golden/modern/unknown-method.json index 4795ecf..ef52b9d 100644 --- a/tests/golden/modern/unknown-method.json +++ b/tests/golden/modern/unknown-method.json @@ -2,7 +2,7 @@ "request": { "jsonrpc": "2.0", "id": 8, - "method": "prompts/list", + "method": "totally/bogus/method", "params": { "_meta": { "io.modelcontextprotocol/protocolVersion": "2026-07-28", @@ -20,7 +20,7 @@ "id": 8, "error": { "code": -32601, - "message": "Method [prompts/list] not found. The method does not exist or is not available." + "message": "Method [totally/bogus/method] not found. The method does not exist or is not available." } } } From d0c88b6a05d87341de426dce524c4d919756041a Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:01:01 +0200 Subject: [PATCH 38/56] test: prune the conformance baselines for the newly passing scenarios prompts-list, prompts-get-*, resources-templates-read, completion-complete, caching and json-schema-2020-12 now pass on both requirement sets. --- conformance-baseline-2025-11-25.yml | 8 -------- conformance-baseline-2026-07-28.yml | 9 --------- 2 files changed, 17 deletions(-) diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml index 749aaff..e51530d 100644 --- a/conformance-baseline-2025-11-25.yml +++ b/conformance-baseline-2025-11-25.yml @@ -3,21 +3,13 @@ # Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. server: - logging-set-level - - completion-complete - tools-call-with-logging - tools-call-with-progress - tools-call-sampling - tools-call-elicitation - elicitation-sep1034-defaults - elicitation-sep1330-enums - # resource templates are not implemented - - resources-templates-read - resources-subscribe - resources-unsubscribe - - prompts-list - - prompts-get-simple - - prompts-get-with-args - - prompts-get-embedded-resource - - prompts-get-with-image # only a WARNING check (no session id on the SSE path); the runner counts it as not passed - server-sse-multiple-streams diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index d1fe24b..d3e7008 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -3,16 +3,7 @@ # Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. server: - server-stateless - - completion-complete - tools-call-with-progress - # resource templates are not implemented - - resources-templates-read - - prompts-list - - prompts-get-simple - - prompts-get-with-args - - prompts-get-embedded-resource - - prompts-get-with-image - - caching - input-required-result-basic-elicitation - input-required-result-basic-sampling - input-required-result-basic-list-roots From 1788410a249037da6679e7bc6a7ac785bb7d1582 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Thu, 3 Sep 2026 17:01:01 +0200 Subject: [PATCH 39/56] docs: describe prompts, resource templates and completion --- CHANGELOG.md | 47 ++++++++++++++++ MIGRATION.md | 15 +++++ README.md | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 212 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3142d0b..badd6b2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,42 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### 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 @@ -129,6 +165,17 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ### Changed +- `TMCPToolBase` (the non-generic, hand-written-schema base) now validates + its arguments against `BuildSchema` before calling the tool: the abstract + method a descendant overrides is `DoExecute`, not `Execute`, which is now + a concrete template method. Tools deriving from `TMCPToolBase` previously + got no argument validation at all; `TMCPToolBase` and + `TMCPToolBase` are unaffected (their arguments already go through + `TMCPSerializer`). +- The property name a tool or prompt parameter class publishes on the wire + is looked up the same way in both directions: `TMCPSerializer` honours + `[SchemaName]` for deserializing and serializing, not only the schema + generator. - Non-ASCII input over stdio is decoded and echoed back unchanged; Text I/O decoded stdin with the console code page, corrupting characters outside it (a Windows console defaults to an ANSI code page, not UTF-8). diff --git a/MIGRATION.md b/MIGRATION.md index a310c38..8e23112 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -115,6 +115,21 @@ 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. + ## Library use - `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are diff --git a/README.md b/README.md index 9104e08..abcae03 100644 --- a/README.md +++ b/README.md @@ -194,6 +194,7 @@ Copy the `src` folder from MCPServer into your project and add the units to your - `lib\mcpserver\src\Server` - `lib\mcpserver\src\Tools` - `lib\mcpserver\src\Resources` + - `lib\mcpserver\src\Prompts` 2. **Required Units**: Include these core units in your project: ```pascal @@ -263,6 +264,7 @@ end. - **STDIO: keep stdout clean.** Everything on stdout must be an MCP message. `TMCPStdioTransport.Create` forces `TLogger.UseStdErr := True` and sets `TLogger.StdoutReserved`, so console logging goes to stderr and an attempt to switch it back is refused with a one-time warning. Never `Writeln` from tools, managers or resources; log through `TLogger`. - **`server://status` is registered by default** by the unit initialization of `MCPServer.Resource.Server`. `TServerStatusResource.SetNamePrefix('myapp_')` renames it to `server://myapp_status`; call it before the managers are created. - **Error codes and protocol constants** live in `MCPServer.Types` (`JSONRPC_*`, `MCP_ERROR_*`, `MCP_PROTOCOL_VERSION_*`, `MCP_META_*`). The `JSONRPC_*` names in `MCPServer.JsonRpcProcessor` remain as aliases. +- **Prompts and completion are optional managers**, registered the same way as tools and resources: `ManagerRegistry.RegisterManager(TMCPPromptsManager.Create)` and, if you want argument completion, `ManagerRegistry.RegisterManager(TMCPCompletionManager.Create(PromptsManager, ResourcesManager))` (it needs the concrete manager instances, not the `IMCPCapabilityManager` interface, to look prompts and resource templates up by name). The `prompts` and `completions` capabilities are only advertised when these managers are registered. ### Creating Custom Tools @@ -427,6 +429,138 @@ 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: @@ -533,15 +667,30 @@ The Inspector provides a web interface to interact with your MCP server, making content type, one that fails, and one that reports progress and honours cancellation, 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 + +## 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 ## Available Example resources -The server provides six resources accessible via URIs: +The server provides six resources and two resource templates, accessible via URIs: - **server://status** - Current server status and health information (request and connection counters) - **project://info** - Project information (JSON metadata with collections) - **project://readme** - This README file (markdown content) - **logs://recent** - Recent log entries from all categories (with thread safety) +- **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` From f8c34f60fc8da8eb7784cafcbc9ab70189f0f1bc Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 07:53:43 +0200 Subject: [PATCH 40/56] fix: thread safety and lifetime issues found in review Resource templates match without a shared TRegEx and percent-decode without treating '+' as a space. The stdio transport no longer frees objects a worker thread may still use after the drain timeout, and the line reader discards an overlong line chunk by chunk instead of buffering it. TMCPLegacySession is guarded by a lock. Origin allow-list entries match with or without the scheme's default port. JSON string fields are checked with IsJsonString so numbers are rejected. completion/complete answers -32002 to legacy clients for an unknown resource. The completion manager keeps references to its managers, the /info endpoint derives its version list from the supported versions, an invalid SchemaDefault raises, and two leaks in tool result serialisation are closed. Sources carry no comments; test fixtures are discovered through RTTI. --- CHANGELOG.md | 26 ++ src/Core/MCPServer.Logger.pas | 28 +- src/Core/MCPServer.ManagerRegistry.pas | 2 - src/Core/MCPServer.Registration.pas | 15 - src/Core/MCPServer.Settings.pas | 42 +-- src/Managers/MCPServer.CompletionManager.pas | 19 +- src/Managers/MCPServer.CoreManager.pas | 5 - src/Managers/MCPServer.PromptsManager.pas | 11 - src/Managers/MCPServer.ResourcesManager.pas | 12 - src/Managers/MCPServer.ToolsManager.pas | 33 +-- src/Prompts/MCPServer.Prompt.Base.pas | 20 +- .../MCPServer.Prompt.ContentSamples.pas | 4 - .../MCPServer.Prompt.SummarizeLogs.pas | 4 - src/Protocol/MCPServer.Capabilities.pas | 5 - src/Protocol/MCPServer.ContentBlocks.pas | 6 - src/Protocol/MCPServer.Errors.pas | 16 -- src/Protocol/MCPServer.JsonRpcProcessor.pas | 60 +--- src/Protocol/MCPServer.Mrtr.pas | 167 +++++++++++ src/Protocol/MCPServer.RequestContext.pas | 62 ++-- src/Protocol/MCPServer.RequestState.pas | 264 ++++++++++++++++++ src/Protocol/MCPServer.Schema.Generator.pas | 31 +- src/Protocol/MCPServer.Schema.Validator.pas | 19 -- src/Protocol/MCPServer.Serializer.pas | 54 ++-- src/Protocol/MCPServer.Types.pas | 146 ++++------ src/Resources/MCPServer.Resource.Base.pas | 79 ++++-- src/Resources/MCPServer.Resource.Logs.pas | 31 +- src/Resources/MCPServer.Resource.Project.pas | 9 +- src/Resources/MCPServer.Resource.Samples.pas | 5 - src/Resources/MCPServer.Resource.Server.pas | 19 +- src/Server/MCPServer.HttpHeaders.pas | 34 +-- src/Server/MCPServer.IdHTTPServer.pas | 24 +- src/Server/MCPServer.StdioChannel.pas | 49 ++-- src/Server/MCPServer.StdioTransport.pas | 69 ++--- src/Tools/MCPServer.Tool.Base.pas | 25 +- src/Tools/MCPServer.Tool.Calculate.pas | 8 +- src/Tools/MCPServer.Tool.ContentSamples.pas | 15 +- src/Tools/MCPServer.Tool.ListFiles.pas | 6 +- src/Tools/MCPServer.Tool.Result.pas | 13 - tests/MCPServer.Tests.Cancellation.pas | 6 - tests/MCPServer.Tests.Capabilities.pas | 4 - tests/MCPServer.Tests.CompletionManager.pas | 23 +- tests/MCPServer.Tests.Constants.pas | 25 +- tests/MCPServer.Tests.Golden.Legacy.pas | 13 - tests/MCPServer.Tests.Golden.Modern.pas | 6 - tests/MCPServer.Tests.Golden.pas | 31 -- tests/MCPServer.Tests.Harness.pas | 8 - tests/MCPServer.Tests.Http.pas | 5 - tests/MCPServer.Tests.HttpHeaders.pas | 15 +- tests/MCPServer.Tests.Logger.pas | 5 - tests/MCPServer.Tests.Processor.pas | 7 - tests/MCPServer.Tests.Prompt.pas | 4 - tests/MCPServer.Tests.PromptsManager.pas | 3 - tests/MCPServer.Tests.Registration.pas | 6 - tests/MCPServer.Tests.RequestContext.pas | 8 - tests/MCPServer.Tests.ResourcesManager.pas | 36 ++- tests/MCPServer.Tests.Schema.pas | 3 - tests/MCPServer.Tests.SchemaValidator.pas | 3 - tests/MCPServer.Tests.Serializer.pas | 3 - tests/MCPServer.Tests.ServerStatus.pas | 5 - tests/MCPServer.Tests.Stdio.pas | 7 - tests/MCPServer.Tests.StdioChannel.pas | 38 ++- tests/MCPServer.Tests.ToolResult.pas | 3 - tests/MCPServer.Tests.ToolsManager.pas | 6 - 63 files changed, 862 insertions(+), 848 deletions(-) create mode 100644 src/Protocol/MCPServer.Mrtr.pas create mode 100644 src/Protocol/MCPServer.RequestState.pas diff --git a/CHANGELOG.md b/CHANGELOG.md index badd6b2..2f745a7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -288,3 +288,29 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). - The result object of a `TMCPToolBase` tool was cloned into `structuredContent` and never freed; every call leaked it. - Enumeration properties of a result were serialised as booleans. +- Resource templates compiled their pattern into one shared `TRegEx` and + matched on it from every Indy thread at once; matching is thread-safe now. + Template variables are percent-decoded only: a `+` in a URI stays a `+`. +- The stdio worker threads could still be running when the transport was + freed after the drain timeout; the transport now leaves the shared objects + in place for them instead of freeing them under a running thread. +- The stdio line reader read a line longer than the limit into memory before + rejecting it; it now discards such a line chunk by chunk up to its newline. +- `TMCPLegacySession` was read and written by several threads without a + lock. +- Origin allow-list entries without a port did not match an `Origin` header + that spelled out the default port (`https://app.example:443`), and the + other way round. +- `jsonrpc`, `method`, `protocolVersion`, `MCP-Name` and the cancel `reason` + were accepted when they were numbers, because `TJSONNumber` descends from + `TJSONString`; `IsJsonString` in `MCPServer.Types` tells them apart. +- `completion/complete` for an unknown `ref/resource` answers `-32002` to a + legacy client (`-32602` stays for a modern one). +- `TMCPCompletionManager` did not hold a reference to the prompts and + resources managers it was given as interfaces. +- The `/info` endpoint listed the protocol versions in a fixed string; it + now derives them from the supported version lists, newest first. +- An invalid JSON literal in a `[SchemaDefault]` attribute raises + `EArgumentException` instead of being silently dropped. +- A tool result that fails to serialise no longer leaks the partial JSON + object; the DEBUG `outputSchema` check no longer leaks the schema. diff --git a/src/Core/MCPServer.Logger.pas b/src/Core/MCPServer.Logger.pas index 5a492dd..6e92273 100644 --- a/src/Core/MCPServer.Logger.pas +++ b/src/Core/MCPServer.Logger.pas @@ -12,14 +12,14 @@ interface {$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; @@ -54,25 +54,22 @@ TLogger = class class constructor Create; class destructor Destroy; destructor Destroy; override; - + class function Instance: TLogger; - + class procedure Debug(const Message: string); overload; class procedure Debug(const Format: string; const Args: array of const); overload; - + class procedure Info(const Message: string); overload; class procedure Info(const Format: string; const Args: array of const); overload; - + class procedure Warning(const Message: string); overload; class procedure Warning(const Format: string; const Args: array of const); overload; - + class procedure Error(const Message: string); overload; class procedure Error(const Format: string; const Args: array of const); overload; class procedure Error(const Exception: Exception); overload; - /// Returns the JSON text with the values of _meta, requestState, - /// inputResponses and token-like members replaced, for logging. Text - /// that is not JSON is described by its length only. class function RedactJson(const Json: string): string; class property LogToConsole: Boolean read GetLogToConsole write SetLogToConsole; @@ -81,10 +78,6 @@ TLogger = class class property MinLogLevel: TLogLevel read GetMinLogLevel write SetMinLogLevel; class property OnLogMessage: TLogMessageProc read GetOnLogMessage write SetOnLogMessage; class property UseStdErr: Boolean read GetUseStdErr write SetUseStdErr; - /// True while a stdio transport owns stdout. Console logging then always - /// goes to stderr, and setting UseStdErr to False is refused with a - /// one-time warning, because anything on stdout that is not an MCP - /// message corrupts the channel. Set by TMCPStdioTransport.Create. class property StdoutReserved: Boolean read GetStdoutReserved write SetStdoutReserved; end; @@ -142,7 +135,6 @@ class function TLogger.Instance: TLogger; Result := FInstance; end; - procedure TLogger.EnsureLogFile; begin if FLogToFile and not Assigned(FLogFile) then @@ -182,7 +174,6 @@ procedure TLogger.DoWriteLog(const Level: TLogLevel; const Message: string); try if FLogToConsole then begin - // Never touch stdout while a stdio transport owns it. ToStdErr := FUseStdErr or FStdoutReserved; {$IFDEF MSWINDOWS} @@ -202,14 +193,14 @@ procedure TLogger.DoWriteLog(const Level: TLogLevel; const Message: string); SetConsoleTextAttribute(ConsoleHandle, 7); {$ENDIF} end; - + if FLogToFile then begin EnsureLogFile; if Assigned(FLogFile) then FLogFile.WriteLine(LogLine); end; - + if Assigned(FOnLogMessage) then FOnLogMessage(LogLine); finally @@ -407,7 +398,6 @@ class procedure TLogger.SetUseStdErr(const Value: Boolean); Exit; end; - // Refused: stdout belongs to the stdio transport. Warn once, on stderr. FLock.Enter; try WarnOnce := not lInstance.FStdoutWarningIssued; diff --git a/src/Core/MCPServer.ManagerRegistry.pas b/src/Core/MCPServer.ManagerRegistry.pas index ba46585..6f8f0fc 100644 --- a/src/Core/MCPServer.ManagerRegistry.pas +++ b/src/Core/MCPServer.ManagerRegistry.pas @@ -8,8 +8,6 @@ interface MCPServer.Types; type - /// Registration-ordered list of capability managers. Managers that - /// implement IMCPRegistryAware receive a reference to this registry. TMCPManagerRegistry = class(TInterfacedObject, IMCPManagerRegistry, IMCPManagerEnumerator) private FManagers: TList; diff --git a/src/Core/MCPServer.Registration.pas b/src/Core/MCPServer.Registration.pas index f1ff4a5..a727180 100644 --- a/src/Core/MCPServer.Registration.pas +++ b/src/Core/MCPServer.Registration.pas @@ -18,15 +18,6 @@ TMCPToolClass = class of TMCPToolBase; TMCPPromptFactory = reference to function: IMCPPrompt; TMCPResourceTemplateFactory = reference to function: IMCPResourceTemplate; - /// Process-wide registry of tool, resource, prompt and resource-template - /// factories, enumerated in registration order. - /// - /// The dictionaries exist from the class constructor on, so registration - /// from unit initialization sections needs no lazy checks. Registration is - /// not synchronised: register everything before the managers are created. - /// TMCPToolsManager.Create and TMCPResourcesManager.Create read the - /// registry once, so in practice that means before TMCPIdHTTPServer.Start - /// or TMCPStdioTransport.Run. TMCPRegistry = class private class var FTools: TDictionary; @@ -45,8 +36,6 @@ TMCPRegistry = class class procedure RegisterResource(const URI: string; Factory: TMCPResourceFactory); class procedure RegisterPrompt(const Name: string; Factory: TMCPPromptFactory); class procedure RegisterResourceTemplate(const UriTemplate: string; Factory: TMCPResourceTemplateFactory); - /// Removes a registration again (no-op for an unknown URI). Like - /// registration, only meaningful before the managers are created. class procedure UnregisterResource(const URI: string); class function CreateTool(const Name: string): IMCPTool; @@ -54,13 +43,9 @@ TMCPRegistry = class class function CreatePrompt(const Name: string): IMCPPrompt; class function CreateResourceTemplate(const UriTemplate: string): IMCPResourceTemplate; - /// Names in registration order. class function GetToolNames: TArray; - /// URIs in registration order. class function GetResourceURIs: TArray; - /// Names in registration order. class function GetPromptNames: TArray; - /// Template strings in registration order. class function GetResourceTemplateURIs: TArray; class function HasTool(const Name: string): Boolean; diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index 0824d31..738d22f 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -44,10 +44,10 @@ TMCPSettings = class public constructor Create(const ASettingsFile: string = ''; const ACreateFile: Boolean = True); destructor Destroy; override; - + procedure LoadFromFile; procedure SaveToFile; - + property Port: Integer read FPort write FPort; property Host: string read FHost write FHost; property Protocol: string read GetProtocol; @@ -62,42 +62,22 @@ TMCPSettings = class property SSLKeyFile: string read FSSLKeyFile write FSSLKeyFile; property SSLRootCertFile: string read FSSLRootCertFile write FSSLRootCertFile; - // Optional server identity ([Server] Title, Description, WebsiteUrl, - // Instructions); reported in initialize and server/discover when set. 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; - /// [Protocol] LenientModernPing: answer ping for 2026-07-28 requests - /// although the revision removed it. Default off. property LenientModernPing: Boolean read FLenientModernPing write FLenientModernPing; - /// [Protocol] DiscoverListsLegacyVersions: also list the initialize-based - /// revisions in server/discover and in unsupported-version errors. Default off. property DiscoverListsLegacyVersions: Boolean read FDiscoverListsLegacyVersions write FDiscoverListsLegacyVersions; - /// [Protocol] DiscoverTtlMs: cache hint on server/discover. Default 0. property DiscoverTtlMs: Integer read FDiscoverTtlMs write FDiscoverTtlMs; - /// [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. property BindAddress: string read FBindAddress write FBindAddress; - /// [Server] EndpointInfoPath: optional GET path that answers a small JSON - /// document with the endpoint URL and the protocol versions. Empty = off. property EndpointInfoPath: string read FEndpointInfoPath write FEndpointInfoPath; - /// [Server] MaxRequestBodyBytes: larger POST bodies get 413. Default 4 MB. property MaxRequestBodyBytes: Integer read FMaxRequestBodyBytes write FMaxRequestBodyBytes; - /// [Server] MaxJsonDepth: deeper nesting gets 400. Default 64. property MaxJsonDepth: Integer read FMaxJsonDepth write FMaxJsonDepth; - /// [Server] MaxConnections: Indy connection limit; 0 = unlimited. property MaxConnections: Integer read FMaxConnections write FMaxConnections; - /// [Server] MaxConcurrentRequests: worker threads of the stdio transport. - /// 1 (default) answers requests in the order they arrive. property MaxConcurrentRequests: Integer read FMaxConcurrentRequests write FMaxConcurrentRequests; - /// [Security] AllowedOrigins: origins that pass the Origin check next to - /// the loopback origins. Falls back to [CORS] AllowedOrigins when empty. property SecurityAllowedOrigins: string read FSecurityAllowedOrigins write FSecurityAllowedOrigins; - /// The effective allow-list for the Origin check. property AllowedOrigins: string read GetAllowedOrigins; const DEFAULT_MAX_REQUEST_BODY_BYTES = 4 * 1024 * 1024; @@ -115,20 +95,20 @@ implementation constructor TMCPSettings.Create(const ASettingsFile: string; const ACreateFile: Boolean); begin inherited Create; - + if ASettingsFile = '' then FSettingsFile := TPath.Combine(ExtractFilePath(ParamStr(0)), 'settings.ini') else FSettingsFile := ASettingsFile; - + LoadDefaults; - + if ACreateFile and (not TFile.Exists(FSettingsFile)) then begin TLogger.Info('Settings file not found. Creating default settings: ' + FSettingsFile); CreateDefaultSettingsFile; end; - + LoadFromFile; end; @@ -219,7 +199,7 @@ procedure TMCPSettings.CreateDefaultSettingsFile; 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); @@ -236,7 +216,7 @@ procedure TMCPSettings.LoadFromFile; begin if not TFile.Exists(FSettingsFile) then Exit; - + IniFile := TIniFile.Create(FSettingsFile); try FPort := IniFile.ReadInteger('Server', 'Port', FPort); @@ -263,12 +243,12 @@ procedure TMCPSettings.LoadFromFile; FCorsEnabled := IniFile.ReadBool('CORS', 'Enabled', FCorsEnabled); FCorsAllowedOrigins := IniFile.ReadString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); - + FSSLEnabled := IniFile.ReadBool('SSL', 'Enabled', FSSLEnabled); FSSLCertFile := IniFile.ReadString('SSL', 'CertFile', FSSLCertFile); FSSLKeyFile := IniFile.ReadString('SSL', 'KeyFile', FSSLKeyFile); FSSLRootCertFile := IniFile.ReadString('SSL', 'RootCertFile', FSSLRootCertFile); - + TLogger.Info('Settings loaded from: ' + FSettingsFile); TLogger.Info('Server: ' + Protocol + '://' + FHost + ':' + IntToStr(FPort)); if FSSLEnabled then @@ -315,7 +295,7 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteBool('CORS', 'Enabled', FCorsEnabled); IniFile.WriteString('CORS', 'AllowedOrigins', FCorsAllowedOrigins); - + IniFile.WriteBool('SSL', 'Enabled', FSSLEnabled); IniFile.WriteString('SSL', 'CertFile', FSSLCertFile); IniFile.WriteString('SSL', 'KeyFile', FSSLKeyFile); diff --git a/src/Managers/MCPServer.CompletionManager.pas b/src/Managers/MCPServer.CompletionManager.pas index ff9be7b..08b74ef 100644 --- a/src/Managers/MCPServer.CompletionManager.pas +++ b/src/Managers/MCPServer.CompletionManager.pas @@ -14,19 +14,14 @@ interface MCPServer.ResourcesManager; type - /// completion/complete for a prompt argument (ref/prompt) or a resource - /// template variable (ref/resource, tried as a template's uriTemplate - /// first, then as an exact resource's URI). - /// - /// A target that does not implement IMCPCompletable answers no - /// suggestions rather than an error, since not offering completion for a - /// known prompt or resource is a valid choice. 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): IInterface; + function ResolveTarget(const Ref: TJSONObject; Era: TMCPProtocolEra): IInterface; function ParseContext(const Params: TJSONObject): TArray>; function BuildCompletionJSON(const Completion: TMCPCompletion): TJSONObject; public @@ -58,6 +53,8 @@ constructor TMCPCompletionManager.Create(const Prompts: TMCPPromptsManager; cons inherited Create; FPrompts := Prompts; FResources := Resources; + FPromptsRef := Prompts; + FResourcesRef := Resources; end; function TMCPCompletionManager.GetCapabilityName: string; @@ -97,7 +94,7 @@ function TMCPCompletionManager.ExecuteMethodWithContext(const Method: string; co raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; -function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject): IInterface; +function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject; Era: TMCPProtocolEra): IInterface; var Prompt: IMCPPrompt; Template: IMCPResourceTemplate; @@ -129,7 +126,7 @@ function TMCPCompletionManager.ResolveTarget(const Ref: TJSONObject): IInterface else if FResources.TryGetResource(Uri, Resource) then Result := Resource else - raise EMCPError.ResourceNotFound(Uri, TMCPProtocolEra.Modern); + raise EMCPError.ResourceNotFound(Uri, Era); end else raise EMCPError.InvalidParams('params.ref.type must be "ref/prompt" or "ref/resource"'); @@ -198,7 +195,7 @@ function TMCPCompletionManager.Complete(const Params: TJSONObject; Era: TMCPProt TLogger.Info('MCP Complete called for argument: ' + TJSONString(ArgumentNameValue).Value); - var Target := ResolveTarget(TJSONObject(RefValue)); + var Target := ResolveTarget(TJSONObject(RefValue), Era); var Completion: TMCPCompletion; if Supports(Target, IMCPCompletable, Completable) then Completion := Completable.Complete(TJSONString(ArgumentNameValue).Value, TJSONString(ArgumentValueValue).Value, diff --git a/src/Managers/MCPServer.CoreManager.pas b/src/Managers/MCPServer.CoreManager.pas index 3265c1e..e7fe62c 100644 --- a/src/Managers/MCPServer.CoreManager.pas +++ b/src/Managers/MCPServer.CoreManager.pas @@ -11,8 +11,6 @@ interface MCPServer.Logger; type - /// Lifecycle methods: server/discover for modern clients, initialize and - /// ping for legacy clients. Holds no per-client state. TMCPCoreManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPRegistryAware) private FSettings: TMCPSettings; @@ -37,7 +35,6 @@ TMCPCoreManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabili function Discover(const Context: IMCPRequestContext): TValue; function Ping: TValue; - /// Sessions are no longer minted; always empty. Kept for consumers. property SessionID: string read GetSessionID; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; end; @@ -164,7 +161,6 @@ function TMCPCoreManager.Initialize(const Params: TJSONObject; const Context: IM Negotiated := Context.ProtocolVersion else begin - // Called outside the processor: negotiate from the params directly. var Requested := ''; if Assigned(Params) then begin @@ -189,7 +185,6 @@ function TMCPCoreManager.Initialize(const Params: TJSONObject; const Context: IM if FSettings.Instructions <> '' then ResultJSON.AddPair('instructions', FSettings.Instructions); - // stdio remembers the negotiated revision for later legacy requests. if Assigned(Context) and Assigned(Context.LegacySession) then Context.LegacySession.ProtocolVersion := Negotiated; diff --git a/src/Managers/MCPServer.PromptsManager.pas b/src/Managers/MCPServer.PromptsManager.pas index 3234cee..fc8f9ab 100644 --- a/src/Managers/MCPServer.PromptsManager.pas +++ b/src/Managers/MCPServer.PromptsManager.pas @@ -13,13 +13,6 @@ interface MCPServer.Prompt.Base; type - /// prompts/list and prompts/get over the prompts registered in - /// TMCPRegistry, listed in registration order. - /// - /// A missing or unknown prompt name is -32602 (EMCPError.UnknownPrompt); - /// a missing required argument or a wrong argument type is -32602 too - /// (mapped from the prompt's own EArgumentException), since prompts/get - /// has no isError concept to report it through instead. TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) strict private FPrompts: TDictionary; @@ -35,9 +28,7 @@ TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapab constructor Create; destructor Destroy; override; - /// Adds a prompt to this manager only (next to the ones from TMCPRegistry). procedure AddPrompt(const Prompt: IMCPPrompt); - /// The prompt registered under Name, or nil. function TryGetPrompt(const Name: string; out Prompt: IMCPPrompt): Boolean; function GetCapabilityName: string; @@ -52,7 +43,6 @@ TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapab function GetPrompt(const Params: System.JSON.TJSONObject): TValue; overload; function GetPrompt(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; - /// Cache hints on prompts/list for modern clients; 0 and 'private' unless set. property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; end; @@ -149,7 +139,6 @@ function TMCPPromptsManager.TryGetPrompt(const Name: string; out Prompt: IMCPPro procedure TMCPPromptsManager.CheckCursor(const Params: TJSONObject); begin - // Every list fits in one page; a cursor is never one this server issued. if Assigned(Params) and Assigned(Params.GetValue('cursor')) then raise EMCPError.InvalidParams('Invalid cursor'); end; diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 7960033..1dd29a7 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -13,12 +13,6 @@ interface MCPServer.Resource.Base; type - /// resources/list, resources/read and resources/templates/list over the - /// resources registered in TMCPRegistry, listed in registration order. - /// - /// An unknown resource is a JSON-RPC error: -32602 with data.uri in the - /// modern era, -32002 in the initialize-based revisions. A failing read is - /// -32603. Resources that implement IMCPBinaryResource are read as blobs. TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) private FResources: TDictionary; @@ -34,18 +28,14 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap function CreateResourceJSON(const Resource: IMCPResource): TJSONObject; function CreateResourceTemplateJSON(const Template: IMCPResourceTemplate): TJSONObject; function CreateContentsItem(const Resource: IMCPResource): TJSONObject; - /// Exact match first, then the first matching template; nil when neither. function FindResource(const URI: string): IMCPResource; function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; public constructor Create; destructor Destroy; override; - /// Adds a resource to this manager only (next to the ones from TMCPRegistry). procedure AddResource(const Resource: IMCPResource); - /// Adds a resource template to this manager only. procedure AddResourceTemplate(const Template: IMCPResourceTemplate); - /// Exact registration lookups, for completion/complete. function TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; function TryGetResourceTemplate(const UriTemplate: string; out Template: IMCPResourceTemplate): Boolean; @@ -63,7 +53,6 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap function ListResourceTemplates: TValue; overload; function ListResourceTemplates(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; - /// Cache hints on the list results for modern clients; 0 and 'private' unless set. property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; end; @@ -209,7 +198,6 @@ function TMCPResourcesManager.FindResource(const URI: string): IMCPResource; procedure TMCPResourcesManager.CheckCursor(const Params: TJSONObject); begin - // Every list fits in one page; a cursor is never one this server issued. if Assigned(Params) and Assigned(Params.GetValue('cursor')) then raise EMCPError.InvalidParams('Invalid cursor'); end; diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 495398b..3d8cba9 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -13,13 +13,6 @@ interface MCPServer.Tool.Base; type - /// tools/list and tools/call over the tools registered in TMCPRegistry, - /// listed in registration order. - /// - /// Protocol errors (-32602) are raised for a missing or unknown tool name - /// and malformed params; everything a tool itself reports (EMCPToolError, - /// argument validation, unexpected exceptions) becomes an isError result - /// the model can act on. TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, IMCPCapabilityProvider) strict private FTools: TDictionary; @@ -41,7 +34,6 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil constructor Create; destructor Destroy; override; - /// Adds a tool to this manager only (next to the ones from TMCPRegistry). procedure AddTool(const Tool: IMCPTool); function GetCapabilityName: string; @@ -56,7 +48,6 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil function CallTool(const Params: System.JSON.TJSONObject): TValue; overload; function CallTool(const Params: TJSONObject; Era: TMCPProtocolEra): TValue; overload; - /// Cache hints on tools/list for modern clients; 0 and 'private' unless set. property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; end; @@ -78,14 +69,18 @@ implementation procedure WarnIfStructuredContentMismatchesSchema(const Tool: IMCPTool; const Result: TJSONObject); begin var OutputSchema := Tool.OutputSchema; - var StructuredContent := Result.GetValue('structuredContent'); - if not Assigned(OutputSchema) or not Assigned(StructuredContent) then - Exit; - - var Errors: TArray; - if not TMCPSchemaValidator.Validate(OutputSchema, StructuredContent, Errors) then - TLogger.Warning(Format('Tool "%s" structuredContent does not match its outputSchema: %s', - [Tool.Name, string.Join('; ', Errors)])); + try + var StructuredContent := Result.GetValue('structuredContent'); + if not Assigned(OutputSchema) or not Assigned(StructuredContent) then + Exit; + + var Errors: TArray; + if not TMCPSchemaValidator.Validate(OutputSchema, StructuredContent, Errors) then + TLogger.Warning(Format('Tool "%s" structuredContent does not match its outputSchema: %s', + [Tool.Name, string.Join('; ', Errors)])); + finally + OutputSchema.Free; + end; end; {$ENDIF} @@ -176,7 +171,6 @@ procedure TMCPToolsManager.AddTool(const Tool: IMCPTool); procedure TMCPToolsManager.CheckCursor(const Params: TJSONObject); begin - // Every list fits in one page; a cursor is never one this server issued. if Assigned(Params) and Assigned(Params.GetValue('cursor')) then raise EMCPError.InvalidParams('Invalid cursor'); end; @@ -205,7 +199,6 @@ function TMCPToolsManager.ResultToJson(const ResultValue: TValue; Era: TMCPProto if ResultValue.IsType then begin - // A ready-made content array is passed through as is. Result := TJSONObject.Create; Result.AddPair('content', ResultValue.AsType); Exit; @@ -217,7 +210,6 @@ function TMCPToolsManager.ResultToJson(const ResultValue: TValue; Era: TMCPProto begin var Text := ResultValue.AsString; ToolResult.AddText(Text); - // Text results keep signalling failure with an "Error:" prefix. ToolResult.IsError := Text.StartsWith('Error:') or Text.StartsWith('Error executing tool:'); end else if ResultValue.IsType then @@ -241,7 +233,6 @@ function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJS var ResultValue: TValue; begin - // "arguments" is optional on the wire; a tool always receives an object. var OwnedArguments: TJSONObject := nil; var EffectiveArguments := Arguments; if not Assigned(EffectiveArguments) then diff --git a/src/Prompts/MCPServer.Prompt.Base.pas b/src/Prompts/MCPServer.Prompt.Base.pas index 096957a..b7c28cc 100644 --- a/src/Prompts/MCPServer.Prompt.Base.pas +++ b/src/Prompts/MCPServer.Prompt.Base.pas @@ -16,9 +16,6 @@ TMCPPromptArgument = record Required: Boolean; end; - /// Builds the messages of a prompts/get result: one role plus one content - /// block per message, the same block shapes tools/call uses (text, image, - /// audio, resource_link, embedded resource). TMCPPromptMessages = class strict private FMessages: TJSONArray; @@ -28,7 +25,6 @@ TMCPPromptMessages = class destructor Destroy; override; function AddText(const Role, Text: string): TMCPPromptMessages; - /// Data is the raw content; it is Base64-encoded here. 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; @@ -37,13 +33,9 @@ TMCPPromptMessages = class const MimeType: string = ''): TMCPPromptMessages; function AddEmbeddedText(const Role, Uri, MimeType, Text: string): TMCPPromptMessages; function AddEmbeddedBlob(const Role, Uri, MimeType: string; const Data: TBytes): TMCPPromptMessages; - /// Reads Resource (text, or blob for an IMCPBinaryResource) and embeds - /// it under Role. function AddEmbeddedResource(const Role: string; const Resource: IMCPResource): TMCPPromptMessages; - /// Annotations for the message added last (audience, priority, lastModified). function WithAnnotations(const Annotations: TJSONObject): TMCPPromptMessages; - /// The messages array for the result; the caller owns the clone. function ToJson: TJSONArray; end; @@ -53,9 +45,6 @@ TMCPPromptMessages = class function GetTitle: string; function GetDescription: string; function GetArguments: TArray; - /// Arguments is never nil (an empty object when the request omitted - /// it). Builds the messages into Messages; returns the optional - /// result-level description. function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; property Name: string read GetName; @@ -64,7 +53,6 @@ TMCPPromptMessages = class property Arguments: TArray read GetArguments; end; - /// Prompt with a hand-written argument list and raw JSON arguments. TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) protected FName: string; @@ -84,12 +72,6 @@ TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) function Get(const Arguments: TJSONObject; Messages: TMCPPromptMessages): string; virtual; abstract; end; - /// Prompt whose arguments are the string properties of a class T; the - /// argument list comes from T's RTTI, [SchemaDescription] and [Optional] - /// (a required property that is missing from arguments is -32602). - /// - /// T must declare only string properties: prompts/get arguments are - /// always plain strings on the wire. TMCPPromptBase = class(TInterfacedObject, IMCPPrompt, IMCPPromptMetadata) protected FName: string; @@ -300,7 +282,7 @@ function TMCPPromptBase.GetArguments: TArray; Continue; var Arg: TMCPPromptArgument; - Arg.Name := LowerCase(Prop.Name); + Arg.Name := TMCPSerializer.GetWireName(Prop); Arg.Description := ''; Arg.Required := True; for var Attr in Prop.GetAttributes do diff --git a/src/Prompts/MCPServer.Prompt.ContentSamples.pas b/src/Prompts/MCPServer.Prompt.ContentSamples.pas index c24476c..df3a2e7 100644 --- a/src/Prompts/MCPServer.Prompt.ContentSamples.pas +++ b/src/Prompts/MCPServer.Prompt.ContentSamples.pas @@ -1,9 +1,5 @@ unit MCPServer.Prompt.ContentSamples; -/// One prompt per content type, matching the fixtures the official -/// conformance suite calls by name (test_simple_prompt and friends), the -/// same role MCPServer.Tool.ContentSamples plays for tools. - interface uses diff --git a/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas index 247ea29..f5f3a01 100644 --- a/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas +++ b/src/Prompts/MCPServer.Prompt.SummarizeLogs.pas @@ -18,10 +18,6 @@ TSummarizeLogsParams = class property Level: string read FLevel write FLevel; end; - /// Asks the model to summarize the server's recent log entries, embedding - /// logs://recent (or a level-filtered view of it) as a resource. The - /// level argument completes against the levels actually present in the - /// log buffer. TSummarizeLogsPrompt = class(TMCPPromptBase, IMCPCompletable) protected function ExecuteWithParams(const Params: TSummarizeLogsParams; Messages: TMCPPromptMessages): string; override; diff --git a/src/Protocol/MCPServer.Capabilities.pas b/src/Protocol/MCPServer.Capabilities.pas index 1f7ca03..59d23b2 100644 --- a/src/Protocol/MCPServer.Capabilities.pas +++ b/src/Protocol/MCPServer.Capabilities.pas @@ -7,11 +7,6 @@ interface MCPServer.Types; type - /// Derives the server capabilities from the registered managers. - /// - /// Every manager that implements IMCPCapabilityProvider adds its own entry. - /// A registry that cannot enumerate its managers yields the built-in - /// defaults (tools and resources). The logging capability is never emitted. TMCPCapabilityBuilder = class public class function Build(const Registry: IMCPManagerRegistry; Era: TMCPProtocolEra): TJSONObject; diff --git a/src/Protocol/MCPServer.ContentBlocks.pas b/src/Protocol/MCPServer.ContentBlocks.pas index c3fca43..72d8be6 100644 --- a/src/Protocol/MCPServer.ContentBlocks.pas +++ b/src/Protocol/MCPServer.ContentBlocks.pas @@ -1,10 +1,5 @@ unit MCPServer.ContentBlocks; -/// Content block builders shared by tools/call results (an array of blocks) -/// and prompts/get messages (one block per message): the wire shape for -/// text, image, audio, resource link and embedded resource content is the -/// same in both places. - interface uses @@ -19,7 +14,6 @@ function CreateResourceLinkBlock(const Uri, Name: string; const Description: str function CreateEmbeddedTextBlock(const Uri, MimeType, Text: string): TJSONObject; function CreateEmbeddedBlobBlock(const Uri, MimeType, Base64Blob: string): TJSONObject; -/// Base64 without line breaks, as the schema requires for blobs. function EncodeBase64Blob(const Data: TBytes): string; implementation diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index ac5101c..85bcc46 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -8,11 +8,6 @@ interface MCPServer.Types; type - /// A JSON-RPC error a handler or the processor wants to send back. - /// - /// Code and Message become the error object; Data (owned, optional) becomes - /// error.data. HttpStatus is the status a modern HTTP response must carry; - /// 0 leaves the decision to the processor's status policy. EMCPError = class(Exception) private FCode: Integer; @@ -23,7 +18,6 @@ EMCPError = class(Exception) AHttpStatus: Integer = 0); reintroduce; destructor Destroy; override; - /// Hands the data object to the caller; the exception no longer owns it. function DetachData: TJSONValue; class function ParseError(const AMessage: string): EMCPError; @@ -31,17 +25,11 @@ EMCPError = class(Exception) class function MethodNotFound(const Method: string): EMCPError; class function InvalidParams(const AMessage: string; AData: TJSONValue = nil): EMCPError; class function InternalError(const AMessage: string): EMCPError; - /// -32020 (HTTP 400): headers missing or different from the body. class function HeaderMismatch(const AMessage: string): EMCPError; - /// -32021 (HTTP 400): the client did not declare a capability the request needs. class function MissingRequiredClientCapability(const RequiredCapabilities: TJSONObject): EMCPError; - /// -32022 (HTTP 400): the requested revision is not served. class function UnsupportedProtocolVersion(const Requested: string; const Supported: TArray): EMCPError; - /// -32602 with data.name: tools/call names a tool the server does not have. class function UnknownTool(const Name: string): EMCPError; class function UnknownPrompt(const Name: string): EMCPError; - /// Resource not found with data.uri: -32602 in the modern era, -32002 in - /// the initialize-based revisions. class function ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; property Code: Integer read FCode; @@ -49,12 +37,8 @@ EMCPError = class(Exception) property HttpStatus: Integer read FHttpStatus write FHttpStatus; end; - /// Raised by a tool to report a tool execution error: the message becomes - /// an isError result that the model can act on, not a protocol error. EMCPToolError = class(Exception); - /// Raised by IMCPRequestContext.CheckCancelled once the client cancelled - /// the request. The processor sends no response for it. EMCPRequestCancelled = class(Exception); const diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index bff7cb1..d7b4a67 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -14,21 +14,14 @@ interface MCPServer.Logger; type - /// Outcome of one JSON-RPC message. Body is empty when nothing must be - /// sent back (notifications, client responses). HttpStatus is the status - /// a Streamable HTTP transport should answer with. TMCPProcessResult = record Body: string; HttpStatus: Integer; Era: TMCPProtocolEra; IsNotification: Boolean; - /// True when the request was cancelled by the client; Body is empty. Cancelled: Boolean; end; - /// Transport-independent JSON-RPC pipeline: parse, validate the message - /// shape, detect the protocol era, dispatch to the owning manager, shape - /// the result for the era and decide the HTTP status. TMCPJsonRpcProcessor = class private FManagerRegistry: IMCPManagerRegistry; @@ -62,32 +55,19 @@ TMCPJsonRpcProcessor = class constructor Create(ManagerRegistry: IMCPManagerRegistry; Settings: TMCPSettings); overload; destructor Destroy; override; - /// Plain JSON-RPC layer without transport hints; returns the response body. function ProcessRequest(const RequestBody: string; const SessionID: string): string; function ProcessRequestEx(const RequestBody: string; const Hints: TMCPTransportHints): TMCPProcessResult; overload; - /// Message is the already parsed body (nil when parsing failed); the - /// caller keeps ownership. function ProcessRequestEx(const Message: TJSONValue; const Hints: TMCPTransportHints): TMCPProcessResult; overload; - /// Decides the era of a request and validates the modern _meta fields. - /// Raises EMCPError with the HTTP status a modern transport must use. function BuildRequestContext(const Method: string; const Params: TJSONObject; const RequestId: TMCPRequestId; const Hints: TMCPTransportHints): IMCPRequestContext; - /// The JSON-RPC error response body for an error a transport detected - /// itself (a duplicate id, an overlong line). The error's data is - /// detached into the body. function BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry; - /// Server identity and protocol options. A processor created without - /// settings uses the defaults (settings.ini next to the executable when present). property Settings: TMCPSettings read FSettings write SetSettings; end; const - // The JSON-RPC error codes are defined in MCPServer.Types. These aliases - // keep consumer code that references MCPServer.JsonRpcProcessor.JSONRPC_* - // compiling. 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; @@ -101,10 +81,8 @@ implementation RESULT_TYPE_COMPLETE = 'complete'; CACHE_SCOPE_PRIVATE = 'private'; - /// Methods that only exist in the initialize-based revisions. LEGACY_ONLY_METHODS: array[0..4] of string = ( 'ping', 'initialize', 'logging/setLevel', 'resources/subscribe', 'resources/unsubscribe'); - /// Methods that only exist with per-request _meta. MODERN_ONLY_METHODS: array[0..1] of string = ('server/discover', 'subscriptions/listen'); LOG_LEVELS: array[0..7] of string = ( 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); @@ -195,7 +173,6 @@ function TMCPJsonRpcProcessor.IsCacheableMethod(const Method: string): Boolean; function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; begin - // Before the body is understood only the header can tell the era apart. if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader and IsModernProtocolVersion(Hints.ProtocolVersionHeader) then Result := TMCPProtocolEra.Modern @@ -206,8 +183,6 @@ function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): T function TMCPJsonRpcProcessor.EraFromMessage(const Method: string; const Params: TJSONObject; const Hints: TMCPTransportHints): TMCPProtocolEra; begin - // The era that decides the status of a rejected request: a body that - // names a protocol version in _meta is modern even when it fails validation. Result := EraFromHeaders(Hints); if (Result = TMCPProtocolEra.Modern) or not Assigned(Params) then Exit; @@ -256,7 +231,6 @@ procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; con var Decoded: string; begin - // Mcp-Method mirrors the method on every modern POST. if not Hints.HasMethodHeader then raise EMCPError.HeaderMismatch('Mcp-Method header is missing'); if Hints.MethodHeader <> Method then @@ -264,7 +238,6 @@ procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; con 'Header mismatch: Mcp-Method header value ''%s'' does not match body value ''%s''', [Hints.MethodHeader, Method])); - // Mcp-Name mirrors params.name (tools/call, prompts/get) or params.uri (resources/read). var SourceField := ''; if (Method = 'tools/call') or (Method = 'prompts/get') then SourceField := 'name' @@ -282,7 +255,7 @@ procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; con if Assigned(Params) then begin var Source := Params.GetValue(SourceField); - if Source is TJSONString then + if IsJsonString(Source) then BodyValue := TJSONString(Source).Value; end; if Decoded <> BodyValue then @@ -298,9 +271,6 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa begin var Meta := ExtractMeta(Params); - // 1. A protocol version in _meta makes the request modern, initialize - // included: in that era it is an unknown method, which is what a - // modern client probing the server expects. var VersionValue: TJSONValue := nil; if Assigned(Meta) then VersionValue := Meta.GetValue(MCP_META_PROTOCOL_VERSION); @@ -338,27 +308,23 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; - // 2. initialize without modern _meta selects the legacy era and negotiates - // the revision. if Method = 'initialize' then begin var Requested := ''; if Assigned(Params) then begin var RequestedValue := Params.GetValue('protocolVersion'); - if RequestedValue is TJSONString then + if IsJsonString(RequestedValue) then Requested := TJSONString(RequestedValue).Value; end; Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; - // 3. A modern-only method without _meta is a malformed modern request. if IsModernOnlyMethod(Method) then raise EMCPError.Create(JSONRPC_INVALID_PARAMS, Format('%s requires params._meta.%s', [Method, MCP_META_PROTOCOL_VERSION]), nil, HTTP_STATUS_BAD_REQUEST); - // 4. On HTTP the header alone can still name the revision. if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader then begin var Header := Hints.ProtocolVersionHeader; @@ -374,7 +340,6 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa Hints.LegacySession, FManagerRegistry, Hints.Sink)); end; - // 5. Legacy, with the version negotiated on this process when known. Version := ''; if Assigned(Hints.LegacySession) then Version := Hints.LegacySession.ProtocolVersion; @@ -417,7 +382,6 @@ function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Pa procedure TMCPJsonRpcProcessor.HandleCancelled(const Params: TJSONObject; const Hints: TMCPTransportHints); begin - // Only a transport that tracks its requests can act on the notification. if not Assigned(Hints.Tracker) or not Assigned(Params) then Exit; @@ -430,7 +394,7 @@ procedure TMCPJsonRpcProcessor.HandleCancelled(const Params: TJSONObject; const var Reason := ''; var ReasonValue := Params.GetValue('reason'); - if ReasonValue is TJSONString then + if IsJsonString(ReasonValue) then Reason := TJSONString(ReasonValue).Value; if not Hints.Tracker.TryCancel(RequestId, Reason) then @@ -504,7 +468,6 @@ function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: I begin if Context.Era = TMCPProtocolEra.Legacy then begin - // Byte-for-byte what the initialize-based revisions always received. if Value.IsEmpty then Result := nil else if Value.IsType then @@ -516,7 +479,6 @@ function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: I Exit; end; - // Modern results are always objects with a resultType. var ResultObject: TJSONObject; if Value.IsType then ResultObject := Value.AsType @@ -533,9 +495,6 @@ function TMCPJsonRpcProcessor.ResultToJson(const Value: TValue; const Context: I function TMCPJsonRpcProcessor.StatusForError(Era: TMCPProtocolEra; const Error: EMCPError): Integer; begin - // Legacy clients read 404 as "session terminated". They get 200 for every - // JSON-RPC error; the one 4xx their revisions define is 400 for a bad - // MCP-Protocol-Version header, which arrives with the status set. if Era = TMCPProtocolEra.Legacy then begin if Error.HttpStatus = HTTP_STATUS_BAD_REQUEST then @@ -587,7 +546,6 @@ function TMCPJsonRpcProcessor.ErrorResult(Era: TMCPProtocolEra; const RequestId: function TMCPJsonRpcProcessor.ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; begin - // The text heuristic predates typed errors; legacy answers keep it. if (Era = TMCPProtocolEra.Legacy) and (Pos('not found', E.Message) > 0) then Result := EMCPError.Create(JSONRPC_METHOD_NOT_FOUND, E.Message) else @@ -642,14 +600,12 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; end; var JsonRpc := Request.GetValue('jsonrpc'); - if not (JsonRpc is TJSONString) or (TJSONString(JsonRpc).Value <> JSONRPC_VERSION) then + if not IsJsonString(JsonRpc) or (TJSONString(JsonRpc).Value <> JSONRPC_VERSION) then raise EMCPError.InvalidRequest('jsonrpc must be "2.0"'); var MethodValue := Request.GetValue('method'); - if not (MethodValue is TJSONString) then + if not IsJsonString(MethodValue) then begin - // A message with result or error is a response sent by the client; - // it is never answered. if Assigned(Request.GetValue('result')) or Assigned(Request.GetValue('error')) then begin if Era = TMCPProtocolEra.Modern then @@ -669,7 +625,11 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; if Assigned(ParamsValue) then begin if not (ParamsValue is TJSONObject) then + begin + if Era = TMCPProtocolEra.Modern then + raise EMCPError.Create(JSONRPC_INVALID_PARAMS, 'params must be an object', nil, HTTP_STATUS_BAD_REQUEST); raise EMCPError.InvalidParams('params must be an object'); + end; Params := TJSONObject(ParamsValue); end; @@ -690,8 +650,6 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; Hints.Tracker.Untrack(Context); end; - // A cancelled request gets no response, whether or not the handler - // noticed the cancellation. if Context.IsCancelled then begin if ExecuteResult.IsObject then diff --git a/src/Protocol/MCPServer.Mrtr.pas b/src/Protocol/MCPServer.Mrtr.pas new file mode 100644 index 0000000..1ea6e46 --- /dev/null +++ b/src/Protocol/MCPServer.Mrtr.pas @@ -0,0 +1,167 @@ +unit MCPServer.Mrtr; + +interface + +uses + System.SysUtils, + System.JSON; + +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; + + EMCPInputRequired = class(Exception) + strict private + FRequests: TMCPInputRequests; + FState: TJSONObject; + public + constructor Create(Requests: TMCPInputRequests; State: TJSONObject = nil); + destructor Destroy; override; + property Requests: TMCPInputRequests read FRequests; + property State: TJSONObject read FState; + end; + +implementation + +{ TMCPInputRequests } + +class function TMCPInputRequests.FieldSchema(const Field: string; const FieldType: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('type', 'object'); + var Properties := TJSONObject.Create; + Result.AddPair('properties', Properties); + var Schema := TJSONObject.Create; + Schema.AddPair('type', FieldType); + Properties.AddPair(Field, Schema); + var Required := TJSONArray.Create; + Required.Add(Field); + Result.AddPair('required', Required); +end; + +constructor TMCPInputRequests.Create; +begin + inherited Create; + FRequests := TJSONObject.Create; +end; + +destructor TMCPInputRequests.Destroy; +begin + FRequests.Free; + inherited; +end; + +function TMCPInputRequests.AddRequest(const Key, Method: string; const Params: TJSONObject): TMCPInputRequests; +begin + var Request := TJSONObject.Create; + Request.AddPair('method', Method); + Request.AddPair('params', Params); + FRequests.AddPair(Key, Request); + Result := Self; +end; + +function TMCPInputRequests.AddElicitation(const Key, Message: string; + const RequestedSchema: TJSONObject): TMCPInputRequests; +begin + var Params := TJSONObject.Create; + Params.AddPair('mode', ELICITATION_MODE_FORM); + Params.AddPair('message', Message); + Params.AddPair('requestedSchema', RequestedSchema); + Result := AddRequest(Key, MCP_METHOD_ELICITATION_CREATE, Params); +end; + +function TMCPInputRequests.AddSampling(const Key, UserText: string; MaxTokens: Integer; + const SystemPrompt: string): TMCPInputRequests; +begin + var Params := TJSONObject.Create; + var Messages := TJSONArray.Create; + Params.AddPair('messages', Messages); + var Message := TJSONObject.Create; + Messages.AddElement(Message); + Message.AddPair('role', 'user'); + var Content := TJSONObject.Create; + Message.AddPair('content', Content); + Content.AddPair('type', 'text'); + Content.AddPair('text', UserText); + if SystemPrompt <> '' then + Params.AddPair('systemPrompt', SystemPrompt); + Params.AddPair('maxTokens', TJSONNumber.Create(MaxTokens)); + Result := AddRequest(Key, MCP_METHOD_SAMPLING_CREATE_MESSAGE, Params); +end; + +function TMCPInputRequests.AddListRoots(const Key: string): TMCPInputRequests; +begin + Result := AddRequest(Key, MCP_METHOD_ROOTS_LIST, TJSONObject.Create); +end; + +function TMCPInputRequests.Count: Integer; +begin + Result := FRequests.Count; +end; + +function TMCPInputRequests.Methods: TArray; +begin + Result := nil; + for var Pair in FRequests do + Result := Result + [TJSONObject(Pair.JsonValue).GetValue('method')]; +end; + +class function TMCPInputRequests.RequiredCapability(const Method: string): string; +begin + if Method = MCP_METHOD_ELICITATION_CREATE then + Result := 'elicitation' + else if Method = MCP_METHOD_SAMPLING_CREATE_MESSAGE then + Result := 'sampling' + else if Method = MCP_METHOD_ROOTS_LIST then + Result := 'roots' + else + Result := ''; +end; + +function TMCPInputRequests.ToJson: TJSONObject; +begin + Result := TJSONObject(FRequests.Clone); +end; + +{ 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 index aac6fa9..e64c1bc 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -9,14 +9,10 @@ interface MCPServer.Types; const - /// Progress notifications for one request are sent at most this often, - /// except for the one that reaches the total. PROGRESS_MIN_INTERVAL_MS = 50; type - /// What the transport knows about a request before the processor sees it. TMCPTransportHints = record - /// True when the transport carries HTTP headers (Streamable HTTP). HasHeaderLayer: Boolean; HasProtocolVersionHeader: Boolean; ProtocolVersionHeader: string; @@ -25,27 +21,17 @@ TMCPTransportHints = record HasNameHeader: Boolean; NameHeader: string; RemoteAddress: string; - /// Per-process legacy state (stdio); nil for stateless transports. LegacySession: TMCPLegacySession; - /// Channel for request-scoped notifications (progress); nil when the - /// transport cannot deliver them before the response. Sink: IMCPMessageSink; - /// In-flight bookkeeping for notifications/cancelled; nil when the - /// transport signals cancellation another way. Tracker: IMCPRequestTracker; - /// No headers, no session: the plain JSON-RPC layer. class function None: TMCPTransportHints; static; - /// stdio: no headers, one session slot per process. class function ForStdio(const Session: TMCPLegacySession): TMCPTransportHints; overload; static; - /// stdio with a channel for progress notifications and cancellation. class function ForStdio(const Session: TMCPLegacySession; const Sink: IMCPMessageSink; const Tracker: IMCPRequestTracker): TMCPTransportHints; overload; static; - /// HTTP: the MCP-Protocol-Version header, empty and HasHeader False when absent. class function ForHttp(const HasVersionHeader: Boolean; const VersionHeader: string): TMCPTransportHints; static; end; - /// Default IMCPRequestContext implementation and the thread-local Current. TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) private FEra: TMCPProtocolEra; @@ -62,12 +48,10 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) FLastProgressTick: UInt64; function MetaObject(const Key: string): TJSONObject; public - /// Meta is cloned; the context owns its copy. Sink is where progress - /// notifications go; nil disables them. - constructor Create(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; - const ARequestId: TMCPRequestId; const AMeta: TJSONObject; - const ALegacySession: TMCPLegacySession; const AManagerRegistry: IMCPManagerRegistry; - const ASink: IMCPMessageSink = nil); + constructor Create(Era: TMCPProtocolEra; const ProtocolVersion, Method: string; + const RequestId: TMCPRequestId; const Meta: TJSONObject; + const LegacySession: TMCPLegacySession; const ManagerRegistry: IMCPManagerRegistry; + const Sink: IMCPMessageSink = nil); destructor Destroy; override; function GetEra: TMCPProtocolEra; @@ -89,9 +73,7 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) function HasProgressToken: Boolean; procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); - /// The context of the request the calling thread is serving, or nil. class function Current: IMCPRequestContext; - /// Set by the processor around a handler call; nil clears it. class procedure SetCurrent(const Value: IMCPRequestContext); end; @@ -101,8 +83,6 @@ implementation MCPServer.Errors; threadvar - // Raw pointer with manual reference counting: a managed threadvar is not - // finalised when a thread ends. CurrentContextPointer: Pointer; { TMCPTransportHints } @@ -136,20 +116,20 @@ class function TMCPTransportHints.ForHttp(const HasVersionHeader: Boolean; const { TMCPRequestContext } -constructor TMCPRequestContext.Create(AEra: TMCPProtocolEra; const AProtocolVersion, AMethod: string; - const ARequestId: TMCPRequestId; const AMeta: TJSONObject; const ALegacySession: TMCPLegacySession; - const AManagerRegistry: IMCPManagerRegistry; const ASink: IMCPMessageSink); +constructor TMCPRequestContext.Create(Era: TMCPProtocolEra; const ProtocolVersion, Method: string; + const RequestId: TMCPRequestId; const Meta: TJSONObject; const LegacySession: TMCPLegacySession; + const ManagerRegistry: IMCPManagerRegistry; const Sink: IMCPMessageSink); begin inherited Create; - FEra := AEra; - FProtocolVersion := AProtocolVersion; - FMethod := AMethod; - FRequestId := ARequestId; - if Assigned(AMeta) then - FMeta := TJSONObject(AMeta.Clone); - FLegacySession := ALegacySession; - FManagerRegistry := AManagerRegistry; - FSink := ASink; + FEra := Era; + FProtocolVersion := ProtocolVersion; + FMethod := Method; + FRequestId := RequestId; + if Assigned(Meta) then + FMeta := TJSONObject(Meta.Clone); + FLegacySession := LegacySession; + FManagerRegistry := ManagerRegistry; + FSink := Sink; end; destructor TMCPRequestContext.Destroy; @@ -211,7 +191,7 @@ function TMCPRequestContext.GetLogLevel: string; Exit; var Value := FMeta.GetValue(MCP_META_LOG_LEVEL); - if Value is TJSONString then + if IsJsonString(Value) then Result := TJSONString(Value).Value; end; @@ -255,8 +235,6 @@ procedure TMCPRequestContext.RequireClientCapability(const Path: string); if HasClientCapability(Path) then Exit; - // Rebuild the dotted path as nested objects: 'elicitation.form' becomes - // {"elicitation": {"form": {}}}. var Required := TJSONObject.Create; var Node := Required; for var Segment in Path.Split(['.']) do @@ -276,7 +254,7 @@ function TMCPRequestContext.IsCancelled: Boolean; procedure TMCPRequestContext.CheckCancelled; begin if IsCancelled then - raise EMCPRequestCancelled.Create('Request ' + FRequestId.AsText + ' was cancelled by the client'); + raise EMCPRequestCancelled.CreateFmt('Request %s was cancelled by the client', [FRequestId.AsText]); end; procedure TMCPRequestContext.Cancel; @@ -287,8 +265,6 @@ procedure TMCPRequestContext.Cancel; function TMCPRequestContext.HasProgressToken: Boolean; begin var Token := GetProgressToken; - // A whole-valued number or a string; TJSONNumber must be checked first - // since it descends from TJSONString. if not Assigned(Token) then Exit(False); if Token is TJSONNumber then @@ -300,8 +276,6 @@ procedure TMCPRequestContext.ReportProgress(const Progress, Total: Double; const const JSON_RPC_VERSION = '2.0'; begin - // Nothing to deliver without a token or a channel, and nothing more for a - // request the client cancelled. if not Assigned(FSink) or not HasProgressToken or IsCancelled then Exit; diff --git a/src/Protocol/MCPServer.RequestState.pas b/src/Protocol/MCPServer.RequestState.pas new file mode 100644 index 0000000..830fe87 --- /dev/null +++ b/src/Protocol/MCPServer.RequestState.pas @@ -0,0 +1,264 @@ +unit MCPServer.RequestState; + +interface + +uses + System.SysUtils, + System.JSON; + +type + TMCPRequestStateSealer = class + public + const DEFAULT_TTL_SECONDS = 600; + const TOKEN_VERSION = 1; + strict private + FKey: TBytes; + FTtlSeconds: Integer; + FKeyIsEphemeral: Boolean; + function Signature(const Payload: TBytes): TBytes; + class function Base64Url(const Bytes: TBytes): string; static; + class function TryFromBase64Url(const Text: string; out Bytes: TBytes): Boolean; static; + class function SameBytes(const A, B: TBytes): Boolean; static; + class function CanonicalJson(const Value: TJSONValue): string; static; + public + constructor Create(const Key: string; TtlSeconds: Integer = DEFAULT_TTL_SECONDS); + + function Seal(const State: TJSONObject; const Method, ArgumentDigest, Principal: string): string; + function Open(const Token, Method, ArgumentDigest, Principal: string): TJSONObject; + + class function DigestOf(const Params: TJSONObject): string; static; + + property KeyIsEphemeral: Boolean read FKeyIsEphemeral; + property TtlSeconds: Integer read FTtlSeconds; + end; + +implementation + +uses + System.Classes, + System.Hash, + System.DateUtils, + System.NetEncoding, + System.Generics.Collections, + System.Generics.Defaults, + MCPServer.Errors, + MCPServer.Logger; + +const + KEY_BYTES = 32; + TOKEN_SEPARATOR = '.'; + PAYLOAD_VERSION = 'v'; + PAYLOAD_METHOD = 'm'; + PAYLOAD_DIGEST = 'a'; + PAYLOAD_EXPIRY = 'exp'; + PAYLOAD_PRINCIPAL = 'p'; + PAYLOAD_STATE = 's'; + EXCLUDED_MEMBERS: array[0..2] of string = ('_meta', 'inputResponses', 'requestState'); + +{ TMCPRequestStateSealer } + +constructor TMCPRequestStateSealer.Create(const Key: string; TtlSeconds: Integer); +begin + inherited Create; + FTtlSeconds := TtlSeconds; + if Key.Trim <> '' then + FKey := TEncoding.UTF8.GetBytes(Key) + else + begin + SetLength(FKey, KEY_BYTES); + Randomize; + for var I := 0 to High(FKey) do + FKey[I] := Byte(Random(256)); + FKeyIsEphemeral := True; + TLogger.Warning('[Security] RequestStateKey is not set: requestState tokens are sealed with a random key ' + + 'and stop verifying after a restart or on another instance'); + end; +end; + +function TMCPRequestStateSealer.Signature(const Payload: TBytes): TBytes; +begin + Result := THashSHA2.GetHMACAsBytes(Payload, FKey, THashSHA2.TSHA2Version.SHA256); +end; + +class function TMCPRequestStateSealer.Base64Url(const Bytes: TBytes): string; +begin + var Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Bytes).Replace('+', '-').Replace('/', '_').TrimRight(['=']); + finally + Encoding.Free; + end; +end; + +class function TMCPRequestStateSealer.TryFromBase64Url(const Text: string; out Bytes: TBytes): Boolean; +begin + Bytes := nil; + if Text = '' then + Exit(False); + for var C in Text do + if not (CharInSet(C, ['A'..'Z', 'a'..'z', '0'..'9', '-', '_'])) then + Exit(False); + + var Standard := Text.Replace('-', '+').Replace('_', '/'); + while Length(Standard) mod 4 <> 0 do + Standard := Standard + '='; + try + Bytes := TNetEncoding.Base64.DecodeStringToBytes(Standard); + Result := Length(Bytes) > 0; + except + Result := False; + end; +end; + +class function TMCPRequestStateSealer.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; + +class function TMCPRequestStateSealer.CanonicalJson(const Value: TJSONValue): string; +begin + if Value is TJSONObject then + begin + var Names := TList.Create; + try + for var Pair in TJSONObject(Value) do + Names.Add(Pair.JsonString.Value); + Names.Sort(TComparer.Construct( + function(const Left, Right: string): Integer + begin + Result := CompareStr(Left, Right); + end)); + var Parts := TStringBuilder.Create; + try + Parts.Append('{'); + for var I := 0 to Names.Count - 1 do + begin + if I > 0 then + Parts.Append(','); + Parts.Append(TJSONString.Create(Names[I]).ToJSON).Append(':') + .Append(CanonicalJson(TJSONObject(Value).GetValue(Names[I]))); + end; + Parts.Append('}'); + Result := Parts.ToString; + finally + Parts.Free; + end; + finally + Names.Free; + end; + end + else if Value is TJSONArray then + begin + var Parts := TStringBuilder.Create; + try + Parts.Append('['); + for var I := 0 to TJSONArray(Value).Count - 1 do + begin + if I > 0 then + Parts.Append(','); + Parts.Append(CanonicalJson(TJSONArray(Value).Items[I])); + end; + Parts.Append(']'); + Result := Parts.ToString; + finally + Parts.Free; + end; + end + else if Assigned(Value) then + Result := Value.ToJSON + else + Result := 'null'; +end; + +class function TMCPRequestStateSealer.DigestOf(const Params: TJSONObject): string; +begin + var Salient := TJSONObject.Create; + try + if Assigned(Params) then + for var Pair in Params do + begin + var Excluded := False; + for var Name in EXCLUDED_MEMBERS do + if Pair.JsonString.Value = Name then + Excluded := True; + if not Excluded then + Salient.AddPair(Pair.JsonString.Value, TJSONValue(Pair.JsonValue.Clone)); + end; + Result := THashSHA2.GetHashString(CanonicalJson(Salient), THashSHA2.TSHA2Version.SHA256); + finally + Salient.Free; + end; +end; + +function TMCPRequestStateSealer.Seal(const State: TJSONObject; const Method, ArgumentDigest, + Principal: string): string; +begin + var Payload := TJSONObject.Create; + try + Payload.AddPair(PAYLOAD_VERSION, TJSONNumber.Create(TOKEN_VERSION)); + Payload.AddPair(PAYLOAD_METHOD, Method); + Payload.AddPair(PAYLOAD_DIGEST, ArgumentDigest); + Payload.AddPair(PAYLOAD_EXPIRY, TJSONNumber.Create(DateTimeToUnix(Now, False) + FTtlSeconds)); + Payload.AddPair(PAYLOAD_PRINCIPAL, Principal); + if Assigned(State) then + Payload.AddPair(PAYLOAD_STATE, TJSONObject(State.Clone)) + else + Payload.AddPair(PAYLOAD_STATE, TJSONObject.Create); + + var PayloadBytes := TEncoding.UTF8.GetBytes(Payload.ToJSON); + Result := Base64Url(PayloadBytes) + TOKEN_SEPARATOR + Base64Url(Signature(PayloadBytes)); + finally + Payload.Free; + end; +end; + +function TMCPRequestStateSealer.Open(const Token, Method, ArgumentDigest, Principal: string): TJSONObject; +var + PayloadBytes, SignatureBytes: TBytes; +begin + var Separator := Token.LastIndexOf(TOKEN_SEPARATOR); + if (Separator <= 0) or not TryFromBase64Url(Token.Substring(0, Separator), PayloadBytes) + or not TryFromBase64Url(Token.Substring(Separator + 1), SignatureBytes) + or not SameBytes(SignatureBytes, Signature(PayloadBytes)) then + raise EMCPError.InvalidParams('requestState failed integrity verification'); + + var Payload := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(PayloadBytes)) as TJSONObject; + if not Assigned(Payload) then + raise EMCPError.InvalidParams('requestState failed integrity verification'); + try + if Payload.GetValue(PAYLOAD_VERSION, 0) <> TOKEN_VERSION then + raise EMCPError.InvalidParams('requestState has an unsupported version'); + if Payload.GetValue(PAYLOAD_METHOD, '') <> Method then + raise EMCPError.InvalidParams('requestState belongs to another method'); + if Payload.GetValue(PAYLOAD_DIGEST, '') <> ArgumentDigest then + raise EMCPError.InvalidParams('requestState belongs to another request'); + if Payload.GetValue(PAYLOAD_PRINCIPAL, '') <> Principal then + raise EMCPError.InvalidParams('requestState belongs to another principal'); + if Payload.GetValue(PAYLOAD_EXPIRY, 0) < DateTimeToUnix(Now, False) then + raise EMCPError.InvalidParams('requestState has expired'); + + var State := Payload.GetValue(PAYLOAD_STATE); + if State is TJSONObject then + Result := TJSONObject(State.Clone) + else + Result := TJSONObject.Create; + finally + Payload.Free; + end; +end; + +end. diff --git a/src/Protocol/MCPServer.Schema.Generator.pas b/src/Protocol/MCPServer.Schema.Generator.pas index 0332371..1ed2ed3 100644 --- a/src/Protocol/MCPServer.Schema.Generator.pas +++ b/src/Protocol/MCPServer.Schema.Generator.pas @@ -9,25 +9,6 @@ interface System.JSON; type - /// JSON Schema (2020-12 subset) for a parameter or result class, derived - /// from its published/public properties: - /// - /// Integer, Int64, Byte ... integer - /// Double, Single, Currency number - /// TDateTime / TDate / TTime string with format date-time / date / time - /// string string - /// Boolean boolean - /// other enumerations string with the enum names - /// sets array of enum names - /// dynamic arrays, TList array with typed items - /// TJSONArray / TJSONObject array / object (free form) - /// other classes nested object schema - /// - /// Property attributes: [SchemaDescription], [SchemaTitle], [SchemaFormat], - /// [SchemaMinimum], [SchemaMaximum], [SchemaMinLength], [SchemaMaxLength], - /// [SchemaPattern], [SchemaDefault], [SchemaEnum], [SchemaName] (overrides - /// the wire name) and [Optional]. Class attributes: - /// [SchemaAdditionalProperties] and [SchemaDialect] (root schema only). TMCPSchemaGenerator = class private const MAX_NESTING_DEPTH = 8; @@ -95,7 +76,6 @@ class function TMCPSchemaGenerator.CreateEnumValuesArray(RttiType: TRttiType): T class function TMCPSchemaGenerator.ListItemType(RttiType: TRttiType): TRttiType; begin - // TList and TObjectList expose Items[Index: NativeInt]: T. Result := nil; var ItemsProp := RttiType.GetIndexedProperty('Items'); if not Assigned(ItemsProp) or not Assigned(ItemsProp.ReadMethod) then @@ -203,7 +183,6 @@ class function TMCPSchemaGenerator.TypeSchema(RttiType: TRttiType; Depth: Intege class function TMCPSchemaGenerator.NumberValue(const Value: Double): TJSONNumber; begin - // Whole bounds are written as integers, so "minimum": 1 rather than 1.0. if Frac(Value) = 0 then Result := TJSONNumber.Create(Trunc(Value)) else @@ -242,7 +221,13 @@ class procedure TMCPSchemaGenerator.ApplyAttributes(Prop: TRttiProperty; const P else if Attr is SchemaPatternAttribute then PropSchema.AddPair('pattern', SchemaPatternAttribute(Attr).Pattern) else if Attr is SchemaDefaultAttribute then - PropSchema.AddPair('default', TJSONObject.ParseJSONValue(SchemaDefaultAttribute(Attr).Json)); + begin + var DefaultValue := TJSONObject.ParseJSONValue(SchemaDefaultAttribute(Attr).Json); + if not Assigned(DefaultValue) then + raise EArgumentException.CreateFmt('[SchemaDefault] on %s is not valid JSON: %s', + [Prop.Name, SchemaDefaultAttribute(Attr).Json]); + PropSchema.AddPair('default', DefaultValue); + end; end; end; @@ -287,8 +272,6 @@ class function TMCPSchemaGenerator.ObjectSchema(RttiType: TRttiType; Depth: Inte ExplicitAdditionalProperties := True; end; - // A tool without parameters accepts an empty object and nothing else, - // unless the class said otherwise. if not ExplicitAdditionalProperties and (Properties.Count = 0) then Result.AddPair('additionalProperties', TJSONBool.Create(False)); except diff --git a/src/Protocol/MCPServer.Schema.Validator.pas b/src/Protocol/MCPServer.Schema.Validator.pas index 3108452..8b142f2 100644 --- a/src/Protocol/MCPServer.Schema.Validator.pas +++ b/src/Protocol/MCPServer.Schema.Validator.pas @@ -1,17 +1,5 @@ unit MCPServer.Schema.Validator; -/// A JSON Schema (2020-12) subset validator for hand-written schemas and for -/// checking a tool's structuredContent against its outputSchema. -/// -/// Covers: type (string or array, including "null"), enum, const, required, -/// properties (recursive), additionalProperties (boolean), items -/// (recursive), minimum/maximum, minLength/maxLength, pattern. A same- -/// document "$ref" ("#/$defs/Name" or "#/definitions/Name") is resolved; -/// anything else (a network reference, "#/properties/..." and similar) is a -/// validation error rather than a crash or a silent no-op, since the -/// specification forbids network references. Nesting deeper than -/// MAX_DEPTH is a validation error, not a stack overflow. - interface uses @@ -24,8 +12,6 @@ TMCPSchemaValidator = class public const MAX_DEPTH = 32; - /// True when Instance satisfies Schema; Errors lists every violation - /// found (empty when Result is True). class function Validate(const Schema: TJSONObject; const Instance: TJSONValue; out Errors: TArray): Boolean; private @@ -58,8 +44,6 @@ class procedure TMCPSchemaValidator.AddError(Errors: TStrings; const Path, Messa class function TMCPSchemaValidator.MatchesType(const Instance: TJSONValue; const TypeName: string): Boolean; begin - // TJSONNumber descends from TJSONString, so "string" must exclude it - // explicitly and "integer"/"number" must be checked before it. if TypeName = 'null' then Result := not Assigned(Instance) or (Instance is TJSONNull) else if TypeName = 'boolean' then @@ -126,8 +110,6 @@ class function TMCPSchemaValidator.JsonEquals(A, B: TJSONValue): Boolean; Exit((A is TJSONNumber) and (B is TJSONNumber) and (TJSONNumber(A).AsDouble = TJSONNumber(B).AsDouble)); if (A is TJSONString) or (B is TJSONString) then Exit((A is TJSONString) and (B is TJSONString) and (TJSONString(A).Value = TJSONString(B).Value)); - // Objects and arrays: canonical text is good enough for the schemas this - // server generates or ships with. Result := A.ToJSON = B.ToJSON; end; @@ -213,7 +195,6 @@ class function TMCPSchemaValidator.ValidateNode(const Schema: TJSONObject; const if not CheckType(ResolvedSchema, Instance, TypeError) then begin AddError(Errors, Path, TypeError); - // The wrong JSON kind makes structural checks below meaningless. Exit(False); end; diff --git a/src/Protocol/MCPServer.Serializer.pas b/src/Protocol/MCPServer.Serializer.pas index dd7c25a..8249c3b 100644 --- a/src/Protocol/MCPServer.Serializer.pas +++ b/src/Protocol/MCPServer.Serializer.pas @@ -18,7 +18,6 @@ TMCPSerializer = class class procedure DeserializeObject(Instance: TObject; const Json: TJSONObject); class function DeserializeArray(RttiType: TRttiType; const JsonArray: TJSONArray): TValue; - // Extracted type conversion methods class function ConvertJsonToValue(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; class function ConvertJsonToEnum(const JsonValue: TJSONValue; const RttiType: TRttiType): TValue; class function GetEnumValueNames(const EnumType: TRttiEnumerationType): string; @@ -26,24 +25,20 @@ TMCPSerializer = class class function TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; class function CreateInstanceFromType(const RttiType: TRttiType): TObject; - // Array deserialization helpers class function DeserializeDynamicArray(const DynArrayType: TRttiDynamicArrayType; const JsonArray: TJSONArray): TValue; class function DeserializeGenericList(const ListType: TRttiInstanceType; const JsonArray: TJSONArray): TValue; class function FindAddMethod(const ListType: TRttiInstanceType): TRttiMethod; - // Case-insensitive JSON value lookup class function GetJsonValueCaseInsensitive(const Json: TJSONObject; const PropName: string): TJSONValue; - // Single normalization rule shared by lookup and validation class function NormalizeKey(const Name: string): string; inline; class function IsRequiredProperty(const Prop: TRttiProperty): Boolean; - /// The wire name: [SchemaName] when present, otherwise the lowercased - /// property name, matching the schema generator. - class function GetWireName(const Prop: TRttiProperty): string; public class constructor Create; class destructor Destroy; + class function GetWireName(const Prop: TRttiProperty): string; + class function Deserialize(const Json: TJSONObject): T; class procedure Serialize(Obj: TObject; Json: TJSONObject); @@ -137,7 +132,6 @@ class procedure TMCPSerializer.DeserializeObject(Instance: TObject; const Json: JsonValue := GetJsonValueCaseInsensitive(Json, GetWireName(RttiProp)); - // Absent and null both mean "not given"; a required parameter must be given. if not Assigned(JsonValue) or (JsonValue is TJSONNull) then begin if IsRequiredProperty(RttiProp) then @@ -196,9 +190,9 @@ class procedure TMCPSerializer.Serialize(Obj: TObject; Json: TJSONObject); {$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; @@ -222,12 +216,10 @@ class function TMCPSerializer.ConvertJsonToValue(const JsonValue: TJSONValue; co NestedInstance: TObject; begin Result := TValue.Empty; - + if not Assigned(JsonValue) then Exit; - - // Values must have the JSON type the schema advertises; a mismatch is an - // argument error the tool reports as isError, so the model can correct it. + case RttiType.TypeKind of tkInteger, tkInt64: begin @@ -357,12 +349,12 @@ class function TMCPSerializer.CreateInstanceFromType(const RttiType: TRttiType): MetaClass: TClass; begin Result := nil; - + if RttiType is TRttiInstanceType then begin InstanceType := TRttiInstanceType(RttiType); MetaClass := InstanceType.MetaclassType; - + if Assigned(MetaClass) then Result := MetaClass.Create; end; @@ -375,8 +367,6 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti begin Result := nil; - // Empty means nil for objects and [] for dynamic arrays; both are worth - // writing so the JSON has the property the schema advertises. if Value.IsEmpty then begin case RttiType.TypeKind of @@ -408,14 +398,12 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti if RttiType.Handle = TypeInfo(Boolean) then Result := TJSONBool.Create(Value.AsBoolean) else - Result := TJSONString.Create(GetEnumName(RttiType.Handle, Value.AsOrdinal)); + Result := TJSONString.Create(GetEnumName(RttiType.Handle, Integer(Value.AsOrdinal))); tkSet: begin - // Every included element by its enum name. var Names := TJSONArray.Create; var ElementType := TRttiEnumerationType(TRttiSetType(RttiType).ElementType); - // A set is stored from the byte that holds its lowest element. var SetBits: Int64 := 0; Move(Value.GetReferenceToRawData^, SetBits, Min(Value.DataSize, SizeOf(SetBits))); var FirstBit := ElementType.MinValue and not 7; @@ -461,9 +449,6 @@ class function TMCPSerializer.ConvertValueToJson(const Value: TValue; const Rtti end; end; -// Serialises TList and TObjectList (anything with an integer-indexed -// Items property and a Count) as a JSON array of their elements. Without -// this a list came out as an object with count and capacity members. class function TMCPSerializer.TrySerializeList(Obj: TObject; out Json: TJSONValue): Boolean; var ListType: TRttiType; @@ -485,7 +470,6 @@ class function TMCPSerializer.TrySerializeList(Obj: TObject; out Json: TJSONValu or not Assigned(ItemsProp.ReadMethod) then Exit; - // Only integer indexes: TDictionary also has Count and Items. IndexParams := ItemsProp.ReadMethod.GetParameters; if (Length(IndexParams) <> 1) or not (IndexParams[0].ParamType.TypeKind in [tkInteger, tkInt64]) then Exit; @@ -512,10 +496,10 @@ class function TMCPSerializer.TrySerializeList(Obj: TObject; out Json: TJSONValu 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; @@ -534,12 +518,12 @@ class function TMCPSerializer.DeserializeDynamicArray(const DynArrayType: TRttiD Result := TValue.Empty; TValue.Make(nil, DynArrayType.Handle, Result); DynArraySetLength(PPointer(Result.GetReferenceToRawData)^, Result.TypeInfo, 1, @ArrayLength); - + for I := 0 to ArrayLength - 1 do begin JsonElement := JsonArray.Items[Integer(I)]; ElementValue := ConvertJsonToValue(JsonElement, ElementType); - + if not ElementValue.IsEmpty then Result.SetArrayElement(I, ElementValue); end; @@ -555,25 +539,25 @@ class function TMCPSerializer.DeserializeGenericList(const ListType: TRttiInstan ParamType: TRttiType; begin ListInstance := ListType.MetaclassType.Create; - + AddMethod := FindAddMethod(ListType); if not Assigned(AddMethod) then begin ListInstance.Free; Exit(TValue.Empty); end; - + ParamType := AddMethod.GetParameters[0].ParamType; - + for I := 0 to JsonArray.Count - 1 do begin JsonElement := JsonArray.Items[I]; ElementValue := ConvertJsonToValue(JsonElement, ParamType); - + if not ElementValue.IsEmpty then AddMethod.Invoke(ListInstance, [ElementValue]); end; - + Result := ListInstance; end; @@ -582,7 +566,7 @@ class function TMCPSerializer.FindAddMethod(const ListType: TRttiInstanceType): Method: TRttiMethod; begin Result := nil; - + for Method in ListType.GetMethods do begin if SameText(Method.Name, 'Add') and (Length(Method.GetParameters) = 1) then diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 6b023ca..3e2a825 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -9,44 +9,35 @@ interface System.Generics.Collections; const - /// Protocol version answered by the initialize handshake. Kept under its - /// historic name for library consumers. MCP_PROTOCOL_VERSION = '2025-06-18'; - // Protocol revisions 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'; - /// Newest revision this server targets (stateless, per-request _meta). MCP_LATEST_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2026_07_28; - /// Newest revision served through the initialize handshake. MCP_LATEST_LEGACY_PROTOCOL_VERSION = MCP_PROTOCOL_VERSION_2025_11_25; MCP_LEGACY_PROTOCOL_VERSIONS: array[0..1] of string = ( - MCP_PROTOCOL_VERSION_2025_06_18, - MCP_PROTOCOL_VERSION_2025_11_25 + 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 ); - // 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; - // MCP error codes reserved by the specification (basic/index.mdx, "Error Codes") MCP_ERROR_HEADER_MISMATCH = -32020; MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY = -32021; MCP_ERROR_UNSUPPORTED_PROTOCOL_VERSION = -32022; - /// Resource not found in 2025-11-25 and earlier; 2026-07-28 uses JSONRPC_INVALID_PARAMS. MCP_ERROR_RESOURCE_NOT_FOUND_LEGACY = -32002; - // Reserved _meta keys (2026-07-28) MCP_META_PROTOCOL_VERSION = 'io.modelcontextprotocol/protocolVersion'; MCP_META_CLIENT_CAPABILITIES = 'io.modelcontextprotocol/clientCapabilities'; MCP_META_CLIENT_INFO = 'io.modelcontextprotocol/clientInfo'; @@ -58,12 +49,9 @@ interface MCP_METHOD_NOTIFICATIONS_CANCELLED = 'notifications/cancelled'; MCP_METHOD_NOTIFICATIONS_PROGRESS = 'notifications/progress'; - // Cache scopes (server/utilities/caching.mdx) MCP_CACHE_SCOPE_PUBLIC = 'public'; MCP_CACHE_SCOPE_PRIVATE = 'private'; - /// Methods whose complete results must carry ttlMs and cacheScope - /// (server/utilities/caching.mdx, "Cacheable Results"). MCP_CACHEABLE_METHODS: array[0..5] of string = ( 'server/discover', 'tools/list', @@ -75,8 +63,6 @@ interface function IsLegacyProtocolVersion(const Version: string): Boolean; function IsModernProtocolVersion(const Version: string): Boolean; -/// The revision answered to an initialize request: the requested one when it -/// is served, otherwise the newest legacy revision. function NegotiateLegacyProtocolVersion(const Requested: string): string; type @@ -91,7 +77,6 @@ SchemaDescriptionAttribute = class(TCustomAttribute) property Description: string read FDescription; end; - /// Human-readable title of a parameter (JSON Schema "title"). SchemaTitleAttribute = class(TCustomAttribute) private FTitle: string; @@ -100,7 +85,6 @@ SchemaTitleAttribute = class(TCustomAttribute) property Title: string read FTitle; end; - /// JSON Schema "format" of a string parameter, for example 'date-time' or 'uri'. SchemaFormatAttribute = class(TCustomAttribute) private FFormat: string; @@ -109,7 +93,6 @@ SchemaFormatAttribute = class(TCustomAttribute) property Format: string read FFormat; end; - /// JSON Schema "minimum" of a numeric parameter. SchemaMinimumAttribute = class(TCustomAttribute) private FMinimum: Double; @@ -118,7 +101,6 @@ SchemaMinimumAttribute = class(TCustomAttribute) property Minimum: Double read FMinimum; end; - /// JSON Schema "maximum" of a numeric parameter. SchemaMaximumAttribute = class(TCustomAttribute) private FMaximum: Double; @@ -139,7 +121,6 @@ SchemaEnumAttribute = class(TCustomAttribute) property Values: TArray read FValues; end; - /// JSON Schema "minLength" of a string parameter. SchemaMinLengthAttribute = class(TCustomAttribute) private FMinLength: Integer; @@ -148,7 +129,6 @@ SchemaMinLengthAttribute = class(TCustomAttribute) property MinLength: Integer read FMinLength; end; - /// JSON Schema "maxLength" of a string parameter. SchemaMaxLengthAttribute = class(TCustomAttribute) private FMaxLength: Integer; @@ -157,7 +137,6 @@ SchemaMaxLengthAttribute = class(TCustomAttribute) property MaxLength: Integer read FMaxLength; end; - /// JSON Schema "pattern" of a string parameter (an ECMA-262 regex). SchemaPatternAttribute = class(TCustomAttribute) private FPattern: string; @@ -166,8 +145,6 @@ SchemaPatternAttribute = class(TCustomAttribute) property Pattern: string read FPattern; end; - /// JSON Schema "default" of a parameter, given as its JSON text - /// (for example '"red"', '0', 'true'). SchemaDefaultAttribute = class(TCustomAttribute) private FJson: string; @@ -176,8 +153,6 @@ SchemaDefaultAttribute = class(TCustomAttribute) property Json: string read FJson; end; - /// Explicit JSON property name, overriding the default (lowercased - /// property name) the generator and the serializer otherwise use. SchemaNameAttribute = class(TCustomAttribute) private FName: string; @@ -186,8 +161,6 @@ SchemaNameAttribute = class(TCustomAttribute) property Name: string read FName; end; - /// Class-level: forbids properties the schema does not list. Applies to a - /// tool's or prompt's parameter class; default is to allow them. SchemaAdditionalPropertiesAttribute = class(TCustomAttribute) private FAllowed: Boolean; @@ -196,7 +169,6 @@ SchemaAdditionalPropertiesAttribute = class(TCustomAttribute) property Allowed: Boolean read FAllowed; end; - /// Class-level: the JSON Schema dialect ($schema) of a generated schema. SchemaDialectAttribute = class(TCustomAttribute) private FUri: string; @@ -206,44 +178,36 @@ SchemaDialectAttribute = class(TCustomAttribute) 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; - /// Optional view on a manager registry that can list its managers, used to - /// derive the server capabilities. Probed with Supports(). IMCPManagerEnumerator = interface ['{6D1F0B2C-3A4E-4F5B-8C7D-9E0F1A2B3C4D}'] function GetManagers: TArray; end; - /// Implemented by managers that want a reference to the registry they are - /// registered in (TMCPManagerRegistry injects it). Keep the reference weak. IMCPRegistryAware = interface ['{2B7C9D1E-4F6A-4B8C-9D0E-1F2A3B4C5D6E}'] procedure SetManagerRegistry(const Registry: IMCPManagerRegistry); end; {$SCOPEDENUMS ON} - /// Legacy: initialize-based revisions (2025-11-25 and earlier). - /// Modern: per-request _meta revisions (2026-07-28 and later). TMCPProtocolEra = (Legacy, Modern); TMCPRequestIdKind = (None, Null, Text, Number, Invalid); {$SCOPEDENUMS OFF} - /// The JSON-RPC id of a message. None means the member is absent - /// (notification); Invalid covers booleans, objects, arrays and fractions. TMCPRequestId = record Kind: TMCPRequestIdKind; Text: string; @@ -251,33 +215,28 @@ TMCPRequestId = record class function FromJson(const Value: TJSONValue): TMCPRequestId; static; class function FromNumber(const Value: Int64): TMCPRequestId; static; class function FromText(const Value: string): TMCPRequestId; static; - /// True for a string or integer id (a request that must be answered). function IsPresent: Boolean; - /// JSON value for the response; null when the id is absent or invalid. function ToJson: TJSONValue; function AsText: string; end; - /// Per-process legacy state for stdio: the protocol version negotiated by - /// the last initialize. Empty until an initialize has been answered. TMCPLegacySession = class private FProtocolVersion: string; + FLock: TObject; + function GetProtocolVersion: string; + procedure SetProtocolVersion(const Value: string); public - property ProtocolVersion: string read FProtocolVersion write FProtocolVersion; + constructor Create; + destructor Destroy; override; + property ProtocolVersion: string read GetProtocolVersion write SetProtocolVersion; end; - /// Where a transport delivers the server-to-client messages that belong to - /// a request in flight (notifications/progress). The stdio transport - /// writes them to stdout; a transport without such a channel passes nil. IMCPMessageSink = interface ['{2B7D4E90-6C1A-4F3B-9E8D-5A0C1B2D3E4F}'] procedure Send(const Json: string); end; - /// What a handler may know about the request it is serving. Built once - /// per request by the JSON-RPC processor and reachable through - /// TMCPRequestContext.Current while the handler runs. IMCPRequestContext = interface ['{7E3A9C1B-5D2F-4A6E-8B0C-3D4E5F6A7B8C}'] function GetEra: TMCPProtocolEra; @@ -292,38 +251,19 @@ TMCPLegacySession = class function GetLegacySession: TMCPLegacySession; function GetManagerRegistry: IMCPManagerRegistry; - /// True when the client declared the capability, given as a dotted path - /// such as 'elicitation' or 'elicitation.form'. Always False for legacy - /// requests (their capabilities are not carried per request). function HasClientCapability(const Path: string): Boolean; - /// Raises EMCPError -32021 when the capability was not declared. procedure RequireClientCapability(const Path: string); - /// True once the client cancelled the request (notifications/cancelled - /// on stdio). function IsCancelled: Boolean; - /// Raises EMCPRequestCancelled when the request was cancelled; the - /// processor then sends no response. Long-running handlers call this - /// between steps. procedure CheckCancelled; - /// Marks the request cancelled. Called by the transport. procedure Cancel; - /// True when the request carries _meta.progressToken. function HasProgressToken: Boolean; - /// Sends notifications/progress for this request when it carries a - /// progress token and the transport can deliver it; otherwise nothing - /// happens. Progress must increase: a value at or below the last one is - /// dropped, and so is a notification within PROGRESS_MIN_INTERVAL_MS of - /// the previous one unless it reaches Total. Total < 0 means unknown. procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); property Era: TMCPProtocolEra read GetEra; property ProtocolVersion: string read GetProtocolVersion; property Method: string read GetMethod; property RequestId: TMCPRequestId read GetRequestId; - /// The request's _meta object (nil when absent). Owned by the context. property Meta: TJSONObject read GetMeta; - /// io.modelcontextprotocol/clientCapabilities (never nil for modern - /// requests, nil for legacy requests). property ClientCapabilities: TJSONObject read GetClientCapabilities; property ClientInfo: TJSONObject read GetClientInfo; property LogLevel: string read GetLogLevel; @@ -332,36 +272,24 @@ TMCPLegacySession = class property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; end; - /// In-flight bookkeeping a transport keeps so notifications/cancelled can - /// reach the request it names. The processor binds every request context - /// while its handler runs. IMCPRequestTracker = interface ['{8C5E1F2A-3B4D-4E6F-A1B2-C3D4E5F6A7B8}'] - /// Binds the context to its request id for the duration of the handler. - /// A request cancelled before its handler started begins cancelled. procedure Track(const Context: IMCPRequestContext); procedure Untrack(const Context: IMCPRequestContext); - /// Cancels the request with that id; False when it is unknown or done. function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; end; - /// Managers that want the request context receive it through this - /// interface; the processor falls back to IMCPCapabilityManager.ExecuteMethod. IMCPCapabilityManagerEx = interface ['{9F4B2D6A-1C3E-4E5F-A7B8-C9D0E1F2A3B4}'] function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; const Context: IMCPRequestContext): TValue; end; - /// Managers that contribute an entry to the server capabilities - /// (for example "tools": {"listChanged": false}). IMCPCapabilityProvider = interface ['{C5D7E9F1-2A4B-4C6D-8E0F-1A2B3C4D5E6F}'] procedure DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); end; - /// Optional tool metadata for tools/list: annotations (readOnlyHint and - /// friends) and icons. Both may be nil. The tool keeps ownership. IMCPToolMetadata = interface ['{D2E4F6A8-1B3C-4D5E-9F0A-2B3C4D5E6F70}'] function GetAnnotations: TJSONObject; @@ -370,15 +298,11 @@ TMCPLegacySession = class property Icons: TJSONArray read GetIcons; end; - /// Resources whose contents are bytes rather than text; resources/read - /// answers with a Base64 "blob" instead of "text". IMCPBinaryResource = interface ['{E3F5A7B9-2C4D-4E6F-A0B1-3C4D5E6F7081}'] function ReadBinary: TBytes; end; - /// Optional resource metadata for resources/list: title, size in bytes - /// (-1 when unknown) and annotations (may be nil, the resource keeps ownership). IMCPResourceMetadata = interface ['{F4A6B8CA-3D5E-4F70-B1C2-4D5E6F708192}'] function GetTitle: string; @@ -389,9 +313,6 @@ TMCPLegacySession = class property Annotations: TJSONObject read GetAnnotations; end; - /// Cache hints a resource attaches to its resources/read result in the - /// modern era: ttlMs (milliseconds, 0 = immediately stale) and cacheScope - /// ('public' or 'private'). IMCPCacheableResource = interface ['{05B7C9DB-4E6F-4081-C2D3-5E6F708192A3}'] function GetTtlMs: Integer; @@ -400,15 +321,12 @@ TMCPLegacySession = class property CacheScope: string read GetCacheScope; end; - /// Optional icons for prompts/list. May be nil; the prompt keeps ownership. IMCPPromptMetadata = interface ['{16C8DAEC-5F70-4192-D3E4-6F708192A3B4}'] function GetIcons: TJSONArray; property Icons: TJSONArray read GetIcons; end; - /// One suggestion set from completion/complete: at most 100 values, an - /// optional total (-1 when unknown) and whether more exist beyond Values. TMCPCompletion = record Values: TArray; Total: Integer; @@ -416,8 +334,6 @@ TMCPCompletion = record class function Create(const Values: TArray; Total: Integer = -1): TMCPCompletion; static; end; - /// Implemented by a prompt or resource template that offers argument - /// completion; checked with Supports before completion/complete calls it. IMCPCompletable = interface ['{27D9EBFD-6081-42A3-E4F5-708192A3B4C5}'] function Complete(const ArgumentName, Value: string; @@ -485,8 +401,49 @@ TMCPToolsResponse = class property Tools: TArray read FTools write FTools; end; +function IsJsonString(const Value: TJSONValue): Boolean; + implementation +function IsJsonString(const Value: TJSONValue): Boolean; +begin + Result := (Value is TJSONString) and not (Value is TJSONNumber); +end; + +{ TMCPLegacySession } + +constructor TMCPLegacySession.Create; +begin + inherited Create; + FLock := TObject.Create; +end; + +destructor TMCPLegacySession.Destroy; +begin + FLock.Free; + inherited; +end; + +function TMCPLegacySession.GetProtocolVersion: string; +begin + TMonitor.Enter(FLock); + try + Result := FProtocolVersion; + finally + TMonitor.Exit(FLock); + end; +end; + +procedure TMCPLegacySession.SetProtocolVersion(const Value: string); +begin + TMonitor.Enter(FLock); + try + FProtocolVersion := Value; + finally + TMonitor.Exit(FLock); + end; +end; + function IsLegacyProtocolVersion(const Version: string): Boolean; begin for var Known in MCP_LEGACY_PROTOCOL_VERSIONS do @@ -524,7 +481,6 @@ class function TMCPRequestId.FromJson(const Value: TJSONValue): TMCPRequestId; Result.Kind := TMCPRequestIdKind.Null else if Value is TJSONNumber then begin - // Only integers are valid ids; a fraction is not. var Number := TJSONNumber(Value); if Frac(Number.AsDouble) = 0 then begin diff --git a/src/Resources/MCPServer.Resource.Base.pas b/src/Resources/MCPServer.Resource.Base.pas index 4a090e0..f30175e 100644 --- a/src/Resources/MCPServer.Resource.Base.pas +++ b/src/Resources/MCPServer.Resource.Base.pas @@ -8,6 +8,7 @@ interface System.JSON, System.Generics.Collections, System.RegularExpressions, + System.SyncObjs, MCPServer.Types; type @@ -25,13 +26,6 @@ interface property MimeType: string read GetMimeType; end; - /// Resource whose data is a class T serialised as JSON (mime type - /// application/json) or, for other mime types, the string in T's Content - /// property. - /// - /// The protected fields FTitle, FSize (-1 = unknown), FAnnotations (nil), - /// FTtlMs (0) and FCacheScope ('private') have safe defaults; set them in - /// the constructor of a descendant. TMCPResourceBase = class(TInterfacedObject, IMCPResource, IMCPResourceMetadata, IMCPCacheableResource) protected @@ -72,7 +66,6 @@ TResourceContent = class property Text: string read FText write FText; end; - /// Variables captured from a URI matched against a template. TMCPTemplateVars = TDictionary; IMCPResourceTemplate = interface @@ -82,11 +75,7 @@ TResourceContent = class function GetTitle: string; function GetDescription: string; function GetMimeType: string; - /// True when URI matches the template; the captured variables - /// (percent-decoded) are added to Vars. function Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; - /// Builds the resource for a URI already confirmed to match, with its - /// captured variables. function CreateResource(const URI: string; Vars: TMCPTemplateVars): IMCPResource; property UriTemplate: string read GetUriTemplate; @@ -96,19 +85,14 @@ TResourceContent = class property MimeType: string read GetMimeType; end; - /// Resource template matched by URI, RFC 6570 level 1 (simple string - /// expansion, "{var}", one path segment) and a level 2 subset (reserved - /// expansion, "{+var}", matches the rest of the URI including "/"). - /// "{/var}" and "{?var}" are not supported. - /// - /// Set FUriTemplate, FName and the optional FTitle/FDescription/FMimeType - /// in the constructor of a descendant, as with TMCPResourceBase. TMCPResourceTemplateBase = class(TInterfacedObject, IMCPResourceTemplate) strict private - FRegex: TRegEx; + FPattern: string; FVariableNames: TArray; FCompiled: Boolean; + FCompileLock: TCriticalSection; procedure EnsureCompiled; + class function PercentDecode(const Text: string): string; static; class function CompilePattern(const UriTemplate: string; out VariableNames: TArray): string; static; protected FUriTemplate: string; @@ -118,6 +102,7 @@ TMCPResourceTemplateBase = class(TInterfacedObject, IMCPResourceTemplate) FMimeType: string; public constructor Create; virtual; + destructor Destroy; override; function GetUriTemplate: string; function GetName: string; @@ -131,7 +116,6 @@ TMCPResourceTemplateBase = class(TInterfacedObject, IMCPResourceTemplate) implementation uses - System.NetEncoding, MCPServer.Serializer; { TMCPResourceBase } @@ -246,6 +230,37 @@ 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; @@ -281,6 +296,10 @@ class function TMCPResourceTemplateBase.CompilePattern(const UriTemplate: string end; if VarName = '' then raise EArgumentException.CreateFmt('Empty variable name in URI template "%s"', [UriTemplate]); + for var C in VarName do + if not CharInSet(C, ['A'..'Z', 'a'..'z', '0'..'9', '_']) then + raise EArgumentException.CreateFmt('Variable name "%s" in URI template "%s" may only contain letters, digits and underscores', + [VarName, UriTemplate]); Names.Add(VarName); Position := CloseBrace + 1; @@ -303,10 +322,16 @@ class function TMCPResourceTemplateBase.CompilePattern(const UriTemplate: string procedure TMCPResourceTemplateBase.EnsureCompiled; begin - if FCompiled then - Exit; - FRegex := TRegEx.Create(CompilePattern(FUriTemplate, FVariableNames)); - FCompiled := True; + FCompileLock.Enter; + try + if not FCompiled then + begin + FPattern := CompilePattern(FUriTemplate, FVariableNames); + FCompiled := True; + end; + finally + FCompileLock.Leave; + end; end; function TMCPResourceTemplateBase.GetUriTemplate: string; @@ -337,11 +362,11 @@ function TMCPResourceTemplateBase.GetMimeType: string; function TMCPResourceTemplateBase.Matches(const URI: string; Vars: TMCPTemplateVars): Boolean; begin EnsureCompiled; - var Match := FRegex.Match(URI); + var Match := TRegEx.Match(URI, FPattern); Result := Match.Success; if Result then for var VarName in FVariableNames do - Vars.AddOrSetValue(VarName, TNetEncoding.URL.Decode(Match.Groups[VarName].Value)); + Vars.AddOrSetValue(VarName, PercentDecode(Match.Groups[VarName].Value)); end; end. diff --git a/src/Resources/MCPServer.Resource.Logs.pas b/src/Resources/MCPServer.Resource.Logs.pas index f340916..3366155 100644 --- a/src/Resources/MCPServer.Resource.Logs.pas +++ b/src/Resources/MCPServer.Resource.Logs.pas @@ -34,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; @@ -49,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; @@ -64,7 +64,6 @@ TLogsRecentResource = class(TMCPResourceBase) constructor Create; override; end; - /// A single log level, e.g. "logs://INFO"; matched by TLogsByLevelTemplate. TLogsByLevelResource = class(TMCPResourceBase) private FLevel: string; @@ -74,9 +73,6 @@ TLogsByLevelResource = class(TMCPResourceBase) constructor CreateForLevel(const AUri, ALevel: string); reintroduce; end; - /// logs://{level}: the same recent-log data as logs://recent, filtered to - /// one level. Completes the level argument against the levels actually - /// present in the buffer. TLogsByLevelTemplate = class(TMCPResourceTemplateBase, IMCPCompletable) public constructor Create; override; @@ -167,10 +163,9 @@ procedure TLogBuffer.AddLog(const ALevel, AMessage, ACategory: string); {$ELSE} Entry.ThreadID := TThread.CurrentThread.ThreadID; {$ENDIF} - + FLogs.Add(Entry); - - // Remove earliest entries if buffer exceeds maximum capacity + while FLogs.Count > FMaxEntries do begin FLogs[0].Free; @@ -188,11 +183,11 @@ function TLogBuffer.GetLogs(AMaxCount: NativeInt; const ALevel: string): TObject StartIndex: NativeInt; begin Result := TObjectList.Create(True); - + FLock.Acquire; try StartIndex := Max(0, FLogs.Count - AMaxCount); - + for i := StartIndex to FLogs.Count - 1 do begin Entry := FLogs[i]; @@ -221,7 +216,6 @@ constructor TLogsRecentResource.Create; FName := 'Recent Logs'; FDescription := 'Recent log entries from all categories'; FMimeType := 'application/json'; - // Live data: never cache, never share between callers. FTtlMs := 0; FCacheScope := MCP_CACHE_SCOPE_PRIVATE; end; @@ -237,15 +231,12 @@ function TLogsRecentResource.GetResourceData: TLogEntries; Result.Entries.AddRange(Logs); Result.TotalCount := Logs.Count; Result.FilteredCount := Logs.Count; - // GetLogs returns copies in an owning list; Result.Entries owns them - // from here on, otherwise they would be freed twice. Logs.OwnsObjects := False; finally Logs.Free; end; end; - { TLogsByLevelResource } constructor TLogsByLevelResource.CreateForLevel(const AUri, ALevel: string); @@ -319,15 +310,13 @@ function TLogsByLevelTemplate.Complete(const ArgumentName, Value: string; initialization TLogBuffer.FLock := TCriticalSection.Create; - - // Example initialization logs + TLogBuffer.Instance.AddLog('INFO', 'MCP Server started', 'SYSTEM'); TLogBuffer.Instance.AddLog('INFO', 'Resources manager initialized', 'SYSTEM'); TLogBuffer.Instance.AddLog('INFO', 'Tools manager initialized', 'SYSTEM'); TLogBuffer.Instance.AddLog('WARNING', 'Debug mode is enabled', 'CONFIG'); TLogBuffer.Instance.AddLog('INFO', 'Server listening on port 8080', 'SERVER'); - - // Register Logs resources + TMCPRegistry.RegisterResource('logs://recent', function: IMCPResource begin @@ -341,7 +330,7 @@ initialization Result := TLogsByLevelTemplate.Create; end ); - + finalization TLogBuffer.Finalize; diff --git a/src/Resources/MCPServer.Resource.Project.pas b/src/Resources/MCPServer.Resource.Project.pas index 40ac540..0d87f1c 100644 --- a/src/Resources/MCPServer.Resource.Project.pas +++ b/src/Resources/MCPServer.Resource.Project.pas @@ -25,7 +25,7 @@ TProjectInfo = class public constructor Create; destructor Destroy; override; - + property Name: string read FName write FName; property Version: string read FVersion write FVersion; property Description: string read FDescription write FDescription; @@ -59,7 +59,6 @@ TProjectReadmeResource = class(TMCPResourceBase) constructor Create; override; end; - implementation uses @@ -91,7 +90,6 @@ constructor TProjectInfoResource.Create; FName := 'Project Information'; FDescription := 'Basic information about the Delphi MCP Server project'; FMimeType := 'application/json'; - // Static content: an hour of caching, shareable between callers. FTtlMs := PROJECT_RESOURCE_TTL_MS; FCacheScope := MCP_CACHE_SCOPE_PUBLIC; end; @@ -160,7 +158,6 @@ function TProjectReadmeResource.GetResourceData: TTextContent; ''''; end; - initialization TMCPRegistry.RegisterResource('project://info', function: IMCPResource @@ -168,13 +165,13 @@ initialization Result := TProjectInfoResource.Create; end ); - + TMCPRegistry.RegisterResource('project://readme', function: IMCPResource begin Result := TProjectReadmeResource.Create; end ); - + end. \ No newline at end of file diff --git a/src/Resources/MCPServer.Resource.Samples.pas b/src/Resources/MCPServer.Resource.Samples.pas index b6bd283..71ba323 100644 --- a/src/Resources/MCPServer.Resource.Samples.pas +++ b/src/Resources/MCPServer.Resource.Samples.pas @@ -15,8 +15,6 @@ TStaticText = class property Content: string read FContent write FContent; end; - /// A static text resource. The URIs of these sample resources follow the - /// official conformance suite, which reads them by URI. TStaticTextResource = class(TMCPResourceBase) protected function GetResourceData: TStaticText; override; @@ -24,7 +22,6 @@ TStaticTextResource = class(TMCPResourceBase) constructor Create; override; end; - /// A static binary resource (a 1x1 PNG), read through IMCPBinaryResource. TStaticBinaryResource = class(TMCPResourceBase, IMCPBinaryResource) protected function GetResourceData: TStaticText; override; @@ -44,7 +41,6 @@ TTemplateData = class property Data: string read FData write FData; end; - /// test://template/{id}/data, matched by TTemplateDataResourceTemplate. TTemplateDataResource = class(TMCPResourceBase) private FId: string; @@ -106,7 +102,6 @@ constructor TStaticBinaryResource.Create; function TStaticBinaryResource.GetResourceData: TStaticText; begin - // Text reads of a binary resource hand out the Base64 form. Result := TStaticText.Create; Result.Content := SAMPLE_PNG_BASE64; end; diff --git a/src/Resources/MCPServer.Resource.Server.pas b/src/Resources/MCPServer.Resource.Server.pas index 3c51c7b..d46648b 100644 --- a/src/Resources/MCPServer.Resource.Server.pas +++ b/src/Resources/MCPServer.Resource.Server.pas @@ -28,7 +28,6 @@ TServerStatus = class property ActiveConnections: Integer read FActiveConnections write FActiveConnections; end; - TServerStatusResource = class(TMCPResourceBase) private class var FServerStartTime: TDateTime; @@ -40,25 +39,14 @@ TServerStatusResource = class(TMCPResourceBase) function GetResourceData: TServerStatus; override; public constructor Create; override; - /// Resets the start time and the counters. Runs from the unit - /// initialization and again from MCPServer.dpr before a transport starts. class procedure Initialize; - /// Re-registers the resource as server://status and removes the - /// URI registered before. The registry is read once, when - /// TMCPResourcesManager is created, so call this before the managers are - /// built (before TMCPIdHTTPServer.Start or TMCPStdioTransport.Run). class procedure SetNamePrefix(const Prefix: string); - /// Registers server://status (or the prefixed URI). The unit - /// initialization does this once, so the resource is available by default. class procedure RegisterServerStatusResource; - // The counters are updated from every Indy connection thread, so they - // use atomic operations. class procedure IncrementRequestCount; class procedure ConnectionOpened; class procedure ConnectionClosed; end; - implementation uses @@ -69,7 +57,6 @@ implementation System.Classes, MCPServer.Registration; - { TServerStatusResource } class procedure TServerStatusResource.Initialize; @@ -114,7 +101,6 @@ class procedure TServerStatusResource.ConnectionOpened; class procedure TServerStatusResource.ConnectionClosed; begin - // Never below zero, and without a moment in which a reader can see -1. var Current := AtomicCmpExchange(FActiveConnections, 0, 0); while Current > 0 do begin @@ -147,7 +133,7 @@ function TServerStatusResource.GetResourceData: TServerStatus; Result.Uptime := SecondsBetween(Now, FServerStartTime); 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 @@ -155,11 +141,10 @@ 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; diff --git a/src/Server/MCPServer.HttpHeaders.pas b/src/Server/MCPServer.HttpHeaders.pas index c11de8a..35c2fdb 100644 --- a/src/Server/MCPServer.HttpHeaders.pas +++ b/src/Server/MCPServer.HttpHeaders.pas @@ -6,46 +6,29 @@ interface System.SysUtils; type - /// Values of the headers the Streamable HTTP transport mirrors from the - /// body (Mcp-Name, Mcp-Param-*). Header values are visible ASCII; anything - /// else travels Base64-encoded between the sentinels =?base64? and ?=. TMCPHeaderValue = record const SENTINEL_PREFIX = '=?base64?'; const SENTINEL_SUFFIX = '?='; - /// Visible ASCII (0x21 to 0x7E), space and horizontal tab only. class function IsHeaderSafe(const Value: string): Boolean; static; class function IsSentinel(const Value: string): Boolean; static; - /// Strict Base64: alphabet, length a multiple of four, padding only at - /// the end. Returns False on any deviation. class function TryDecodeBase64(const Text: string; out Bytes: TBytes): Boolean; static; - /// Decodes a header value to the string it stands for. A sentinel value - /// is Base64-decoded as UTF-8; a plain value must be header-safe. class function TryDecode(const Value: string; out Decoded: string): Boolean; static; end; TMCPAcceptHeader = record - /// True when one of the comma-separated entries names the media type - /// (parameters ignored, case-insensitive). class function Accepts(const AcceptHeader, MediaType: string): Boolean; static; end; - /// Origin validation for DNS-rebinding protection. TMCPOriginPolicy = record const ALLOW_ALL = '*'; - /// An origin whose host is localhost, 127.0.0.1 or [::1], any port. class function IsLoopback(const Origin: string): Boolean; static; - /// Absent origins and loopback origins pass. Otherwise the origin must be - /// in the allow-list: scheme://host[:port], compared case-insensitively; - /// a ':*' port allows any port; '*' allows everything. 'null' never passes. class function IsAllowed(const Origin: string; const AllowList: TArray): Boolean; static; class function Matches(const Origin, Pattern: string): Boolean; static; end; TMCPJsonLimits = record - /// Nesting depth of objects and arrays in a JSON text, ignoring the - /// contents of strings. Zero for a scalar. class function NestingDepth(const Json: string): Integer; static; end; @@ -66,7 +49,6 @@ class function TMCPHeaderValue.IsHeaderSafe(const Value: string): Boolean; class function TMCPHeaderValue.IsSentinel(const Value: string): Boolean; begin - // The markers are case-sensitive and must appear exactly as shown. Result := (Length(Value) >= Length(SENTINEL_PREFIX) + Length(SENTINEL_SUFFIX)) and Value.StartsWith(SENTINEL_PREFIX, False) and Value.EndsWith(SENTINEL_SUFFIX, False); end; @@ -137,6 +119,16 @@ class function TMCPAcceptHeader.Accepts(const AcceptHeader, MediaType: string): { TMCPOriginPolicy } +function DefaultPortOf(const Scheme: string): string; +begin + if Scheme = 'https' then + Result := '443' + else if Scheme = 'http' then + Result := '80' + else + Result := ''; +end; + procedure SplitOrigin(const Origin: string; out Scheme, Host, Port: string); begin Scheme := ''; @@ -150,7 +142,6 @@ procedure SplitOrigin(const Origin: string; out Scheme, Host, Port: string); Scheme := Rest.Substring(0, SchemeEnd).ToLower; Rest := Rest.Substring(SchemeEnd + 3); - // IPv6 hosts are bracketed; the port follows the closing bracket. var PortStart: Integer; if Rest.StartsWith('[') then begin @@ -195,6 +186,11 @@ class function TMCPOriginPolicy.Matches(const Origin, Pattern: string): Boolean; if (OriginScheme = '') or (PatternScheme = '') then Exit(False); + if (OriginPort = '') then + OriginPort := DefaultPortOf(OriginScheme); + if (PatternPort = '') then + PatternPort := DefaultPortOf(PatternScheme); + Result := (OriginScheme = PatternScheme) and (OriginHost = PatternHost) and ((PatternPort = '*') or (OriginPort = PatternPort)); end; diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index fcc709e..e3a149c 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -30,10 +30,6 @@ interface MCPServer.JsonRpcProcessor; type - /// Streamable HTTP transport on Indy. The request pipeline is: - /// Origin check (403), CORS headers, endpoint check (404), OPTIONS (204), - /// any verb but POST (405), then the JSON-RPC processor decides body and - /// status. Notifications are answered with 202 and an empty body. TMCPIdHTTPServer = class(TComponent) private FHTTPServer: TIdHTTPServer; @@ -72,9 +68,7 @@ TMCPIdHTTPServer = class(TComponent) destructor Destroy; override; procedure Start; procedure Stop; - /// Addresses the server listens on after Start ("ip:port"). function BoundAddresses: TArray; - /// Port after Start; a Settings port of 0 lets the system choose one. property Port: Word read FPort write FPort; property Active: Boolean read FActive; property ManagerRegistry: IMCPManagerRegistry read FManagerRegistry write FManagerRegistry; @@ -236,8 +230,6 @@ procedure TMCPIdHTTPServer.ConfigureBindings; Exit; end; - // No BindAddress: a loopback Host means a local server, anything else is - // reachable at the address the host name resolves to. if SameText(Host, 'localhost') or (Host = LOOPBACK_IPV4) or (Host = LOOPBACK_IPV6) then begin AddBinding(LOOPBACK_IPV4, Id_IPv4); @@ -268,12 +260,10 @@ procedure TMCPIdHTTPServer.ConfigureSSL; end; {$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; TLS 1.2 is the only version offered. FSSLHandler := TIdServerIOHandlerSSLOpenSSL.Create(Self); FSSLHandler.SSLOptions.CertFile := FSettings.SSLCertFile; FSSLHandler.SSLOptions.KeyFile := FSettings.SSLKeyFile; @@ -302,7 +292,6 @@ procedure TMCPIdHTTPServer.HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean) function TMCPIdHTTPServer.HeaderPresent(RequestInfo: TIdHTTPRequestInfo; const Name: string): Boolean; begin - // TIdHeaderList matches names case-insensitively. Result := RequestInfo.RawHeaders.IndexOfName(Name) >= 0; end; @@ -402,7 +391,6 @@ procedure TMCPIdHTTPServer.ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; Res ResponseInfo.CustomHeaders.Values['Access-Control-Allow-Origin'] := Origin; var AllowHeaders := CORS_ALLOW_HEADERS; - // Reflect what a preflight asks for, so Mcp-Param-* headers pass as well. for var Requested in HeaderValue(RequestInfo, 'Access-Control-Request-Headers').Split([',']) do begin var Name := Requested.Trim; @@ -422,8 +410,12 @@ procedure TMCPIdHTTPServer.HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo) try Info.AddPair('url', FSettings.Protocol + '://' + FSettings.Host + ':' + IntToStr(FPort) + FSettings.Endpoint); Info.AddPair('transport', 'streamable-http'); - Info.AddPair('protocolVersions', TJSONArray.Create - .Add(MCP_LATEST_PROTOCOL_VERSION).Add(MCP_PROTOCOL_VERSION_2025_11_25).Add(MCP_PROTOCOL_VERSION_2025_06_18)); + var Versions := TJSONArray.Create; + Info.AddPair('protocolVersions', Versions); + for var Version in MCP_MODERN_PROTOCOL_VERSIONS do + Versions.Add(Version); + for var Version in MCP_LEGACY_PROTOCOL_VERSIONS do + Versions.Add(Version); SendJson(ResponseInfo, HTTP_STATUS_OK, Info.ToJSON); finally Info.Free; @@ -443,8 +435,6 @@ function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); begin - // Never minted; an incoming id is handed back unchanged when it is a - // plausible header value. var SessionId := HeaderValue(RequestInfo, HEADER_SESSION_ID); if (SessionId <> '') and TMCPHeaderValue.IsHeaderSafe(SessionId) and not SessionId.Contains(' ') then ResponseInfo.CustomHeaders.Values[HEADER_SESSION_ID] := SessionId; @@ -511,7 +501,6 @@ procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; Re procedure TMCPIdHTTPServer.SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); begin - // An assigned, empty stream keeps Indy from writing its default HTML body. ResponseInfo.ResponseNo := Status; ResponseInfo.ContentStream := TMemoryStream.Create; ResponseInfo.FreeContentStream := True; @@ -539,7 +528,6 @@ procedure TMCPIdHTTPServer.SendSse(ResponseInfo: TIdHTTPResponseInfo; const Body procedure TMCPIdHTTPServer.SendJsonRpcError(ResponseInfo: TIdHTTPResponseInfo; Status, Code: Integer; const Message: string); begin - // Transport-level rejections carry an error body without an id. var Response := TJSONObject.Create; try Response.AddPair('jsonrpc', '2.0'); diff --git a/src/Server/MCPServer.StdioChannel.pas b/src/Server/MCPServer.StdioChannel.pas index 9a45c99..ecd496e 100644 --- a/src/Server/MCPServer.StdioChannel.pas +++ b/src/Server/MCPServer.StdioChannel.pas @@ -1,10 +1,5 @@ unit MCPServer.StdioChannel; -/// The byte-level side of the stdio transport: one UTF-8 encoded JSON-RPC -/// message per line, LF-delimited, no BOM, and the standard handles as -/// streams. Text I/O is deliberately not used: it decodes stdin with the -/// console code page on Windows and would alter every non-ASCII character. - interface uses @@ -15,17 +10,11 @@ interface type TMCPLineStatus = ( - /// A complete line was decoded. Ok, - /// The line exceeded the limit; it was skipped up to its newline. TooLong, - /// The bytes were not valid UTF-8; the line was skipped. InvalidUtf8 ); - /// Reads LF-delimited UTF-8 lines from a byte stream. A trailing CR is - /// dropped, a leading byte-order mark is ignored, the last line needs no - /// newline. TMCPLineReader = class strict private const READ_CHUNK_BYTES = 64 * 1024; @@ -40,13 +29,9 @@ TMCPLineReader = class function DecodeLine(Start, Count: Integer; out Line: string): TMCPLineStatus; public constructor Create(Stream: TStream; MaxLineBytes: Integer); - /// False at the end of the stream. Status says whether Line is usable. function ReadLine(out Line: string; out Status: TMCPLineStatus): Boolean; end; - /// Writes one message per line, UTF-8 with a bare LF, and serialises - /// concurrent writers so lines never interleave. Any newline inside a - /// message is replaced by a space: the framing does not allow it. TMCPLineWriter = class(TInterfacedObject, IMCPMessageSink) strict private FStream: TStream; @@ -57,7 +42,6 @@ TMCPLineWriter = class(TInterfacedObject, IMCPMessageSink) procedure Send(const Json: string); end; -/// Streams over the process's standard input and output handles. function StandardInputStream: TStream; function StandardOutputStream: TStream; @@ -103,7 +87,6 @@ constructor TMCPLineReader.Create(Stream: TStream; MaxLineBytes: Integer); function TMCPLineReader.Fill: Boolean; begin - // Grow the buffer when a line is longer than a chunk, then append a chunk. if Length(FPending) - FPendingLength < READ_CHUNK_BYTES then SetLength(FPending, Length(FPending) + READ_CHUNK_BYTES); @@ -142,11 +125,9 @@ function TMCPLineReader.DecodeLine(Start, Count: Integer; out Line: string): TMC try Line := TEncoding.UTF8.GetString(FPending, Start, Count); except - // Some malformed sequences raise instead of decoding leniently. Line := ''; Exit(TMCPLineStatus.InvalidUtf8); end; - // The RTL decoder answers an empty string for other malformed input. if (Line = '') and (Count > 0) then Exit(TMCPLineStatus.InvalidUtf8); Result := TMCPLineStatus.Ok; @@ -172,9 +153,37 @@ function TMCPLineReader.ReadLine(out Line: string; out Status: TMCPLineStatus): 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 - // The final line may end without a newline. if FPendingLength = 0 then Exit(False); Status := DecodeLine(0, FPendingLength, Line); diff --git a/src/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index c6f24a5..e66d761 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -1,16 +1,5 @@ unit MCPServer.StdioTransport; -/// The stdio transport: JSON-RPC messages on stdin, one per line, answered -/// on stdout; every log line on stderr. -/// -/// A reader thread (the calling thread of Run) parses each line. Messages -/// without an id and legacy ping are handled on that thread at once, so a -/// notifications/cancelled reaches a request that is still running. Other -/// requests go through a queue to MaxConcurrentRequests worker threads -/// (default 1: responses in request order). A cancelled request gets no -/// response. When stdin closes, queued and running work is drained for -/// ShutdownDrainMs, the rest is cancelled, and Run returns. - interface uses @@ -27,8 +16,6 @@ interface MCPServer.Logger; type - /// The requests a stdio process has accepted and not yet answered, keyed - /// by id, so notifications/cancelled can reach them. TMCPStdioRequestTracker = class(TInterfacedObject, IMCPRequestTracker) strict private type @@ -43,14 +30,11 @@ TEntry = record public constructor Create; destructor Destroy; override; - /// Claims the id when it is read; False when that id is still in flight. function Reserve(const RequestId: TMCPRequestId): Boolean; - /// Drops the claim once the request is answered or refused. procedure Release(const RequestId: TMCPRequestId); procedure Track(const Context: IMCPRequestContext); procedure Untrack(const Context: IMCPRequestContext); function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; - /// Cancels everything still in flight; returns how many there were. function CancelAll(const Reason: string): Integer; end; @@ -70,6 +54,7 @@ TMCPStdioTransport = class FQueue: TThreadedQueue; FWorkersDone: TCountdownEvent; FShutdownDrainMs: Integer; + FWorkerStuck: Boolean; function GetSettings: TMCPSettings; procedure SetSettings(const Value: TMCPSettings); function Hints: TMCPTransportHints; @@ -87,16 +72,9 @@ TMCPStdioTransport = class public constructor Create(ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager); destructor Destroy; override; - /// Serves the process's standard input and output until stdin closes. procedure Run; - /// Serves the given streams until the input ends; what Run does with the - /// standard handles. Both streams stay owned by the caller. procedure RunWith(InputStream, OutputStream: TStream); - /// Server identity and protocol options; assign before Run. Without it the - /// processor uses the defaults (settings.ini next to the executable). property Settings: TMCPSettings read GetSettings write SetSettings; - /// How long Run waits for in-flight requests after stdin closed before - /// cancelling them. Default DEFAULT_SHUTDOWN_DRAIN_MS. property ShutdownDrainMs: Integer read FShutdownDrainMs write FShutdownDrainMs; end; @@ -147,7 +125,6 @@ destructor TMCPStdioRequestTracker.Destroy; class function TMCPStdioRequestTracker.KeyOf(const RequestId: TMCPRequestId): string; begin - // 1 and "1" are different ids. if RequestId.Kind = TMCPRequestIdKind.Number then Result := 'n:' + RequestId.AsText else @@ -192,7 +169,6 @@ procedure TMCPStdioRequestTracker.Track(const Context: IMCPRequestContext); finally FLock.Leave; end; - // The cancellation arrived before the handler started. if CancelNow then Context.Cancel; end; @@ -227,7 +203,7 @@ function TMCPStdioRequestTracker.TryCancel(const RequestId: TMCPRequestId; const if Reason <> '' then TLogger.Info(Format('Request %s cancelled by the client: %s', [RequestId.AsText, Reason])) else - TLogger.Info('Request ' + RequestId.AsText + ' cancelled by the client'); + TLogger.Info(Format('Request %s cancelled by the client', [RequestId.AsText])); end; function TMCPStdioRequestTracker.CancelAll(const Reason: string): Integer; @@ -236,7 +212,7 @@ function TMCPStdioRequestTracker.CancelAll(const Reason: string): Integer; try FLock.Enter; try - Result := FEntries.Count; + Result := Integer(FEntries.Count); for var Key in FEntries.Keys.ToArray do begin var Entry := FEntries[Key]; @@ -270,17 +246,18 @@ constructor TMCPStdioTransport.Create(ManagerRegistry: IMCPManagerRegistry; Core FTrackerIntf := FTracker; FShutdownDrainMs := DEFAULT_SHUTDOWN_DRAIN_MS; - // stdout carries MCP messages only; every log line must go to stderr, - // also for library consumers that never set UseStdErr themselves. TLogger.UseStdErr := True; TLogger.StdoutReserved := True; end; destructor TMCPStdioTransport.Destroy; begin - FJsonRpcProcessor.Free; - FLegacySession.Free; - FTrackerIntf := nil; + if not FWorkerStuck then + begin + FJsonRpcProcessor.Free; + FLegacySession.Free; + FTrackerIntf := nil; + end; inherited; end; @@ -331,8 +308,6 @@ procedure TMCPStdioTransport.ProcessInline(const Message: TJSONValue); procedure TMCPStdioTransport.DispatchLine(const Message: TJSONValue); begin - // Malformed shapes, notifications, client responses and legacy ping are - // answered on the reader thread; every other request is queued. var Queued := False; try if Message is TJSONObject then @@ -388,12 +363,11 @@ procedure TMCPStdioTransport.WorkerLoop; var Message: TJSONValue; begin + var Queue := FQueue; + var Done := FWorkersDone; try - while FQueue.PopItem(Message) = TWaitResult.wrSignaled do + while Queue.PopItem(Message) = TWaitResult.wrSignaled do begin - // A nil sentinel (one per worker, pushed by DrainAndStop) is the - // shutdown signal: everything queued ahead of it is real work and - // gets processed first, since the queue is FIFO. if not Assigned(Message) then Break; try @@ -404,7 +378,7 @@ procedure TMCPStdioTransport.WorkerLoop; end; end; finally - FWorkersDone.Signal; + Done.Signal; end; end; @@ -420,31 +394,27 @@ procedure TMCPStdioTransport.StartWorkers; procedure TMCPStdioTransport.DrainAndStop; begin - // One sentinel per worker: whatever real work is already queued runs - // first (the queue is FIFO), then each worker pops its sentinel and - // stops. No new work is pushed after this point (the reader loop has - // already returned). for var I := 1 to WorkerCount do FQueue.PushItem(nil); - if FWorkersDone.WaitFor(FShutdownDrainMs) <> TWaitResult.wrSignaled then + if FWorkersDone.WaitFor(Cardinal(FShutdownDrainMs)) <> TWaitResult.wrSignaled then begin FTracker.CancelAll('stdin closed'); FWorkersDone.WaitFor(SHUTDOWN_CANCEL_GRACE_MS); end; - // A worker that is still stuck in a handler owns nothing we free here; it - // ends with the process. Once every worker took its sentinel the queue - // holds nothing else, so it is safe to free here. if FWorkersDone.IsSet then begin FWorkersDone.Free; FQueue.Free; + FWorkersDone := nil; + FQueue := nil; end else + begin + FWorkerStuck := True; TLogger.Warning('A request handler did not stop; leaving it to the process exit'); - FWorkersDone := nil; - FQueue := nil; + end; end; procedure TMCPStdioTransport.ReadLoop(InputStream: TStream); @@ -470,7 +440,6 @@ procedure TMCPStdioTransport.ReadLoop(InputStream: TStream); DispatchLine(TJSONObject.ParseJSONValue(Line)); end; except - // Never on stdout: a failure here has no request to answer. on E: Exception do TLogger.Error('Error reading stdio request: ' + E.Message); end; diff --git a/src/Tools/MCPServer.Tool.Base.pas b/src/Tools/MCPServer.Tool.Base.pas index cb80248..6730a92 100644 --- a/src/Tools/MCPServer.Tool.Base.pas +++ b/src/Tools/MCPServer.Tool.Base.pas @@ -16,9 +16,6 @@ interface function GetDescription: string; function GetInputSchema: TJSONObject; function GetOutputSchema: TJSONObject; - /// Returns a string (one text block), a TJSONObject (structured content), - /// a TJSONArray (content blocks) or a TMCPToolResult. The tools manager - /// takes ownership of objects. function Execute(const Arguments: TJSONObject): TValue; property Name: string read GetName; @@ -28,14 +25,6 @@ interface property OutputSchema: TJSONObject read GetOutputSchema; end; - /// Tool with a hand-written schema and raw JSON arguments. - /// - /// The protected fields FAnnotations and FIcons (nil by default) are - /// reported in tools/list when set; the tool owns them. Execute validates - /// Arguments against BuildSchema (raising EArgumentException, which the - /// tools manager reports as an isError result) before calling DoExecute; - /// this is the only validation a hand-written schema gets, since it does - /// not go through TMCPSerializer. TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; @@ -59,11 +48,6 @@ TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) function Execute(const Arguments: TJSONObject): TValue; end; - /// Tool whose parameters are a class T; the schema comes from T's RTTI. - /// - /// Override ExecuteWithParams for a text result, or ExecuteWithContext for - /// any other result (TMCPToolResult, structured content) and access to the - /// request context. The default ExecuteWithContext calls ExecuteWithParams. TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; @@ -88,8 +72,6 @@ TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCP function Execute(const Arguments: TJSONObject): TValue; end; - /// Tool with parameters T and a typed result R that is serialised as - /// structured content (with the compact JSON as text for older clients). TMCPToolBase = class(TInterfacedObject, IMCPTool, IMCPToolMetadata) protected FName: string; @@ -292,7 +274,12 @@ function TMCPToolBase.ExecuteWithContext(const Params: T; const Context: I Response := ExecuteWithParams(Params); try var JsonObj := TJSONObject.Create; - TMCPSerializer.Serialize(Response, JsonObj); + try + TMCPSerializer.Serialize(Response, JsonObj); + except + JsonObj.Free; + raise; + end; Result := TValue.From(JsonObj); finally Response.Free; diff --git a/src/Tools/MCPServer.Tool.Calculate.pas b/src/Tools/MCPServer.Tool.Calculate.pas index c6344ab..b7988cd 100644 --- a/src/Tools/MCPServer.Tool.Calculate.pas +++ b/src/Tools/MCPServer.Tool.Calculate.pas @@ -10,7 +10,7 @@ interface type TOperationType = (otAdd, otSubtract, otMultiply, otDivide); - + TCalculateParams = class private FOperation: string; @@ -20,10 +20,10 @@ TCalculateParams = class [SchemaDescription('Operation: add, subtract, multiply, divide')] [SchemaEnum('add', 'subtract', 'multiply', 'divide')] property Operation: string read FOperation write FOperation; - + [SchemaDescription('First number')] property A: Double read FA write FA; - + [SchemaDescription('Second number')] property B: Double read FB write FB; end; @@ -74,7 +74,7 @@ function TCalculateTool.ExecuteWithParams(const Params: TCalculateParams): strin Result := 'Error: Unknown operation: ' + Params.Operation; Exit; end; - + Result := Format('%s %s %s = %g', [ FloatToStr(Params.A), Params.Operation, FloatToStr(Params.B), ResultValue ]); diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas index 47efe50..e3cc236 100644 --- a/src/Tools/MCPServer.Tool.ContentSamples.pas +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -13,8 +13,6 @@ interface TNoParams = class end; - /// Plain text result. The names of these sample tools follow the official - /// conformance suite, which calls them by name. TSimpleTextTool = class(TMCPToolBase) protected function ExecuteWithParams(const Params: TNoParams): string; override; @@ -22,7 +20,6 @@ TSimpleTextTool = class(TMCPToolBase) constructor Create; override; end; - /// One image block (a 1x1 PNG). TImageContentTool = class(TMCPToolBase) protected function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; @@ -30,7 +27,6 @@ TImageContentTool = class(TMCPToolBase) constructor Create; override; end; - /// One audio block (a silent WAV). TAudioContentTool = class(TMCPToolBase) protected function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; @@ -38,7 +34,6 @@ TAudioContentTool = class(TMCPToolBase) constructor Create; override; end; - /// An embedded text resource. TEmbeddedResourceTool = class(TMCPToolBase) protected function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; @@ -46,7 +41,6 @@ TEmbeddedResourceTool = class(TMCPToolBase) constructor Create; override; end; - /// Text, image and an embedded resource in one result. TMultipleContentTypesTool = class(TMCPToolBase) protected function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; @@ -54,7 +48,6 @@ TMultipleContentTypesTool = class(TMCPToolBase) constructor Create; override; end; - /// Always fails with a tool execution error (isError: true). TProgressToolParams = class private FSteps: Integer; @@ -68,7 +61,6 @@ TProgressToolParams = class property StepMs: Integer read FStepMs write FStepMs; end; - /// Reports progress for every step and stops when the client cancels. TProgressTool = class(TMCPToolBase) public const DEFAULT_STEPS = 5; @@ -89,9 +81,6 @@ TErrorHandlingTool = class(TMCPToolBase) constructor Create; override; end; - /// A hand-written schema exercising the JSON Schema 2020-12 keywords the - /// conformance suite checks for verbatim preservation: $schema, $defs, - /// $anchor, $ref, allOf/anyOf, if/then/else and additionalProperties. TJsonSchema202012Tool = class(TMCPToolBase) protected function BuildSchema: TJSONObject; override; @@ -103,9 +92,7 @@ TJsonSchema202012Tool = class(TMCPToolBase) const SAMPLE_TEXT_RESOURCE_URI = 'test://static-text'; SAMPLE_TEXT_RESOURCE_CONTENT = 'This is the content of the static text resource.'; - /// A 1x1 transparent PNG. SAMPLE_PNG_BASE64 = 'iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mNkYPhfDwAChwGA60e6kgAAAABJRU5ErkJggg=='; - /// A WAV header for 8 kHz mono 8-bit audio with no samples. SAMPLE_WAV_BASE64 = 'UklGRiQAAABXQVZFZm10IBAAAAABAAEAQB8AAEAfAAABAAgAZGF0YQAAAAA='; implementation @@ -230,7 +217,7 @@ function TProgressTool.ExecuteWithContext(const Params: TProgressToolParams; Context.CheckCancelled; Context.ReportProgress(Step - 1, Steps, Format('Step %d of %d', [Step, Steps])); end; - Sleep(StepMs); + Sleep(Cardinal(StepMs)); end; if Assigned(Context) then Context.ReportProgress(Steps, Steps, 'Done'); diff --git a/src/Tools/MCPServer.Tool.ListFiles.pas b/src/Tools/MCPServer.Tool.ListFiles.pas index 8e6e8f3..777d8b8 100644 --- a/src/Tools/MCPServer.Tool.ListFiles.pas +++ b/src/Tools/MCPServer.Tool.ListFiles.pas @@ -19,7 +19,7 @@ TListFilesParams = class public [SchemaDescription('Directory path to list files from')] property Path: string read FPath write FPath; - + [Optional] [SchemaDescription('Include hidden files in the listing')] property IncludeHidden: Boolean read FIncludeHidden write FIncludeHidden; @@ -67,7 +67,7 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin Result := 'Error: Access denied - path outside allowed directory'; Exit; end; - + if TDirectory.Exists(NormalizedPath) then begin FileArray := TDirectory.GetFiles(NormalizedPath); @@ -83,7 +83,7 @@ function TListFilesTool.ExecuteWithParams(const Params: TListFilesParams): strin {$WARN SYMBOL_PLATFORM ON} end; {$ENDIF} - + Files.Add(ExtractFileName(FileName)); end; Result := 'Files in ' + NormalizedPath + ':' + sLineBreak + Files.Text; diff --git a/src/Tools/MCPServer.Tool.Result.pas b/src/Tools/MCPServer.Tool.Result.pas index 01df478..9d7348c 100644 --- a/src/Tools/MCPServer.Tool.Result.pas +++ b/src/Tools/MCPServer.Tool.Result.pas @@ -11,10 +11,6 @@ interface MCPServer.ContentBlocks; type - /// Builds a tools/call result: content blocks of every kind, optional - /// structured content, the error flag and result metadata. A tool returns - /// the instance from Execute (as a TValue); the tools manager serialises it - /// for the era of the request and frees it. TMCPToolResult = class private FContent: TJSONArray; @@ -27,7 +23,6 @@ TMCPToolResult = class destructor Destroy; override; function AddText(const Text: string): TMCPToolResult; - /// Data is the raw content; it is Base64-encoded here. 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; @@ -36,20 +31,14 @@ TMCPToolResult = class const MimeType: string = ''): TMCPToolResult; function AddEmbeddedText(const Uri, MimeType, Text: string): TMCPToolResult; function AddEmbeddedBlob(const Uri, MimeType: string; const Data: TBytes): TMCPToolResult; - /// Annotations for the block added last (audience, priority, lastModified). function WithAnnotations(const Annotations: TJSONObject): TMCPToolResult; - /// Takes ownership. Any JSON value; the initialize-based revisions only - /// carry it when it is an object, and a text block with the compact JSON - /// is added when no other content exists. function SetStructuredContent(const Value: TJSONValue): TMCPToolResult; - /// Takes ownership of the result-level _meta object. 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; - /// The CallToolResult object for the era; the caller owns it. function ToJson(Era: TMCPProtocolEra): TJSONObject; property IsError: Boolean read FIsError write FIsError; @@ -166,7 +155,6 @@ class function TMCPToolResult.Error(const Message: string): TMCPToolResult; function TMCPToolResult.BuildContent(Era: TMCPProtocolEra): TJSONArray; begin Result := TJSONArray(FContent.Clone); - // The schema requires content; structured-only results get the JSON as text. if (Result.Count = 0) and Assigned(FStructuredContent) then begin var Block := TJSONObject.Create; @@ -182,7 +170,6 @@ function TMCPToolResult.ToJson(Era: TMCPProtocolEra): TJSONObject; try Result.AddPair('content', BuildContent(Era)); - // 2025-06-18 and 2025-11-25 define structuredContent as an object only. if Assigned(FStructuredContent) and ((Era = TMCPProtocolEra.Modern) or (FStructuredContent is TJSONObject)) then Result.AddPair('structuredContent', FStructuredContent.Clone as TJSONValue); diff --git a/tests/MCPServer.Tests.Cancellation.pas b/tests/MCPServer.Tests.Cancellation.pas index 72a685b..1998966 100644 --- a/tests/MCPServer.Tests.Cancellation.pas +++ b/tests/MCPServer.Tests.Cancellation.pas @@ -12,7 +12,6 @@ interface MCPServer.Tests.Harness; type - /// Collects what a context sends through the sink. TRecordingSink = class(TInterfacedObject, IMCPMessageSink) private FMessages: TStrings; @@ -21,8 +20,6 @@ TRecordingSink = class(TInterfacedObject, IMCPMessageSink) procedure Send(const Json: string); end; - /// A tracker that cancels every request as soon as it is tracked and - /// records the cancellations it is asked for. TCancellingTracker = class(TInterfacedObject, IMCPRequestTracker) private FCancelOnTrack: Boolean; @@ -268,7 +265,4 @@ procedure TCancellationTests.Processor_CancelledNotification_ReachesTracker; end; end; -initialization - TDUnitX.RegisterTestFixture(TCancellationTests); - end. diff --git a/tests/MCPServer.Tests.Capabilities.pas b/tests/MCPServer.Tests.Capabilities.pas index 7d6f989..9502eac 100644 --- a/tests/MCPServer.Tests.Capabilities.pas +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -25,7 +25,6 @@ implementation MCPServer.Tests.Harness; type - /// A registry that cannot list its managers (a consumer's own implementation). TOpaqueRegistry = class(TInterfacedObject, IMCPManagerRegistry) public procedure RegisterManager(const Manager: IMCPCapabilityManager); @@ -98,7 +97,4 @@ procedure TCapabilityBuilderTests.RegistryWithoutEnumeration_YieldsDefaults; end; end; -initialization - TDUnitX.RegisterTestFixture(TCapabilityBuilderTests); - end. diff --git a/tests/MCPServer.Tests.CompletionManager.pas b/tests/MCPServer.Tests.CompletionManager.pas index b83c24f..bc8d16c 100644 --- a/tests/MCPServer.Tests.CompletionManager.pas +++ b/tests/MCPServer.Tests.CompletionManager.pas @@ -24,6 +24,7 @@ TCompletionManagerTests = class [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; @@ -144,6 +145,25 @@ procedure TCompletionManagerTests.RefResource_UnknownUri_IsNotFound; 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); @@ -194,7 +214,4 @@ procedure TCompletionManagerTests.CapabilitiesInclude_Completions; end; end; -initialization - TDUnitX.RegisterTestFixture(TCompletionManagerTests); - end. diff --git a/tests/MCPServer.Tests.Constants.pas b/tests/MCPServer.Tests.Constants.pas index 57d71f4..1c11c42 100644 --- a/tests/MCPServer.Tests.Constants.pas +++ b/tests/MCPServer.Tests.Constants.pas @@ -6,8 +6,6 @@ interface DUnitX.TestFramework; type - /// Guards the protocol constants in MCPServer.Types and the aliases that - /// keep MCPServer.JsonRpcProcessor.JSONRPC_* compiling for consumers. [TestFixture] TProtocolConstantsTests = class public @@ -17,12 +15,14 @@ TProtocolConstantsTests = class [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; @@ -61,8 +61,8 @@ procedure TProtocolConstantsTests.ProtocolVersions_AreConsistent; Assert.AreEqual('2025-11-25', MCP_LATEST_LEGACY_PROTOCOL_VERSION); Assert.AreEqual(2, Length(MCP_LEGACY_PROTOCOL_VERSIONS)); - Assert.AreEqual(MCP_PROTOCOL_VERSION_2025_06_18, MCP_LEGACY_PROTOCOL_VERSIONS[0]); - Assert.AreEqual(MCP_PROTOCOL_VERSION_2025_11_25, MCP_LEGACY_PROTOCOL_VERSIONS[1]); + 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]); @@ -92,7 +92,20 @@ procedure TProtocolConstantsTests.CacheableMethods_MatchSpec; Assert.AreEqual('resources/read', MCP_CACHEABLE_METHODS[5]); end; -initialization - TDUnitX.RegisterTestFixture(TProtocolConstantsTests); +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 index 156ebca..7f80022 100644 --- a/tests/MCPServer.Tests.Golden.Legacy.pas +++ b/tests/MCPServer.Tests.Golden.Legacy.pas @@ -8,12 +8,6 @@ interface MCPServer.Tests.Golden; type - /// Pins the legacy (initialize-based) wire behaviour of the JSON-RPC layer. - /// - /// Every test replays one file from tests\golden\legacy through a fresh - /// harness and compares the normalised response with the recorded one. - /// A golden file only changes when the wire behaviour changes on purpose; - /// such a change belongs in the CHANGELOG. [TestFixture] TLegacyGoldenTests = class private @@ -25,7 +19,6 @@ TLegacyGoldenTests = class [TearDown] procedure TearDown; - // Lifecycle [Test] procedure Initialize_2025_06_18; [Test] procedure Initialize_2025_11_25; [Test] procedure Initialize_2025_03_26; @@ -34,7 +27,6 @@ TLegacyGoldenTests = class [Test] procedure Notifications_Initialized; [Test] procedure Ping; - // Tools [Test] procedure Tools_List; [Test] procedure Tools_Call_Echo; [Test] procedure Tools_Call_Echo_Unicode; @@ -49,7 +41,6 @@ TLegacyGoldenTests = class [Test] procedure Tools_Call_WithoutParams; [Test] procedure Tools_Call_EmptyName; - // Resources [Test] procedure Resources_List; [Test] procedure Resources_Read_ProjectInfo; [Test] procedure Resources_Read_ProjectReadme; @@ -59,7 +50,6 @@ TLegacyGoldenTests = class [Test] procedure Resources_Read_WithoutParams; [Test] procedure Resources_Templates_List; - // Method and message shape [Test] procedure UnknownMethod; [Test] procedure ServerDiscover_WithoutMeta; [Test] procedure ParseError; @@ -288,7 +278,4 @@ procedure TLegacyGoldenTests.ParamsNotAnObject; CheckGolden('params-not-an-object'); end; -initialization - TDUnitX.RegisterTestFixture(TLegacyGoldenTests); - end. diff --git a/tests/MCPServer.Tests.Golden.Modern.pas b/tests/MCPServer.Tests.Golden.Modern.pas index eae2e0c..d0e6a99 100644 --- a/tests/MCPServer.Tests.Golden.Modern.pas +++ b/tests/MCPServer.Tests.Golden.Modern.pas @@ -8,8 +8,6 @@ interface MCPServer.Tests.Golden; type - /// Pins the wire behaviour for requests that carry per-request _meta - /// (MCP 2026-07-28), replayed through the plain JSON-RPC layer. [TestFixture] TModernGoldenTests = class private @@ -77,7 +75,6 @@ procedure TModernGoldenTests.Server_Discover; procedure TModernGoldenTests.Server_Discover_AfterInitialize; begin - // A legacy handshake on the same process must not latch the server. FHarness.Process(INITIALIZE_REQUEST); CheckGolden('server-discover'); end; @@ -157,7 +154,4 @@ procedure TModernGoldenTests.MissingJsonRpcField; CheckGolden('missing-jsonrpc-field'); end; -initialization - TDUnitX.RegisterTestFixture(TModernGoldenTests); - end. diff --git a/tests/MCPServer.Tests.Golden.pas b/tests/MCPServer.Tests.Golden.pas index 21f0f3d..a4b767e 100644 --- a/tests/MCPServer.Tests.Golden.pas +++ b/tests/MCPServer.Tests.Golden.pas @@ -11,12 +11,6 @@ interface type EGoldenError = class(Exception); - /// Locates the golden directory and exposes the record switch. - /// - /// The golden root is the "golden" folder under "tests". It is found by - /// walking up from the test executable, or taken from the environment - /// variable MCP_GOLDEN_DIR. Setting MCP_GOLDEN_RECORD=1 makes the golden - /// tests overwrite the expected sections instead of comparing. TGoldenFiles = class public const RECORD_ENVIRONMENT_VARIABLE = 'MCP_GOLDEN_RECORD'; @@ -31,15 +25,6 @@ TGoldenFiles = class class function RecordMode: Boolean; end; - /// Replaces known-volatile values in a parsed JSON response so that two - /// runs can be compared byte for byte. - /// - /// A path is a dotted member path with array indexes, for example - /// "result.content[0].text". A pattern may use [*] to match any index. - /// Mask paths are replaced by the placeholder string; shape paths are - /// replaced by their shape (every leaf becomes its JSON type name, and a - /// string that itself contains a JSON document is parsed first). Paths must - /// end at an object member. TGoldenNormalizer = class private class function ReplaceIndexes(const Segment: string): string; @@ -58,15 +43,6 @@ TGoldenNormalizer = class class procedure Normalize(const Root: TJSONValue; const MaskPaths, ShapePaths: TArray); end; - /// One golden case file. Fields: - /// request JSON value sent as the request body, or - /// requestText raw request body for non-JSON input - /// mask optional list of paths replaced by "" - /// shape optional list of paths replaced by their shape - /// workingDirectory optional directory (relative to "tests") made - /// current while the request runs - /// expected normalised JSON response, or - /// expectedText raw response when it is empty or not JSON TGoldenCase = class private FFileName: string; @@ -83,13 +59,8 @@ TGoldenCase = class constructor Create(const AFileName: string); destructor Destroy; override; - /// Applies mask and shape rules to an actual response and returns the - /// formatted text used for comparison. Empty or non-JSON responses are - /// returned unchanged. function NormalizeResponse(const ResponseBody: string): string; - /// The recorded expectation in the same formatted form. function ExpectedText: string; - /// Stores the normalised response as the new expectation and saves the file. procedure RecordExpected(const ResponseBody: string); property FileName: string read FFileName; @@ -100,8 +71,6 @@ TGoldenCase = class TGoldenProcessFunc = reference to function(const RequestBody: string): string; - /// Replays one golden case through the given processing function and - /// compares (or records) the response. TGoldenRunner = class public class procedure Check(const Suite, CaseName: string; const Process: TGoldenProcessFunc); diff --git a/tests/MCPServer.Tests.Harness.pas b/tests/MCPServer.Tests.Harness.pas index 292e4e0..cdf13dc 100644 --- a/tests/MCPServer.Tests.Harness.pas +++ b/tests/MCPServer.Tests.Harness.pas @@ -12,10 +12,6 @@ interface MCPServer.JsonRpcProcessor; type - /// Builds the same manager registry as MCPServer.dpr (core, tools, - /// resources, prompts and completion managers on top of the built-in - /// registrations) and drives the transport-independent JSON-RPC processor - /// directly. TMCPTestHarness = class private FSettings: TMCPSettings; @@ -29,8 +25,6 @@ TMCPTestHarness = class constructor Create; destructor Destroy; override; - /// Sends one JSON-RPC message through the processor and returns the raw - /// response body; an empty string means "no response" (notification). function Process(const RequestBody: string): string; property Settings: TMCPSettings read FSettings; @@ -54,8 +48,6 @@ constructor TMCPTestHarness.Create; begin inherited Create; - // Never create a settings.ini next to the test executable; the defaults are - // the same values the server writes into a fresh settings.ini. FSettings := TMCPSettings.Create('', False); FManagerRegistry := TMCPManagerRegistry.Create; diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index c7ec2c7..adc5f17 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -22,7 +22,6 @@ THttpReply = record function Json: TJSONObject; end; - /// The Streamable HTTP transport, in-process on an ephemeral port. [TestFixture] THttpTransportTests = class private @@ -435,7 +434,6 @@ procedure THttpTransportTests.Bind_DefaultIsLoopback; StartServer; var Addresses := FServer.BoundAddresses; Assert.IsTrue(Length(Addresses) >= 1); - // Indy reports the IPv6 loopback in its expanded form. 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); @@ -466,7 +464,4 @@ procedure THttpTransportTests.EndpointInfoPath_AnswersJson; Assert.AreEqual(404, Send('GET', '/nothing', '', []).Status); end; -initialization - TDUnitX.RegisterTestFixture(THttpTransportTests); - end. diff --git a/tests/MCPServer.Tests.HttpHeaders.pas b/tests/MCPServer.Tests.HttpHeaders.pas index 253ca9b..c098438 100644 --- a/tests/MCPServer.Tests.HttpHeaders.pas +++ b/tests/MCPServer.Tests.HttpHeaders.pas @@ -6,8 +6,6 @@ interface DUnitX.TestFramework; type - /// Header value decoding (Base64 sentinel), Accept parsing, Origin policy - /// and the JSON depth scanner. [TestFixture] THttpHeadersTests = class public @@ -24,6 +22,7 @@ THttpHeadersTests = class [Test] procedure Origin_AbsentAllowed_NullDenied; [Test] procedure Origin_AllowListMatchesSchemeHostAndPort; [Test] procedure Origin_PortWildcardAndAllowAll; + [Test] procedure Origin_DefaultPortEqualsExplicitPort; [Test] procedure NestingDepth_CountsObjectsAndArraysOutsideStrings; end; @@ -146,6 +145,15 @@ procedure THttpHeadersTests.Origin_PortWildcardAndAllowAll; 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.NestingDepth_CountsObjectsAndArraysOutsideStrings; begin Assert.AreEqual(0, TMCPJsonLimits.NestingDepth('"scalar"')); @@ -155,7 +163,4 @@ procedure THttpHeadersTests.NestingDepth_CountsObjectsAndArraysOutsideStrings; Assert.AreEqual(2, TMCPJsonLimits.NestingDepth('{"a":"\"[","b":[1]}')); end; -initialization - TDUnitX.RegisterTestFixture(THttpHeadersTests); - end. diff --git a/tests/MCPServer.Tests.Logger.pas b/tests/MCPServer.Tests.Logger.pas index 701dae5..979e92f 100644 --- a/tests/MCPServer.Tests.Logger.pas +++ b/tests/MCPServer.Tests.Logger.pas @@ -6,8 +6,6 @@ interface DUnitX.TestFramework; type - /// The stdout guard: while a stdio transport runs, console logging must - /// never reach stdout, whatever a consumer sets on TLogger. [TestFixture] TLoggerStdoutGuardTests = class private @@ -109,7 +107,4 @@ procedure TLoggerStdoutGuardTests.StdioTransport_Create_ReservesStdout; end; end; -initialization - TDUnitX.RegisterTestFixture(TLoggerStdoutGuardTests); - end. diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas index 74e38d4..61c883d 100644 --- a/tests/MCPServer.Tests.Processor.pas +++ b/tests/MCPServer.Tests.Processor.pas @@ -14,7 +14,6 @@ interface MCPServer.Tests.Harness; type - /// A manager that records the context it was called with. TProbeManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx) public SeenContext: IMCPRequestContext; @@ -26,7 +25,6 @@ TProbeManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapability const Context: IMCPRequestContext): TValue; end; - /// Status policy, result envelope and dispatch through ProcessRequestEx. [TestFixture] TProcessorTests = class private @@ -102,7 +100,6 @@ function TProbeManager.ExecuteMethodWithContext(const Method: string; const Para procedure TProcessorTests.Setup; begin FHarness := TMCPTestHarness.Create; - // One settings instance for the managers and the processor. FSettings := FHarness.Settings; FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FSettings); end; @@ -165,7 +162,6 @@ procedure TProcessorTests.Modern_MetaValidationError_Is400; procedure TProcessorTests.Modern_ApplicationInvalidParams_Is200; begin - // An error a manager raises without an explicit status stays application level. var Probe := TProbeManager.Create; var Registry: IMCPManagerRegistry := TMCPManagerRegistry.Create; Registry.RegisterManager(Probe); @@ -363,7 +359,4 @@ procedure TProcessorTests.Concurrent_Initialize_AllSucceed; Assert.AreEqual(0, Failures); end; -initialization - TDUnitX.RegisterTestFixture(TProcessorTests); - end. diff --git a/tests/MCPServer.Tests.Prompt.pas b/tests/MCPServer.Tests.Prompt.pas index d1bc439..5a37049 100644 --- a/tests/MCPServer.Tests.Prompt.pas +++ b/tests/MCPServer.Tests.Prompt.pas @@ -202,8 +202,4 @@ procedure TPromptBaseTests.Get_MissingRequiredArgument_Raises; end; end; -initialization - TDUnitX.RegisterTestFixture(TPromptMessagesTests); - TDUnitX.RegisterTestFixture(TPromptBaseTests); - end. diff --git a/tests/MCPServer.Tests.PromptsManager.pas b/tests/MCPServer.Tests.PromptsManager.pas index ec57693..ffa1ebe 100644 --- a/tests/MCPServer.Tests.PromptsManager.pas +++ b/tests/MCPServer.Tests.PromptsManager.pas @@ -210,7 +210,4 @@ procedure TPromptsManagerTests.Get_ResultHasNoCacheHints; end; end; -initialization - TDUnitX.RegisterTestFixture(TPromptsManagerTests); - end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index ef48c15..4acc5a5 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -6,8 +6,6 @@ interface DUnitX.TestFramework; type - /// TMCPRegistry is filled from unit initialization sections; these tests - /// only read it so the golden tests keep seeing the shipped registry. [TestFixture] TRegistryTests = class public @@ -67,7 +65,6 @@ procedure TRegistryTests.BuiltInResourceTemplates_AreRegisteredFromInitializatio procedure TRegistryTests.ServerStatus_IsRegisteredByDefault; begin - // Registered by the initialization section of MCPServer.Resource.Server. var Status := TMCPRegistry.CreateResource('server://status'); Assert.AreEqual('server://status', Status.URI); Assert.AreEqual('server_status', Status.Name); @@ -102,7 +99,4 @@ procedure TRegistryTests.CreateTool_ReturnsFreshInstances; Assert.AreNotSame(First, Second); end; -initialization - TDUnitX.RegisterTestFixture(TRegistryTests); - end. diff --git a/tests/MCPServer.Tests.RequestContext.pas b/tests/MCPServer.Tests.RequestContext.pas index 3242250..942815d 100644 --- a/tests/MCPServer.Tests.RequestContext.pas +++ b/tests/MCPServer.Tests.RequestContext.pas @@ -13,7 +13,6 @@ interface MCPServer.Tests.Harness; type - /// Era detection, one branch per test, straight against BuildRequestContext. [TestFixture] TRequestContextTests = class private @@ -125,8 +124,6 @@ procedure TRequestContextTests.ExpectError(const RequestJson: string; const Hint procedure TRequestContextTests.Initialize_WithModernMeta_IsNotFound; begin - // A modern client probing with initialize must learn that the method does - // not exist in its era; only an initialize without modern _meta is legacy. ExpectError(Request('initialize', '{"protocolVersion":"2025-11-25",' + META_MODERN + '}'), TMCPTransportHints.None, JSONRPC_METHOD_NOT_FOUND, 404, 'initialize is legacy-only'); @@ -180,7 +177,6 @@ procedure TRequestContextTests.ModernMeta_Http_HeaderMatches_IsModern; var Context := Build(Request('tools/list', '{' + META_MODERN + '}'), Hints); Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); - // The mirrored method header is compared case-sensitively. Hints.MethodHeader := 'TOOLS/LIST'; ExpectError(Request('tools/list', '{' + META_MODERN + '}'), Hints, MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Method differs from the body'); @@ -203,7 +199,6 @@ procedure TRequestContextTests.ModernMeta_Http_NameHeader_IsDecodedAndCompared; Hints.NameHeader := 'file:///cafe.txt'; ExpectError(Body, Hints, MCP_ERROR_HEADER_MISMATCH, 400, 'Mcp-Name differs from params.uri'); - // "file:///café.txt" as UTF-8 in the Base64 sentinel form. Hints.NameHeader := '=?base64?ZmlsZTovLy9jYWbDqS50eHQ=?='; var Context := Build(Body, Hints); Assert.AreEqual(TMCPProtocolEra.Modern, Context.Era); @@ -365,7 +360,4 @@ procedure TRequestContextTests.RequireClientCapability_RaisesMissingCapability; end; end; -initialization - TDUnitX.RegisterTestFixture(TRequestContextTests); - end. diff --git a/tests/MCPServer.Tests.ResourcesManager.pas b/tests/MCPServer.Tests.ResourcesManager.pas index c4c9986..bd93874 100644 --- a/tests/MCPServer.Tests.ResourcesManager.pas +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -13,7 +13,6 @@ interface TFailingData = class end; - /// A resource whose read raises. TFailingResource = class(TMCPResourceBase) protected function GetResourceData: TFailingData; override; @@ -28,7 +27,6 @@ TEchoTemplateData = class property Value: string read FValue write FValue; end; - /// A resource matched by TEchoTemplate; echoes the captured variable. TEchoResource = class(TMCPResourceBase) private FValue: string; @@ -38,8 +36,6 @@ TEchoResource = class(TMCPResourceBase) constructor CreateForValue(const AUri, AValue: string); end; - /// echo://{value}, used to test template matching independent of the - /// server's own logs://{level} template. TEchoTemplate = class(TMCPResourceTemplateBase) public constructor Create; override; @@ -70,12 +66,15 @@ TResourcesManagerTests = class [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; end; implementation uses System.SysUtils, + System.Threading, System.Generics.Collections, MCPServer.Errors; @@ -330,6 +329,32 @@ procedure TResourcesManagerTests.Read_ViaTemplate_ResolvesWithActualUri; end; end; +procedure TResourcesManagerTests.Read_ViaTemplate_PercentDecodes_KeepsPlusLiteral; +begin + var Json := Read('echo://a%20b+c%2Fd', TMCPProtocolEra.Modern); + try + Assert.AreEqual('{"value":"a b+c/d"}', Json.GetValue('contents[0].text')); + finally + Json.Free; + end; +end; + +procedure TResourcesManagerTests.Read_ViaTemplate_ConcurrentReads_Succeed; +const + READS = 400; +begin + TParallel.For(1, READS, + procedure(Index: Integer) + begin + var Json := Read(Format('echo://item%d', [Index]), TMCPProtocolEra.Modern); + try + Assert.AreEqual(Format('{"value":"item%d"}', [Index]), Json.GetValue('contents[0].text')); + finally + Json.Free; + end; + end); +end; + procedure TResourcesManagerTests.Read_TemplateMismatch_IsNotFound; begin try @@ -341,7 +366,4 @@ procedure TResourcesManagerTests.Read_TemplateMismatch_IsNotFound; end; end; -initialization - TDUnitX.RegisterTestFixture(TResourcesManagerTests); - end. diff --git a/tests/MCPServer.Tests.Schema.pas b/tests/MCPServer.Tests.Schema.pas index c3ffa91..4705a44 100644 --- a/tests/MCPServer.Tests.Schema.pas +++ b/tests/MCPServer.Tests.Schema.pas @@ -270,7 +270,4 @@ procedure TSchemaGeneratorTests.Dialect_OnlyAppliesAtRoot; end; end; -initialization - TDUnitX.RegisterTestFixture(TSchemaGeneratorTests); - end. diff --git a/tests/MCPServer.Tests.SchemaValidator.pas b/tests/MCPServer.Tests.SchemaValidator.pas index 786d33a..8747c02 100644 --- a/tests/MCPServer.Tests.SchemaValidator.pas +++ b/tests/MCPServer.Tests.SchemaValidator.pas @@ -294,7 +294,4 @@ procedure TSchemaValidatorTests.ExcessiveNesting_IsAnError; end; end; -initialization - TDUnitX.RegisterTestFixture(TSchemaValidatorTests); - end. diff --git a/tests/MCPServer.Tests.Serializer.pas b/tests/MCPServer.Tests.Serializer.pas index 33484c8..cc21dde 100644 --- a/tests/MCPServer.Tests.Serializer.pas +++ b/tests/MCPServer.Tests.Serializer.pas @@ -256,7 +256,4 @@ procedure TSerializerTests.SchemaName_UsedForDeserializeAndSerialize; end; end; -initialization - TDUnitX.RegisterTestFixture(TSerializerTests); - end. diff --git a/tests/MCPServer.Tests.ServerStatus.pas b/tests/MCPServer.Tests.ServerStatus.pas index b710c0a..1df4212 100644 --- a/tests/MCPServer.Tests.ServerStatus.pas +++ b/tests/MCPServer.Tests.ServerStatus.pas @@ -6,8 +6,6 @@ interface DUnitX.TestFramework; type - /// The counters behind server://status are updated from every Indy - /// connection thread; these tests guard the atomic implementation. [TestFixture] TServerStatusResourceTests = class private @@ -123,7 +121,4 @@ procedure TServerStatusResourceTests.Read_ProducesJsonWithStatusFields; end; end; -initialization - TDUnitX.RegisterTestFixture(TServerStatusResourceTests); - end. diff --git a/tests/MCPServer.Tests.Stdio.pas b/tests/MCPServer.Tests.Stdio.pas index 97d11e8..7d93130 100644 --- a/tests/MCPServer.Tests.Stdio.pas +++ b/tests/MCPServer.Tests.Stdio.pas @@ -12,8 +12,6 @@ interface MCPServer.Tests.Harness; type - /// Drives TMCPStdioTransport.RunWith over in-memory streams: the bytes a - /// client would write to stdin in, the bytes it would read from stdout out. [TestFixture] TStdioTransportTests = class private @@ -175,8 +173,6 @@ 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"}']); - // ping is answered inline and is never a duplicate; the second queued - // request with the same id is. Lines := Run([Slow, Slow]); Assert.AreEqual(2, Integer(Length(Lines))); var First := ParseLine(Lines[0]); @@ -262,7 +258,4 @@ procedure TStdioTransportTests.Eof_WithRunningRequest_ReturnsAfterDrain; Assert.IsTrue(FElapsedMs < 3000, 'Run returned after the drain timeout: ' + FElapsedMs.ToString + ' ms'); end; -initialization - TDUnitX.RegisterTestFixture(TStdioTransportTests); - end. diff --git a/tests/MCPServer.Tests.StdioChannel.pas b/tests/MCPServer.Tests.StdioChannel.pas index a19de03..d837b72 100644 --- a/tests/MCPServer.Tests.StdioChannel.pas +++ b/tests/MCPServer.Tests.StdioChannel.pas @@ -20,6 +20,8 @@ TStdioChannelTests = class [Test] procedure Reader_DecodesUtf8; [Test] procedure Reader_ReportsOverlongLine_AndContinues; [Test] procedure Reader_ReportsInvalidUtf8_AndContinues; + [Test] procedure Reader_OverlongLineWithoutNewline_EndsStream; + [Test] procedure Reader_OverlongLineBeyondChunk_IsSkippedUpToNewline; [Test] procedure Reader_EmptyStream_HasNoLines; [Test] procedure Writer_OneLinePerMessage_Utf8_NoBom; [Test] procedure Writer_ReplacesEmbeddedNewlines; @@ -102,6 +104,33 @@ procedure TStdioChannelTests.Reader_ReportsOverlongLine_AndContinues; Assert.AreEqual('short', Lines[1]); end; +procedure TStdioChannelTests.Reader_OverlongLineWithoutNewline_EndsStream; +var + Statuses: TArray; +begin + var Lines := ReadAll(TEncoding.UTF8.GetBytes(StringOfChar('x', 100)), 50, Statuses); + Assert.AreEqual(1, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.AreEqual('', Lines[0]); +end; + +procedure TStdioChannelTests.Reader_OverlongLineBeyondChunk_IsSkippedUpToNewline; +const + BEYOND_ONE_CHUNK = 70 * 1024; + LIMIT = 1024; +var + Statuses: TArray; +begin + var Long := StringOfChar('y', BEYOND_ONE_CHUNK); + var Lines := ReadAll(TEncoding.UTF8.GetBytes(Long + #10'after'#10'last'), LIMIT, Statuses); + Assert.AreEqual(3, Integer(Length(Lines))); + Assert.IsTrue(Statuses[0] = TMCPLineStatus.TooLong); + Assert.IsTrue(Statuses[1] = TMCPLineStatus.Ok); + Assert.AreEqual('after', Lines[1]); + Assert.IsTrue(Statuses[2] = TMCPLineStatus.Ok); + Assert.AreEqual('last', Lines[2]); +end; + procedure TStdioChannelTests.Reader_ReportsInvalidUtf8_AndContinues; var Statuses: TArray; @@ -131,7 +160,7 @@ procedure TStdioChannelTests.Writer_OneLinePerMessage_Utf8_NoBom; var Bytes: TBytes; SetLength(Bytes, Stream.Size); - Move(Stream.Memory^, Bytes[0], 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); @@ -149,7 +178,7 @@ procedure TStdioChannelTests.Writer_ReplacesEmbeddedNewlines; SinkIntf.Send('a'#13#10'b'); var Bytes: TBytes; SetLength(Bytes, Stream.Size); - Move(Stream.Memory^, Bytes[0], Stream.Size); + Move(Stream.Memory^, Bytes[0], Length(Bytes)); Assert.AreEqual('a b'#10, TEncoding.UTF8.GetString(Bytes)); finally Stream.Free; @@ -183,7 +212,7 @@ procedure TStdioChannelTests.Writer_ConcurrentSends_DoNotInterleave; var Bytes: TBytes; SetLength(Bytes, Stream.Size); - Move(Stream.Memory^, Bytes[0], 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 @@ -201,7 +230,4 @@ procedure TStdioChannelTests.Writer_ConcurrentSends_DoNotInterleave; end; end; -initialization - TDUnitX.RegisterTestFixture(TStdioChannelTests); - end. diff --git a/tests/MCPServer.Tests.ToolResult.pas b/tests/MCPServer.Tests.ToolResult.pas index 84b56e4..7edf90c 100644 --- a/tests/MCPServer.Tests.ToolResult.pas +++ b/tests/MCPServer.Tests.ToolResult.pas @@ -152,7 +152,4 @@ procedure TToolResultTests.Base64Blob_HasNoLineBreaks; Assert.IsFalse(Encoded.Contains(#13) or Encoded.Contains(#10)); end; -initialization - TDUnitX.RegisterTestFixture(TToolResultTests); - end. diff --git a/tests/MCPServer.Tests.ToolsManager.pas b/tests/MCPServer.Tests.ToolsManager.pas index ea9d371..db37108 100644 --- a/tests/MCPServer.Tests.ToolsManager.pas +++ b/tests/MCPServer.Tests.ToolsManager.pas @@ -25,7 +25,6 @@ TStructuredOutput = class property Doubled: Integer read FDoubled write FDoubled; end; - /// A typed tool: structured content plus the text fallback. TDoublingTool = class(TMCPToolBase) protected function ExecuteWithParams(const Params: TStructuredParams): TStructuredOutput; override; @@ -33,8 +32,6 @@ TDoublingTool = class(TMCPToolBase) constructor Create; override; end; - /// A hand-written schema, to exercise TMCPToolBase's own validation - /// (nothing goes through TMCPSerializer for this tool). THandWrittenTool = class(TMCPToolBase) protected function BuildSchema: TJSONObject; override; @@ -332,7 +329,4 @@ procedure TToolsManagerTests.HandWrittenTool_WrongType_IsErrorResult; end; end; -initialization - TDUnitX.RegisterTestFixture(TToolsManagerTests); - end. From cb4946407574e3cf79683b89ca61b8e2fb7008bb Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 07:53:43 +0200 Subject: [PATCH 41/56] docs: record the coding conventions this library keeps --- README.md | 2 +- coding-rules.md | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 coding-rules.md diff --git a/README.md b/README.md index abcae03..fe4fc86 100644 --- a/README.md +++ b/README.md @@ -804,7 +804,7 @@ We welcome contributions! Here's how to help: ### Pull Requests 1. Fork the repository 2. Create a feature branch: `git checkout -b feature/my-feature` -3. Follow existing code style (inline vars, named constants) +3. Follow the existing code style (inline vars, named constants, no comments in code); `coding-rules.md` in the repository root lists the conventions this library keeps on purpose 4. Test your changes 5. Submit a pull request diff --git a/coding-rules.md b/coding-rules.md new file mode 100644 index 0000000..0b68ff9 --- /dev/null +++ b/coding-rules.md @@ -0,0 +1,33 @@ +# Coding rules + +This file records where this repository deviates from the GDK Delphi coding standard and why. Everything not listed here follows that standard. + +## Exceptions + +### Registration in `initialization` sections + +Tools, prompts, resources and resource templates register themselves in the `initialization` section of their own unit. Consumers add a unit to their project's `uses` clause and the item is available; that is the public contract of the library and the reason no central registration list exists. New tool, prompt and resource units follow the same pattern. + +### System.Generics.Collections + +The library has no third-party dependencies so that it can be dropped into any Delphi project. `System.Generics.Collections` is used instead of Spring4D collections. + +### Public global functions + +`MCPServer.Types` and a few other units expose global functions (`IsJsonString`, `StandardInputStream`, `StandardOutputStream`) because they are part of the public API and because attribute or record helpers cannot host them. Internal helpers still belong in classes or records. + +### Constructor parameter names in attributes + +Schema attributes and exception classes keep the `A` prefix on constructor parameters where the parameter would otherwise shadow a property of the same class (`Code`, `Message`, `Description`). Elsewhere parameters carry no prefix. + +### Framework callback signatures + +Indy event handlers keep the signature Indy declares, including `var` parameters (for example `OnQuerySSLPort`). + +### DUnitX fixtures + +The test runner uses RTTI discovery (`UseRTTI := True`). Test units have no `initialization` section. + +### Class section markers + +The `{ TClassName }` markers the IDE generates in the implementation section are kept. No other comments are used; behaviour is documented in the README, CHANGELOG and MIGRATION guide. From fe169b7b10deb309b7f52012482a5cbade5f688e Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:07:28 +0200 Subject: [PATCH 42/56] feat: multi round-trip requests with signed request state A tool, resource or prompt raises EMCPInputRequired with the input requests it needs and optional state. The processor answers tools/call, resources/read and prompts/get with an InputRequiredResult, only for the kinds of input the client declared a capability for (-32021 otherwise), and answers -32603 to legacy clients. On the retry it validates inputResponses (-32602 unless an object of objects), opens the sealed requestState (HMAC-SHA256 over state, method, parameter digest, principal and expiry; -32602 when tampered, expired or foreign) and exposes both on the request context. [Security] RequestStateKey and RequestStateTtlSeconds configure the sealer. --- settings.ini.example | 6 + src/Core/MCPServer.Settings.pas | 14 +++ src/MCPServer.dpr | 1 + src/MCPServer.dproj | 1 + src/Managers/MCPServer.ResourcesManager.pas | 3 + src/Managers/MCPServer.ToolsManager.pas | 3 + src/Protocol/MCPServer.JsonRpcProcessor.pas | 121 +++++++++++++++++++- src/Protocol/MCPServer.Mrtr.pas | 64 ++++++++++- src/Protocol/MCPServer.RequestContext.pas | 39 ++++++- src/Protocol/MCPServer.Types.pas | 5 + 10 files changed, 252 insertions(+), 5 deletions(-) diff --git a/settings.ini.example b/settings.ini.example index 8cbde63..c2b6080 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -35,6 +35,12 @@ MaxConcurrentRequests=1 ; any port), for DNS-rebinding protection. Comma-separated scheme://host[:port]; ; ":*" allows any port. Empty = the [CORS] AllowedOrigins list below. AllowedOrigins= +; 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 [Protocol] ; Boolean values: use 1 (true) or 0 (false) diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index 738d22f..4e06d08 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -36,6 +36,8 @@ TMCPSettings = class FMaxConnections: Integer; FMaxConcurrentRequests: Integer; FSecurityAllowedOrigins: string; + FRequestStateKey: string; + FRequestStateTtlSeconds: Integer; function GetProtocol: string; function GetAllowedOrigins: string; @@ -79,10 +81,13 @@ TMCPSettings = class property MaxConcurrentRequests: Integer read FMaxConcurrentRequests write FMaxConcurrentRequests; property SecurityAllowedOrigins: string read FSecurityAllowedOrigins write FSecurityAllowedOrigins; property AllowedOrigins: string read GetAllowedOrigins; + property RequestStateKey: string read FRequestStateKey write FRequestStateKey; + property RequestStateTtlSeconds: Integer read FRequestStateTtlSeconds write FRequestStateTtlSeconds; 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 @@ -144,6 +149,8 @@ procedure TMCPSettings.LoadDefaults; FMaxConcurrentRequests := DEFAULT_MAX_CONCURRENT_REQUESTS; FMaxConnections := 0; FSecurityAllowedOrigins := ''; + FRequestStateKey := ''; + FRequestStateTtlSeconds := DEFAULT_REQUEST_STATE_TTL_SECONDS; end; function TMCPSettings.GetAllowedOrigins: string; @@ -189,6 +196,9 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Security', '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', '; Secret that signs requestState tokens (empty = random per process)', ''); + IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); IniFile.WriteString('Protocol', '; Protocol options (1 = on, 0 = off)', ''); IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); @@ -236,6 +246,8 @@ procedure TMCPSettings.LoadFromFile; FMaxConnections := IniFile.ReadInteger('Server', 'MaxConnections', FMaxConnections); FSecurityAllowedOrigins := IniFile.ReadString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + FRequestStateKey := IniFile.ReadString('Security', 'RequestStateKey', FRequestStateKey); + FRequestStateTtlSeconds := IniFile.ReadInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); FLenientModernPing := IniFile.ReadBool('Protocol', 'LenientModernPing', FLenientModernPing); FDiscoverListsLegacyVersions := IniFile.ReadBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); @@ -288,6 +300,8 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); + IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index ea35a97..6e2808d 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -45,6 +45,7 @@ uses MCPServer.Resource.Logs in 'Resources\MCPServer.Resource.Logs.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.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'; diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index f631626..6f0c7e5 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -160,6 +160,7 @@ + diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index 1dd29a7..c01b0a3 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -63,6 +63,7 @@ implementation MCPServer.Registration, MCPServer.RequestContext, MCPServer.Errors, + MCPServer.Mrtr, MCPServer.ContentBlocks; { TMCPResourcesManager } @@ -329,6 +330,8 @@ function TMCPResourcesManager.ReadResource(const Params: TJSONObject; Era: TMCPP raise; on E: EMCPRequestCancelled do raise; + on E: EMCPInputRequired do + raise; on E: Exception do raise EMCPError.InternalError('Error reading resource: ' + E.Message); end; diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 3d8cba9..19d0b99 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -59,6 +59,7 @@ implementation MCPServer.Registration, MCPServer.RequestContext, MCPServer.Errors, + MCPServer.Mrtr, MCPServer.Tool.Result, MCPServer.Schema.Validator; @@ -253,6 +254,8 @@ function TMCPToolsManager.ExecuteTool(const Tool: IMCPTool; const Arguments: TJS raise; on E: EMCPRequestCancelled do raise; + on E: EMCPInputRequired do + raise; on E: Exception do Exit(ErrorResult('Error executing tool: ' + E.Message, Era)); end; diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index d7b4a67..0be23b8 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -9,6 +9,8 @@ interface MCPServer.Types, MCPServer.Settings, MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.Mrtr, MCPServer.Errors, MCPServer.HttpHeaders, MCPServer.Logger; @@ -27,12 +29,19 @@ TMCPJsonRpcProcessor = class FManagerRegistry: IMCPManagerRegistry; 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 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; @@ -84,6 +93,9 @@ implementation LEGACY_ONLY_METHODS: array[0..4] of string = ( 'ping', 'initialize', 'logging/setLevel', 'resources/subscribe', 'resources/unsubscribe'); MODERN_ONLY_METHODS: array[0..1] of string = ('server/discover', 'subscriptions/listen'); + INPUT_REQUIRED_METHODS: array[0..2] of string = ('tools/call', 'resources/read', 'prompts/get'); + PARAM_INPUT_RESPONSES = 'inputResponses'; + PARAM_REQUEST_STATE = 'requestState'; LOG_LEVELS: array[0..7] of string = ( 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); @@ -111,6 +123,7 @@ constructor TMCPJsonRpcProcessor.Create(ManagerRegistry: IMCPManagerRegistry; Se destructor TMCPJsonRpcProcessor.Destroy; begin + FStateSealer.Free; if FOwnsSettings then FSettings.Free; inherited; @@ -129,6 +142,9 @@ procedure TMCPJsonRpcProcessor.SetSettings(const Value: TMCPSettings); FSettings := TMCPSettings.Create('', False); FOwnsSettings := True; end; + + FreeAndNil(FStateSealer); + FStateSealer := TMCPRequestStateSealer.Create(FSettings.RequestStateKey, FSettings.RequestStateTtlSeconds); end; function TMCPJsonRpcProcessor.SupportedModernVersions: TArray; @@ -171,6 +187,47 @@ function TMCPJsonRpcProcessor.IsCacheableMethod(const Method: string): Boolean; Result := InArray(Method, MCP_CACHEABLE_METHODS); end; +function TMCPJsonRpcProcessor.IsInputRequiredMethod(const Method: string): Boolean; +begin + Result := InArray(Method, INPUT_REQUIRED_METHODS); +end; + +function TMCPJsonRpcProcessor.ClientInputResponses(const Params: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var Value := Params.GetValue(PARAM_INPUT_RESPONSES); + if not Assigned(Value) then + Exit; + if not (Value is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s must be an object', [PARAM_INPUT_RESPONSES])); + + for var Pair in TJSONObject(Value) do + begin + if not (Pair.JsonValue is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s.%s must be an object', [PARAM_INPUT_RESPONSES, Pair.JsonString.Value])); + end; + Result := TJSONObject(Value); +end; + +function TMCPJsonRpcProcessor.OpenClientRequestState(const Method: string; const Params: TJSONObject; + const Hints: TMCPTransportHints): TJSONObject; +begin + Result := nil; + if not Assigned(Params) then + Exit; + + var Value := Params.GetValue(PARAM_REQUEST_STATE); + if not Assigned(Value) then + Exit; + if not IsJsonString(Value) then + raise EMCPError.InvalidParams(Format('params.%s must be a string', [PARAM_REQUEST_STATE])); + + Result := FStateSealer.Open(TJSONString(Value).Value, Method, TMCPRequestStateSealer.DigestOf(Params), Hints.Principal); +end; + function TMCPJsonRpcProcessor.EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; begin if Hints.HasHeaderLayer and Hints.HasProtocolVersionHeader @@ -304,8 +361,15 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa raise NotFound; end; + var InputResponses: TJSONObject := nil; + var RequestState: TJSONObject := nil; + if IsInputRequiredMethod(Method) then + begin + InputResponses := ClientInputResponses(Params); + RequestState := OpenClientRequestState(Method, Params, Hints); + end; Exit(TMCPRequestContext.Create(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry, Hints.Sink)); + Hints.LegacySession, FManagerRegistry, Hints.Sink, InputResponses, RequestState)); end; if Method = 'initialize' then @@ -409,6 +473,54 @@ function TMCPJsonRpcProcessor.CancelledResult(Era: TMCPProtocolEra): TMCPProcess Result.Cancelled := True; end; +function TMCPJsonRpcProcessor.InputRequiredResult(const Context: IMCPRequestContext; const Params: TJSONObject; + const Hints: TMCPTransportHints; const Required: EMCPInputRequired): TMCPProcessResult; +begin + 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 + var Capability := TMCPInputRequests.RequiredCapability(Method); + if Capability = '' then + raise EMCPError.InternalError(Format('%s is not a request a client can answer', [Method])); + Context.RequireClientCapability(Capability); + end; + + var ResultObject := TJSONObject.Create; + try + ResultObject.AddPair('resultType', RESULT_TYPE_INPUT_REQUIRED); + if Required.Requests.Count > 0 then + ResultObject.AddPair('inputRequests', Required.Requests.ToJson); + if Assigned(Required.State) then + ResultObject.AddPair(PARAM_REQUEST_STATE, FStateSealer.Seal(Required.State, Context.Method, + TMCPRequestStateSealer.DigestOf(Params), Hints.Principal)); + ApplyModernEnvelope(ResultObject, Context.Method); + + var Response := TJSONObject.Create; + try + Response.AddPair('jsonrpc', JSONRPC_VERSION); + Response.AddPair('id', Context.RequestId.ToJson); + Response.AddPair('result', TJSONObject(ResultObject.Clone)); + Result.Body := Response.ToJSON; + finally + Response.Free; + end; + finally + ResultObject.Free; + end; + Result.HttpStatus := HTTP_STATUS_OK; + Result.Era := Context.Era; + Result.IsNotification := False; + Result.Cancelled := False; +end; + function TMCPJsonRpcProcessor.BuildErrorResponse(const RequestId: TMCPRequestId; const Error: EMCPError): string; begin Result := ErrorResult(TMCPProtocolEra.Legacy, RequestId, Error).Body; @@ -644,7 +756,12 @@ function TMCPJsonRpcProcessor.ProcessRequestEx(const Message: TJSONValue; if Assigned(Hints.Tracker) then Hints.Tracker.Track(Context); try - ExecuteResult := DispatchRequest(Context, Params); + try + ExecuteResult := DispatchRequest(Context, Params); + except + on E: EMCPInputRequired do + Exit(InputRequiredResult(Context, Params, Hints, E)); + end; finally if Assigned(Hints.Tracker) then Hints.Tracker.Untrack(Context); diff --git a/src/Protocol/MCPServer.Mrtr.pas b/src/Protocol/MCPServer.Mrtr.pas index 1ea6e46..6346be8 100644 --- a/src/Protocol/MCPServer.Mrtr.pas +++ b/src/Protocol/MCPServer.Mrtr.pas @@ -4,7 +4,8 @@ interface uses System.SysUtils, - System.JSON; + System.JSON, + MCPServer.Types; const RESULT_TYPE_INPUT_REQUIRED = 'input_required'; @@ -35,6 +36,13 @@ TMCPInputRequests = class 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; @@ -148,6 +156,60 @@ function TMCPInputRequests.ToJson: TJSONObject; Result := TJSONObject(FRequests.Clone); end; +{ TMCPInputResponse } + +class function TMCPInputResponse.ElicitationContent(const Response: TJSONObject): TJSONObject; +begin + Result := nil; + if not Assigned(Response) then + Exit; + + var Action := Response.GetValue('action'); + var Content := Response.GetValue('content'); + var Accepted := IsJsonString(Action) and (TJSONString(Action).Value = ELICITATION_ACTION_ACCEPT); + if Accepted and (Content is TJSONObject) then + Result := TJSONObject(Content); +end; + +class function TMCPInputResponse.ElicitationField(const Response: TJSONObject; const Field: string): string; +begin + Result := ''; + var Content := ElicitationContent(Response); + if not Assigned(Content) then + Exit; + + var Value := Content.GetValue(Field); + if IsJsonString(Value) then + Result := TJSONString(Value).Value + else if Assigned(Value) and not (Value is TJSONNull) then + Result := Value.ToJSON; +end; + +class function TMCPInputResponse.SamplingText(const Response: TJSONObject): string; +begin + Result := ''; + if not Assigned(Response) then + Exit; + + var Content := Response.GetValue('content'); + if not (Content is TJSONObject) then + Exit; + var Text := TJSONObject(Content).GetValue('text'); + if IsJsonString(Text) then + Result := TJSONString(Text).Value; +end; + +class function TMCPInputResponse.Roots(const Response: TJSONObject): TJSONArray; +begin + Result := nil; + if not Assigned(Response) then + Exit; + + var Value := Response.GetValue('roots'); + if Value is TJSONArray then + Result := TJSONArray(Value); +end; + { EMCPInputRequired } constructor EMCPInputRequired.Create(Requests: TMCPInputRequests; State: TJSONObject); diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas index e64c1bc..622ac47 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -21,6 +21,7 @@ TMCPTransportHints = record HasNameHeader: Boolean; NameHeader: string; RemoteAddress: string; + Principal: string; LegacySession: TMCPLegacySession; Sink: IMCPMessageSink; Tracker: IMCPRequestTracker; @@ -42,6 +43,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) FLegacySession: TMCPLegacySession; FManagerRegistry: IMCPManagerRegistry; FSink: IMCPMessageSink; + FInputResponses: TJSONObject; + FRequestState: TJSONObject; FCancelled: Integer; FProgressSent: Boolean; FLastProgress: Double; @@ -51,7 +54,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) 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 Sink: IMCPMessageSink = nil; const InputResponses: TJSONObject = nil; + const RequestState: TJSONObject = nil); destructor Destroy; override; function GetEra: TMCPProtocolEra; @@ -65,6 +69,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) function GetProgressToken: TJSONValue; function GetLegacySession: TMCPLegacySession; function GetManagerRegistry: IMCPManagerRegistry; + function GetInputResponses: TJSONObject; + function GetRequestState: TJSONObject; function HasClientCapability(const Path: string): Boolean; procedure RequireClientCapability(const Path: string); function IsCancelled: Boolean; @@ -72,6 +78,7 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) 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; class function Current: IMCPRequestContext; class procedure SetCurrent(const Value: IMCPRequestContext); @@ -118,7 +125,8 @@ class function TMCPTransportHints.ForHttp(const HasVersionHeader: Boolean; const 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 ManagerRegistry: IMCPManagerRegistry; const Sink: IMCPMessageSink; const InputResponses: TJSONObject; + const RequestState: TJSONObject); begin inherited Create; FEra := Era; @@ -130,11 +138,16 @@ constructor TMCPRequestContext.Create(Era: TMCPProtocolEra; const ProtocolVersio FLegacySession := LegacySession; FManagerRegistry := ManagerRegistry; FSink := Sink; + if Assigned(InputResponses) then + FInputResponses := TJSONObject(InputResponses.Clone); + FRequestState := RequestState; end; destructor TMCPRequestContext.Destroy; begin FMeta.Free; + FInputResponses.Free; + FRequestState.Free; inherited; end; @@ -212,6 +225,28 @@ function TMCPRequestContext.GetManagerRegistry: IMCPManagerRegistry; Result := FManagerRegistry; end; +function TMCPRequestContext.GetInputResponses: TJSONObject; +begin + Result := FInputResponses; +end; + +function TMCPRequestContext.GetRequestState: TJSONObject; +begin + Result := FRequestState; +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; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 3e2a825..80077e0 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -250,6 +250,8 @@ TMCPLegacySession = class function GetProgressToken: TJSONValue; function GetLegacySession: TMCPLegacySession; function GetManagerRegistry: IMCPManagerRegistry; + function GetInputResponses: TJSONObject; + function GetRequestState: TJSONObject; function HasClientCapability(const Path: string): Boolean; procedure RequireClientCapability(const Path: string); @@ -258,6 +260,7 @@ TMCPLegacySession = class 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; property Era: TMCPProtocolEra read GetEra; property ProtocolVersion: string read GetProtocolVersion; @@ -270,6 +273,8 @@ TMCPLegacySession = class 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; end; IMCPRequestTracker = interface From 1ff1add846391738908af597cf7328d9fc75fbb5 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:07:28 +0200 Subject: [PATCH 43/56] feat: example tools, prompt and tests for multi round-trip requests One example tool per kind of client input, signed request state across one and two round trips, a capability-aware tool, test_missing_capability for the stateless scenario and test_input_required_result_prompt. Tests cover the sealer, the input request builder and readers, and the processor flow in both eras. The 14 input-required conformance scenarios pass and leave the baseline. --- conformance-baseline-2026-07-28.yml | 13 - .../MCPServer.Prompt.ContentSamples.pas | 44 ++ .../MCPServer.Tool.InputRequiredSamples.pas | 444 ++++++++++++ tests/MCPServer.Tests.Mrtr.pas | 676 ++++++++++++++++++ tests/MCPServer.Tests.Registration.pas | 4 +- tests/MCPServerTests.dpr | 2 + tests/MCPServerTests.dproj | 2 + tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/legacy/tools-list.json | 90 +++ tests/golden/modern/tools-list.json | 90 +++ 12 files changed, 1356 insertions(+), 21 deletions(-) create mode 100644 src/Tools/MCPServer.Tool.InputRequiredSamples.pas create mode 100644 tests/MCPServer.Tests.Mrtr.pas diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index d3e7008..aea2510 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -4,16 +4,3 @@ server: - server-stateless - tools-call-with-progress - - input-required-result-basic-elicitation - - input-required-result-basic-sampling - - input-required-result-basic-list-roots - - input-required-result-request-state - - input-required-result-multiple-input-requests - - input-required-result-multi-round - - input-required-result-non-tool-request - - input-required-result-result-type - - input-required-result-tampered-state - - input-required-result-capability-check - # only WARNING checks (MRTR is not implemented, so the tool these call is unknown); the runner counts them as not passed - - input-required-result-missing-input-response - - input-required-result-ignore-extra-params diff --git a/src/Prompts/MCPServer.Prompt.ContentSamples.pas b/src/Prompts/MCPServer.Prompt.ContentSamples.pas index df3a2e7..e3958c4 100644 --- a/src/Prompts/MCPServer.Prompt.ContentSamples.pas +++ b/src/Prompts/MCPServer.Prompt.ContentSamples.pas @@ -57,11 +57,25 @@ TImagePrompt = class(TMCPPromptBase) constructor Create; override; end; + TInputRequiredPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + implementation uses + System.JSON, + MCPServer.Mrtr, + MCPServer.RequestContext, MCPServer.Registration; +const + KEY_USER_CONTEXT = 'user_context'; + FIELD_CONTEXT = 'context'; + { TSimplePrompt } constructor TSimplePrompt.Create; @@ -126,6 +140,31 @@ function TImagePrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPP Result := 'Prompt with image'; end; +{ TInputRequiredPrompt } + +constructor TInputRequiredPrompt.Create; +begin + inherited; + FName := 'test_input_required_result_prompt'; + FDescription := 'Asks the client which context to use before it renders'; +end; + +function TInputRequiredPrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +var + Response: TJSONObject; +begin + var UserContext := ''; + var Context := TMCPRequestContext.Current; + if Assigned(Context) and Context.TryGetInputResponse(KEY_USER_CONTEXT, Response) then + UserContext := TMCPInputResponse.ElicitationField(Response, FIELD_CONTEXT); + if UserContext = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create.AddElicitation(KEY_USER_CONTEXT, + 'What context should the prompt use?', TMCPInputRequests.FieldSchema(FIELD_CONTEXT))); + + Messages.AddText('user', Format('Use this context: %s', [UserContext])); + Result := 'Prompt with client-provided context'; +end; + initialization TMCPRegistry.RegisterPrompt('test_simple_prompt', function: IMCPPrompt @@ -147,5 +186,10 @@ initialization begin Result := TImagePrompt.Create; end); + TMCPRegistry.RegisterPrompt('test_input_required_result_prompt', + function: IMCPPrompt + begin + Result := TInputRequiredPrompt.Create; + end); end. diff --git a/src/Tools/MCPServer.Tool.InputRequiredSamples.pas b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas new file mode 100644 index 0000000..016a947 --- /dev/null +++ b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas @@ -0,0 +1,444 @@ +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; + + TInputSample = record + class function DescribeRoots(const Roots: TJSONArray): string; static; + class function NewState(const Round: Integer): TJSONObject; static; + end; + +implementation + +uses + MCPServer.Mrtr, + MCPServer.Registration, + MCPServer.Tool.Result; + +const + KEY_USER_NAME = 'user_name'; + KEY_CAPITAL_QUESTION = 'capital_question'; + KEY_CLIENT_ROOTS = 'client_roots'; + KEY_CONFIRM = 'confirm'; + KEY_GREETING = 'greeting'; + KEY_STEP1 = 'step1'; + KEY_STEP2 = 'step2'; + FIELD_NAME = 'name'; + FIELD_OK = 'ok'; + FIELD_COLOR = 'color'; + STATE_ROUND = 'round'; + STATE_NAME = 'name'; + STATE_NONCE = 'nonce'; + CAPABILITY_ELICITATION = 'elicitation'; + CAPABILITY_SAMPLING = 'sampling'; + CAPABILITY_ROOTS = 'roots'; + ASK_NAME = 'What is your name?'; + CAPITAL_QUESTION = 'What is the capital of France?'; + SAMPLING_MAX_TOKENS = 100; + GREETING_MAX_TOKENS = 50; + +{ TInputSample } + +class function TInputSample.DescribeRoots(const Roots: TJSONArray): string; +begin + var Uris: TArray := nil; + if Assigned(Roots) then + begin + for var Root in Roots do + begin + if Root is TJSONObject then + Uris := Uris + [TJSONObject(Root).GetValue('uri', '')]; + end; + end; + Result := Format('Roots: %s', [string.Join(', ', Uris)]); +end; + +class function TInputSample.NewState(const Round: Integer): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair(STATE_ROUND, TJSONNumber.Create(Round)); +end; + +{ TElicitationInputTool } + +constructor TElicitationInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_elicitation'; + FDescription := 'Asks the client for a name through an elicitation input request, then greets it'; +end; + +function TElicitationInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Name := ''; + if Context.TryGetInputResponse(KEY_USER_NAME, Response) then + Name := TMCPInputResponse.ElicitationField(Response, FIELD_NAME); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME))); + + Result := TMCPToolResult.Text(Format('Hello, %s!', [Name])); +end; + +{ TSamplingInputTool } + +constructor TSamplingInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_sampling'; + FDescription := 'Asks the client to sample an answer, then returns that answer'; +end; + +function TSamplingInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Answer := ''; + if Context.TryGetInputResponse(KEY_CAPITAL_QUESTION, Response) then + Answer := TMCPInputResponse.SamplingText(Response); + if Answer = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddSampling(KEY_CAPITAL_QUESTION, CAPITAL_QUESTION, SAMPLING_MAX_TOKENS)); + + Result := TMCPToolResult.Text(Format('LLM response: %s', [Answer])); +end; + +{ TListRootsInputTool } + +constructor TListRootsInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_list_roots'; + FDescription := 'Asks the client for its roots, then lists them'; +end; + +function TListRootsInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + if not Context.TryGetInputResponse(KEY_CLIENT_ROOTS, Response) + or not Assigned(TMCPInputResponse.Roots(Response)) then + raise EMCPInputRequired.Create(TMCPInputRequests.Create.AddListRoots(KEY_CLIENT_ROOTS)); + + Result := TMCPToolResult.Text(TInputSample.DescribeRoots(TMCPInputResponse.Roots(Response))); +end; + +{ TRequestStateInputTool } + +constructor TRequestStateInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_request_state'; + FDescription := 'Asks for a confirmation and carries a signed requestState across the round trip'; +end; + +function TRequestStateInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + var HasState := Assigned(Context.RequestState) and Assigned(Context.RequestState.GetValue(STATE_NONCE)); + if not Confirmed or not HasState then + begin + var State := TJSONObject.Create; + State.AddPair(STATE_NONCE, TGUID.NewGuid.ToString); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean')), State); + end; + + Result := TMCPToolResult.Text(Format('state-ok: confirmed with nonce %s', + [Context.RequestState.GetValue(STATE_NONCE)])); +end; + +{ TMultipleInputsTool } + +constructor TMultipleInputsTool.Create; +begin + inherited; + FName := 'test_input_required_result_multiple_inputs'; + FDescription := 'Asks for a name, a sampled greeting and the client roots in one round trip'; +end; + +function TMultipleInputsTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + NameResponse, GreetingResponse, RootsResponse: TJSONObject; +begin + var Complete := Context.TryGetInputResponse(KEY_USER_NAME, NameResponse) + and Context.TryGetInputResponse(KEY_GREETING, GreetingResponse) + and Context.TryGetInputResponse(KEY_CLIENT_ROOTS, RootsResponse) + and Assigned(Context.RequestState); + if not Complete then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME)) + .AddSampling(KEY_GREETING, 'Generate a greeting', GREETING_MAX_TOKENS) + .AddListRoots(KEY_CLIENT_ROOTS), TInputSample.NewState(1)); + + Result := TMCPToolResult.Text(Format('%s, %s! %s', [ + TMCPInputResponse.SamplingText(GreetingResponse), + TMCPInputResponse.ElicitationField(NameResponse, FIELD_NAME), + TInputSample.DescribeRoots(TMCPInputResponse.Roots(RootsResponse))])); +end; + +{ TMultiRoundInputTool } + +constructor TMultiRoundInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_multi_round'; + FDescription := 'Asks for a name and then a colour in two consecutive round trips'; +end; + +function TMultiRoundInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Round := 0; + if Assigned(Context.RequestState) then + Round := Context.RequestState.GetValue(STATE_ROUND, 0); + + if Round < 1 then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP1, 'Step 1: What is your name?', TMCPInputRequests.FieldSchema(FIELD_NAME)), TInputSample.NewState(1)); + + if Round = 1 then + begin + var Name := ''; + if Context.TryGetInputResponse(KEY_STEP1, Response) then + Name := TMCPInputResponse.ElicitationField(Response, FIELD_NAME); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP1, 'Step 1: What is your name?', TMCPInputRequests.FieldSchema(FIELD_NAME)), TInputSample.NewState(1)); + + var State := TInputSample.NewState(2); + State.AddPair(STATE_NAME, Name); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP2, 'Step 2: What is your favorite color?', TMCPInputRequests.FieldSchema(FIELD_COLOR)), State); + end; + + var Color := ''; + if Context.TryGetInputResponse(KEY_STEP2, Response) then + Color := TMCPInputResponse.ElicitationField(Response, FIELD_COLOR); + if Color = '' then + begin + var State := TInputSample.NewState(2); + State.AddPair(STATE_NAME, Context.RequestState.GetValue(STATE_NAME, '')); + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_STEP2, 'Step 2: What is your favorite color?', TMCPInputRequests.FieldSchema(FIELD_COLOR)), State); + end; + + Result := TMCPToolResult.Text(Format('Hello, %s! Your favorite color is %s.', + [Context.RequestState.GetValue(STATE_NAME, ''), Color])); +end; + +{ TTamperedStateInputTool } + +constructor TTamperedStateInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_tampered_state'; + FDescription := 'Asks for a confirmation with a signed requestState that must come back unchanged'; +end; + +function TTamperedStateInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + if not Confirmed or not Assigned(Context.RequestState) then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean')), TInputSample.NewState(1)); + + Result := TMCPToolResult.Text('state-ok: the requestState verified'); +end; + +{ TCapabilityAwareInputTool } + +constructor TCapabilityAwareInputTool.Create; +begin + inherited; + FName := 'test_input_required_result_capabilities'; + FDescription := 'Asks only for the kinds of input the client declared it can provide'; +end; + +function TCapabilityAwareInputTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Answers: TArray := nil; + var Requests := TMCPInputRequests.Create; + try + var Response: TJSONObject; + if Context.HasClientCapability(CAPABILITY_ELICITATION) then + begin + if Context.TryGetInputResponse(KEY_USER_NAME, Response) then + Answers := Answers + [Format('name=%s', [TMCPInputResponse.ElicitationField(Response, FIELD_NAME)])] + else + Requests.AddElicitation(KEY_USER_NAME, ASK_NAME, TMCPInputRequests.FieldSchema(FIELD_NAME)); + end; + if Context.HasClientCapability(CAPABILITY_SAMPLING) then + begin + if Context.TryGetInputResponse(KEY_CAPITAL_QUESTION, Response) then + Answers := Answers + [Format('capital=%s', [TMCPInputResponse.SamplingText(Response)])] + else + Requests.AddSampling(KEY_CAPITAL_QUESTION, CAPITAL_QUESTION, SAMPLING_MAX_TOKENS); + end; + if Context.HasClientCapability(CAPABILITY_ROOTS) then + begin + if Context.TryGetInputResponse(KEY_CLIENT_ROOTS, Response) then + Answers := Answers + [TInputSample.DescribeRoots(TMCPInputResponse.Roots(Response))] + else + Requests.AddListRoots(KEY_CLIENT_ROOTS); + end; + + if Requests.Count > 0 then + begin + var Pending := Requests; + Requests := nil; + raise EMCPInputRequired.Create(Pending); + end; + finally + Requests.Free; + end; + + if Length(Answers) = 0 then + Result := TMCPToolResult.Text('The client declared no capability this tool can ask input through') + else + Result := TMCPToolResult.Text(string.Join('; ', Answers)); +end; + +{ TMissingCapabilityTool } + +constructor TMissingCapabilityTool.Create; +begin + inherited; + FName := 'test_missing_capability'; + FDescription := 'Requires the sampling client capability and fails with -32021 when it is absent'; +end; + +function TMissingCapabilityTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + Context.RequireClientCapability(CAPABILITY_SAMPLING); + Result := TMCPToolResult.Text('The client declared the sampling capability'); +end; + +initialization + TMCPRegistry.RegisterTool('test_input_required_result_elicitation', + function: IMCPTool + begin + Result := TElicitationInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_sampling', + function: IMCPTool + begin + Result := TSamplingInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_list_roots', + function: IMCPTool + begin + Result := TListRootsInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_request_state', + function: IMCPTool + begin + Result := TRequestStateInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_multiple_inputs', + function: IMCPTool + begin + Result := TMultipleInputsTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_multi_round', + function: IMCPTool + begin + Result := TMultiRoundInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_tampered_state', + function: IMCPTool + begin + Result := TTamperedStateInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_input_required_result_capabilities', + function: IMCPTool + begin + Result := TCapabilityAwareInputTool.Create; + end); + TMCPRegistry.RegisterTool('test_missing_capability', + function: IMCPTool + begin + Result := TMissingCapabilityTool.Create; + end); + +end. diff --git a/tests/MCPServer.Tests.Mrtr.pas b/tests/MCPServer.Tests.Mrtr.pas new file mode 100644 index 0000000..f3306fe --- /dev/null +++ b/tests/MCPServer.Tests.Mrtr.pas @@ -0,0 +1,676 @@ +unit MCPServer.Tests.Mrtr; + +interface + +uses + DUnitX.TestFramework, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.RequestState, + MCPServer.JsonRpcProcessor, + MCPServer.Tests.Harness; + +type + [TestFixture] + TRequestStateSealerTests = class + public + [Test] procedure Seal_Open_RoundTripsState; + [Test] procedure Open_TamperedToken_Fails; + [Test] procedure Open_OtherMethodOrDigestOrPrincipal_Fails; + [Test] procedure Open_Expired_Fails; + [Test] procedure Open_OtherKey_Fails; + [Test] procedure DigestOf_IgnoresMetaInputResponsesAndRequestState; + [Test] procedure EmptyKey_IsEphemeral; + end; + + [TestFixture] + TInputRequestsTests = class + public + [Test] procedure ToJson_HasMethodAndParamsPerKey; + [Test] procedure RequiredCapability_PerMethod; + [Test] procedure FieldSchema_IsObjectWithRequiredField; + [Test] procedure InputResponse_Readers; + end; + + [TestFixture] + TInputRequiredFlowTests = class + private + FHarness: TMCPTestHarness; + FProcessor: TMCPJsonRpcProcessor; + function Call(const Method, ParamsJson: string; const Capabilities: string = '{"elicitation":{},"sampling":{},"roots":{"listChanged":true}}'): TJSONObject; + function CallTool(const Name, ExtraParams: string; const Capabilities: string = '{"elicitation":{},"sampling":{},"roots":{"listChanged":true}}'): TJSONObject; + function CallLegacy(const Name: string): TJSONObject; + function ResultText(const Response: TJSONObject): string; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Elicitation_RoundOne_IsInputRequired_WithResultType; + [Test] procedure Elicitation_RoundTwo_Completes; + [Test] procedure Elicitation_WrongKey_ReRequests; + [Test] procedure Elicitation_ExtraKeys_AreIgnored; + [Test] procedure InputResponses_NotObject_IsInvalidParams; + [Test] procedure InputResponses_ValueNotObject_IsInvalidParams; + [Test] procedure Sampling_RoundTrip; + [Test] procedure ListRoots_RoundTrip; + [Test] procedure RequestState_RoundTrip_MentionsStateOk; + [Test] procedure RequestState_Tampered_IsInvalidParams; + [Test] procedure RequestState_OtherTool_IsInvalidParams; + [Test] procedure MultipleInputs_RoundTrip; + [Test] procedure MultiRound_StateChangesPerRound; + [Test] procedure Capabilities_OnlyDeclaredKinds; + [Test] procedure Capabilities_UndeclaredKind_Is32021; + [Test] procedure MissingCapabilityTool_Is32021_WithRequiredCapabilities; + [Test] procedure Legacy_IsInternalError; + [Test] procedure Prompt_RoundTrip; + [Test] procedure ToolsList_IsNeverInputRequired; + end; + +implementation + +uses + System.SysUtils, + System.Classes, + MCPServer.Errors, + MCPServer.Mrtr; + +const + SEALER_KEY = 'unit-test-key'; + DIGEST_A = 'digest-a'; + PRINCIPAL_A = 'alice'; + +{ TRequestStateSealerTests } + +procedure TRequestStateSealerTests.Seal_Open_RoundTripsState; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + var State := TJSONObject.Create; + try + State.AddPair('round', TJSONNumber.Create(2)); + State.AddPair('name', 'Alice'); + var Token := Sealer.Seal(State, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.IsFalse(Token.Contains('='), 'base64url without padding'); + + var Opened := Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A); + try + Assert.AreEqual(2, Opened.GetValue('round')); + Assert.AreEqual('Alice', Opened.GetValue('name')); + finally + Opened.Free; + end; + finally + State.Free; + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_TamperedToken_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + for var Tampered in [Token + '-TAMPERED', Token.Substring(1), 'not.a.token', '', Token.Replace('.', '')] do + begin + Assert.WillRaise( + procedure + begin + Sealer.Open(Tampered, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError, Tampered); + end; + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_OtherMethodOrDigestOrPrincipal_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'prompts/get', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError, 'method'); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', 'digest-b', PRINCIPAL_A).Free; + end, EMCPError, 'digest'); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', DIGEST_A, 'bob').Free; + end, EMCPError, 'principal'); + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_Expired_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY, -5); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError); + finally + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.Open_OtherKey_Fails; +begin + var Sealer := TMCPRequestStateSealer.Create(SEALER_KEY); + var Other := TMCPRequestStateSealer.Create('another-key'); + try + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Assert.WillRaise( + procedure + begin + Other.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + end, EMCPError); + finally + Other.Free; + Sealer.Free; + end; +end; + +procedure TRequestStateSealerTests.DigestOf_IgnoresMetaInputResponsesAndRequestState; +begin + var Plain := TJSONObject.ParseJSONValue('{"name":"t","arguments":{"b":1,"a":[1,2]}}') as TJSONObject; + var Reordered := TJSONObject.ParseJSONValue( + '{"arguments":{"a":[1,2],"b":1},"name":"t","_meta":{"x":1},"inputResponses":{"k":{}},"requestState":"s"}') as TJSONObject; + var Different := TJSONObject.ParseJSONValue('{"name":"t","arguments":{"b":2,"a":[1,2]}}') as TJSONObject; + try + Assert.AreEqual(TMCPRequestStateSealer.DigestOf(Plain), TMCPRequestStateSealer.DigestOf(Reordered)); + Assert.AreNotEqual(TMCPRequestStateSealer.DigestOf(Plain), TMCPRequestStateSealer.DigestOf(Different)); + Assert.AreEqual(TMCPRequestStateSealer.DigestOf(nil), TMCPRequestStateSealer.DigestOf(nil)); + finally + Plain.Free; + Reordered.Free; + Different.Free; + end; +end; + +procedure TRequestStateSealerTests.EmptyKey_IsEphemeral; +begin + var Sealer := TMCPRequestStateSealer.Create(''); + var Fixed := TMCPRequestStateSealer.Create(SEALER_KEY); + try + Assert.IsTrue(Sealer.KeyIsEphemeral); + Assert.IsFalse(Fixed.KeyIsEphemeral); + var Token := Sealer.Seal(nil, 'tools/call', DIGEST_A, PRINCIPAL_A); + Sealer.Open(Token, 'tools/call', DIGEST_A, PRINCIPAL_A).Free; + finally + Fixed.Free; + Sealer.Free; + end; +end; + +{ TInputRequestsTests } + +procedure TInputRequestsTests.ToJson_HasMethodAndParamsPerKey; +begin + var Requests := TMCPInputRequests.Create + .AddElicitation('who', 'Who?', TMCPInputRequests.FieldSchema('name')) + .AddSampling('what', 'What?', 10, 'Be brief') + .AddListRoots('roots'); + try + Assert.AreEqual(3, Requests.Count); + Assert.AreEqual(3, Integer(Length(Requests.Methods))); + var Json := Requests.ToJson; + try + Assert.AreEqual('elicitation/create', Json.GetValue('who.method')); + Assert.AreEqual('form', Json.GetValue('who.params.mode')); + Assert.AreEqual('Who?', Json.GetValue('who.params.message')); + Assert.AreEqual('string', Json.GetValue('who.params.requestedSchema.properties.name.type')); + Assert.AreEqual('sampling/createMessage', Json.GetValue('what.method')); + Assert.AreEqual('What?', Json.GetValue('what.params.messages[0].content.text')); + Assert.AreEqual('Be brief', Json.GetValue('what.params.systemPrompt')); + Assert.AreEqual(10, Json.GetValue('what.params.maxTokens')); + Assert.AreEqual('roots/list', Json.GetValue('roots.method')); + Assert.IsNotNull(Json.FindValue('roots.params')); + finally + Json.Free; + end; + finally + Requests.Free; + end; +end; + +procedure TInputRequestsTests.RequiredCapability_PerMethod; +begin + Assert.AreEqual('elicitation', TMCPInputRequests.RequiredCapability('elicitation/create')); + Assert.AreEqual('sampling', TMCPInputRequests.RequiredCapability('sampling/createMessage')); + Assert.AreEqual('roots', TMCPInputRequests.RequiredCapability('roots/list')); + Assert.AreEqual('', TMCPInputRequests.RequiredCapability('tools/call')); +end; + +procedure TInputRequestsTests.FieldSchema_IsObjectWithRequiredField; +begin + var Schema := TMCPInputRequests.FieldSchema('ok', 'boolean'); + try + Assert.AreEqual('object', Schema.GetValue('type')); + Assert.AreEqual('boolean', Schema.GetValue('properties.ok.type')); + Assert.AreEqual('ok', Schema.GetValue('required[0]')); + finally + Schema.Free; + end; +end; + +procedure TInputRequestsTests.InputResponse_Readers; +begin + var Accepted := TJSONObject.ParseJSONValue('{"action":"accept","content":{"name":"Alice","ok":true}}') as TJSONObject; + var Declined := TJSONObject.ParseJSONValue('{"action":"decline"}') as TJSONObject; + var Sampled := TJSONObject.ParseJSONValue('{"role":"assistant","content":{"type":"text","text":"Paris"}}') as TJSONObject; + var Roots := TJSONObject.ParseJSONValue('{"roots":[{"uri":"file:///r"}]}') as TJSONObject; + try + Assert.AreEqual('Alice', TMCPInputResponse.ElicitationField(Accepted, 'name')); + Assert.AreEqual('true', TMCPInputResponse.ElicitationField(Accepted, 'ok')); + Assert.AreEqual('', TMCPInputResponse.ElicitationField(Accepted, 'missing')); + Assert.IsNull(TMCPInputResponse.ElicitationContent(Declined)); + Assert.AreEqual('', TMCPInputResponse.ElicitationField(nil, 'name')); + Assert.AreEqual('Paris', TMCPInputResponse.SamplingText(Sampled)); + Assert.AreEqual('', TMCPInputResponse.SamplingText(Accepted)); + Assert.AreEqual(1, TMCPInputResponse.Roots(Roots).Count); + Assert.IsNull(TMCPInputResponse.Roots(Sampled)); + finally + Accepted.Free; + Declined.Free; + Sampled.Free; + Roots.Free; + end; +end; + +{ TInputRequiredFlowTests } + +procedure TInputRequiredFlowTests.Setup; +begin + FHarness := TMCPTestHarness.Create; + FHarness.Settings.RequestStateKey := SEALER_KEY; + FProcessor := TMCPJsonRpcProcessor.Create(FHarness.ManagerRegistry, FHarness.Settings); +end; + +procedure TInputRequiredFlowTests.TearDown; +begin + FProcessor.Free; + FHarness.Free; +end; + +function TInputRequiredFlowTests.Call(const Method, ParamsJson: string; const Capabilities: string): TJSONObject; +begin + var Meta := Format('"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":%s}', + [Capabilities]); + var Params := ParamsJson; + if Params = '' then + Params := Meta + else + Params := Params + ',' + Meta; + var Body := Format('{"jsonrpc":"2.0","id":7,"method":"%s","params":{%s}}', [Method, Params]); + var Outcome := FProcessor.ProcessRequestEx(Body, TMCPTransportHints.None); + Result := TJSONObject.ParseJSONValue(Outcome.Body) as TJSONObject; + Assert.IsNotNull(Result, 'response is not a JSON object: ' + Outcome.Body); + Result.AddPair('httpStatus', TJSONNumber.Create(Outcome.HttpStatus)); +end; + +function TInputRequiredFlowTests.CallTool(const Name, ExtraParams: string; const Capabilities: string): TJSONObject; +begin + var Params := Format('"name":"%s","arguments":{}', [Name]); + if ExtraParams <> '' then + Params := Params + ',' + ExtraParams; + Result := Call('tools/call', Params, Capabilities); +end; + +function TInputRequiredFlowTests.CallLegacy(const Name: string): TJSONObject; +begin + var Body := Format('{"jsonrpc":"2.0","id":7,"method":"tools/call","params":{"name":"%s","arguments":{}}}', [Name]); + var Outcome := FProcessor.ProcessRequestEx(Body, TMCPTransportHints.ForHttp(True, '2025-11-25')); + Result := TJSONObject.ParseJSONValue(Outcome.Body) as TJSONObject; + Assert.IsNotNull(Result, 'response is not a JSON object: ' + Outcome.Body); +end; + +function TInputRequiredFlowTests.ResultText(const Response: TJSONObject): string; +begin + Result := Response.GetValue('result.content[0].text', ''); +end; + +procedure TInputRequiredFlowTests.Elicitation_RoundOne_IsInputRequired_WithResultType; +begin + var Response := CallTool('test_input_required_result_elicitation', ''); + try + Assert.AreEqual(200, Response.GetValue('httpStatus')); + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.AreEqual('elicitation/create', Response.GetValue('result.inputRequests.user_name.method')); + Assert.AreEqual('What is your name?', Response.GetValue('result.inputRequests.user_name.params.message')); + Assert.AreEqual('name', Response.GetValue('result.inputRequests.user_name.params.requestedSchema.required[0]')); + Assert.IsNull(Response.FindValue('result.requestState')); + Assert.IsNull(Response.FindValue('result.ttlMs'), 'cache hints only on complete results'); + Assert.IsNotNull((Response.FindValue('result._meta') as TJSONObject).GetValue(MCP_META_SERVER_INFO)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_RoundTwo_Completes; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}}}'); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.AreEqual('Hello, Alice!', ResultText(Response)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_WrongKey_ReRequests; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"wrong_key":{"action":"accept","content":{"data":"wrong"}}}'); + try + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.IsNotNull(Response.FindValue('result.inputRequests.user_name')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Elicitation_ExtraKeys_AreIgnored; +begin + var Response := CallTool('test_input_required_result_elicitation', + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}},"unknown_extra_key":{"action":"accept","content":{}}}'); + try + Assert.AreEqual('Hello, Alice!', ResultText(Response)); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.InputResponses_NotObject_IsInvalidParams; +begin + var Response := CallTool('test_input_required_result_elicitation', '"inputResponses":null'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.InputResponses_ValueNotObject_IsInvalidParams; +begin + var Response := CallTool('test_input_required_result_elicitation', '"inputResponses":{"user_name":12345}'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Response.GetValue('error.code')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Sampling_RoundTrip; +begin + var First := CallTool('test_input_required_result_sampling', ''); + try + Assert.AreEqual('sampling/createMessage', First.GetValue('result.inputRequests.capital_question.method')); + Assert.AreEqual('What is the capital of France?', + First.GetValue('result.inputRequests.capital_question.params.messages[0].content.text')); + Assert.AreEqual(100, First.GetValue('result.inputRequests.capital_question.params.maxTokens')); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_sampling', + '"inputResponses":{"capital_question":{"role":"assistant","content":{"type":"text","text":"Paris"},"model":"m","stopReason":"endTurn"}}'); + try + Assert.AreEqual('LLM response: Paris', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.ListRoots_RoundTrip; +begin + var First := CallTool('test_input_required_result_list_roots', ''); + try + Assert.AreEqual('roots/list', First.GetValue('result.inputRequests.client_roots.method')); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_list_roots', + '"inputResponses":{"client_roots":{"roots":[{"uri":"file:///test/root","name":"Test Root"}]}}'); + try + Assert.AreEqual('Roots: file:///test/root', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_RoundTrip_MentionsStateOk; +begin + var First := CallTool('test_input_required_result_request_state', ''); + var Token := ''; + try + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.confirm.method')); + Assert.AreEqual('boolean', First.GetValue('result.inputRequests.confirm.params.requestedSchema.properties.ok.type')); + Token := First.GetValue('result.requestState'); + Assert.IsTrue(Token <> ''); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_request_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s"', [Token])); + try + Assert.AreEqual('complete', Second.GetValue('result.resultType')); + Assert.IsTrue(ResultText(Second).Contains('state-ok'), ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_Tampered_IsInvalidParams; +begin + var First := CallTool('test_input_required_result_tampered_state', ''); + var Token := ''; + try + Token := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_tampered_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s-TAMPERED"', [Token])); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Second.GetValue('error.code')); + Assert.AreEqual(200, Second.GetValue('httpStatus')); + finally + Second.Free; + end; + + var Third := CallTool('test_input_required_result_tampered_state', + '"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":42'); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Third.GetValue('error.code')); + finally + Third.Free; + end; +end; + +procedure TInputRequiredFlowTests.RequestState_OtherTool_IsInvalidParams; +begin + var First := CallTool('test_input_required_result_request_state', ''); + var Token := ''; + try + Token := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_tampered_state', + Format('"inputResponses":{"confirm":{"action":"accept","content":{"ok":true}}},"requestState":"%s"', [Token])); + try + Assert.AreEqual(JSONRPC_INVALID_PARAMS, Second.GetValue('error.code')); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.MultipleInputs_RoundTrip; +begin + var First := CallTool('test_input_required_result_multiple_inputs', ''); + var Token := ''; + try + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.user_name.method')); + Assert.AreEqual('sampling/createMessage', First.GetValue('result.inputRequests.greeting.method')); + Assert.AreEqual('roots/list', First.GetValue('result.inputRequests.client_roots.method')); + Token := First.GetValue('result.requestState'); + Assert.IsTrue(Token <> ''); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_multiple_inputs', Format( + '"inputResponses":{"user_name":{"action":"accept","content":{"name":"Alice"}},' + + '"greeting":{"role":"assistant","content":{"type":"text","text":"Hello there"}},' + + '"client_roots":{"roots":[{"uri":"file:///test/root"}]}},"requestState":"%s"', [Token])); + try + Assert.AreEqual('Hello there, Alice! Roots: file:///test/root', ResultText(Second)); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.MultiRound_StateChangesPerRound; +begin + var First := CallTool('test_input_required_result_multi_round', ''); + var Token1 := ''; + try + Assert.IsNotNull(First.FindValue('result.inputRequests.step1')); + Token1 := First.GetValue('result.requestState'); + finally + First.Free; + end; + + var Second := CallTool('test_input_required_result_multi_round', + Format('"inputResponses":{"step1":{"action":"accept","content":{"name":"Alice"}}},"requestState":"%s"', [Token1])); + var Token2 := ''; + try + Assert.AreEqual('input_required', Second.GetValue('result.resultType')); + Assert.IsNotNull(Second.FindValue('result.inputRequests.step2')); + Assert.IsNull(Second.FindValue('result.inputRequests.step1')); + Token2 := Second.GetValue('result.requestState'); + Assert.AreNotEqual(Token1, Token2); + finally + Second.Free; + end; + + var Third := CallTool('test_input_required_result_multi_round', + Format('"inputResponses":{"step2":{"action":"accept","content":{"color":"blue"}}},"requestState":"%s"', [Token2])); + try + Assert.AreEqual('Hello, Alice! Your favorite color is blue.', ResultText(Third)); + finally + Third.Free; + end; +end; + +procedure TInputRequiredFlowTests.Capabilities_OnlyDeclaredKinds; +begin + var Response := CallTool('test_input_required_result_capabilities', '', '{"sampling":{}}'); + try + Assert.AreEqual('input_required', Response.GetValue('result.resultType')); + Assert.IsNotNull(Response.FindValue('result.inputRequests.capital_question')); + Assert.IsNull(Response.FindValue('result.inputRequests.user_name')); + Assert.IsNull(Response.FindValue('result.inputRequests.client_roots')); + finally + Response.Free; + end; + + var None := CallTool('test_input_required_result_capabilities', '', '{}'); + try + Assert.AreEqual('complete', None.GetValue('result.resultType')); + finally + None.Free; + end; +end; + +procedure TInputRequiredFlowTests.Capabilities_UndeclaredKind_Is32021; +begin + var Response := CallTool('test_input_required_result_elicitation', '', '{"sampling":{}}'); + try + Assert.AreEqual(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, Response.GetValue('error.code')); + Assert.AreEqual(400, Response.GetValue('httpStatus')); + Assert.IsNotNull(Response.FindValue('error.data.requiredCapabilities.elicitation')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.MissingCapabilityTool_Is32021_WithRequiredCapabilities; +begin + var Response := CallTool('test_missing_capability', '', '{"elicitation":{}}'); + try + Assert.AreEqual(MCP_ERROR_MISSING_REQUIRED_CLIENT_CAPABILITY, Response.GetValue('error.code')); + Assert.AreEqual(400, Response.GetValue('httpStatus')); + Assert.IsTrue(Response.FindValue('error.data.requiredCapabilities.sampling') is TJSONObject); + finally + Response.Free; + end; + + var Declared := CallTool('test_missing_capability', '', '{"sampling":{}}'); + try + Assert.AreEqual('complete', Declared.GetValue('result.resultType')); + finally + Declared.Free; + end; +end; + +procedure TInputRequiredFlowTests.Legacy_IsInternalError; +begin + var Response := CallLegacy('test_input_required_result_elicitation'); + try + Assert.AreEqual(JSONRPC_INTERNAL_ERROR, Response.GetValue('error.code')); + Assert.IsTrue(Response.GetValue('error.message').Contains('2025-11-25')); + finally + Response.Free; + end; +end; + +procedure TInputRequiredFlowTests.Prompt_RoundTrip; +begin + var First := Call('prompts/get', '"name":"test_input_required_result_prompt"'); + try + Assert.AreEqual('input_required', First.GetValue('result.resultType')); + Assert.AreEqual('elicitation/create', First.GetValue('result.inputRequests.user_context.method')); + Assert.AreEqual('context', First.GetValue('result.inputRequests.user_context.params.requestedSchema.required[0]')); + finally + First.Free; + end; + + var Second := Call('prompts/get', + '"name":"test_input_required_result_prompt","inputResponses":{"user_context":{"action":"accept","content":{"context":"test context"}}}'); + try + Assert.AreEqual('complete', Second.GetValue('result.resultType')); + Assert.AreEqual('Use this context: test context', Second.GetValue('result.messages[0].content.text')); + finally + Second.Free; + end; +end; + +procedure TInputRequiredFlowTests.ToolsList_IsNeverInputRequired; +begin + var Response := Call('tools/list', '"inputResponses":{"x":{}},"requestState":"ignored"'); + try + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + finally + Response.Free; + end; +end; + +end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index 4acc5a5..56ff4e8 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -34,7 +34,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(12, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(21, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; @@ -53,7 +53,7 @@ procedure TRegistryTests.BuiltInPrompts_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_arguments')); Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_embedded_resource')); Assert.IsTrue(TMCPRegistry.HasPrompt('test_prompt_with_image')); - Assert.AreEqual(5, Integer(Length(TMCPRegistry.GetPromptNames))); + Assert.AreEqual(6, Integer(Length(TMCPRegistry.GetPromptNames))); end; procedure TRegistryTests.BuiltInResourceTemplates_AreRegisteredFromInitialization; diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index dfecab4..297be36 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -44,6 +44,7 @@ uses 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.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', @@ -71,6 +72,7 @@ uses 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.PromptsManager in 'MCPServer.Tests.PromptsManager.pas', MCPServer.Tests.CompletionManager in 'MCPServer.Tests.CompletionManager.pas'; diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index de6b9ee..1c2de03 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -102,6 +102,7 @@ + @@ -131,6 +132,7 @@ + diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 2439f42..4c5996d 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 3336 +Content-Length: 5252 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 895d463..8da36e4 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 3207 +Content-Length: 5123 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index f16880a..e8a4b90 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 3184 +Content-Length: 5100 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json index be1fff3..9157795 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -246,6 +246,96 @@ }, "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 + } } ] } diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json index 47eae7f..8a2476a 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -257,6 +257,96 @@ }, "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 + } } ], "ttlMs": 0, From bebf755768ec392a3b1f42e5222a6b1e808608c0 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:07:28 +0200 Subject: [PATCH 44/56] docs: describe multi round-trip requests and the request state settings --- CHANGELOG.md | 19 ++++++++++++++++ MIGRATION.md | 22 +++++++++++++++++++ README.md | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 103 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2f745a7..1cf4012 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -162,6 +162,25 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). `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`. +- Example tools `test_input_required_result_elicitation`, `_sampling`, + `_list_roots`, `_request_state`, `_multiple_inputs`, `_multi_round`, + `_tampered_state`, `_capabilities` and `test_missing_capability` + (`MCPServer.Tool.InputRequiredSamples`) and the prompt + `test_input_required_result_prompt`: the multi round-trip fixtures of the + conformance suite. ### Changed diff --git a/MIGRATION.md b/MIGRATION.md index 8e23112..ecf2309 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -130,6 +130,28 @@ Override `DoExecute` instead of `Execute`; the base class validates `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. + ## Library use - `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are diff --git a/README.md b/README.md index fe4fc86..6a9432d 100644 --- a/README.md +++ b/README.md @@ -362,6 +362,59 @@ JSON. Set `FAnnotations` (for example `readOnlyHint`) or `FIcons` in the constructor to publish them in `tools/list`. `MCPServer.Tool.ContentSamples` has one small example per content type. +### Asking the client for input (multi round-trip requests) + +MCP 2026-07-28 replaced server-initiated requests (`elicitation/create`, +`sampling/createMessage`, `roots/list`) with multi round-trip requests: the +server answers `tools/call`, `resources/read` or `prompts/get` with an +`InputRequiredResult` that lists what it needs, the client gathers the +answers and retries the same request with `inputResponses` (and the +server's opaque `requestState`). A tool, resource or prompt that needs input +raises `EMCPInputRequired` (`MCPServer.Mrtr`); the request context carries +the answers on the retry: + +```pascal +function TGreetTool.ExecuteWithContext(const Params: TNoParams; + const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + var Name := ''; + if Context.TryGetInputResponse('user_name', Response) then + Name := TMCPInputResponse.ElicitationField(Response, 'name'); + if Name = '' then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation('user_name', 'What is your name?', TMCPInputRequests.FieldSchema('name'))); + + Result := TMCPToolResult.Text(Format('Hello, %s!', [Name])); +end; +``` + +`TMCPInputRequests` builds the `inputRequests` map (`AddElicitation`, +`AddSampling`, `AddListRoots`); `TMCPInputResponse` reads the answers +(`ElicitationContent`, `ElicitationField`, `SamplingText`, `Roots`). The +processor only sends input requests the client declared a capability for +(`elicitation`, `sampling`, `roots`) and answers `-32021` otherwise, so a +tool can check `Context.HasClientCapability` first and ask for what the +client can deliver. Missing or wrong answers are handled by raising again: +the client gets a fresh `InputRequiredResult`. + +State that must survive the round trip goes into the second constructor +argument: `EMCPInputRequired.Create(Requests, State)` with a `TJSONObject`. +The processor seals it into `requestState` (HMAC-SHA256 over the state, the +method, a digest of the request parameters, the principal and an expiry) +and opens it on the retry into `Context.RequestState`; a tampered, expired +or foreign token is `-32602`. `[Security] RequestStateKey` in `settings.ini` +is the signing secret (set the same value on every instance behind a load +balancer; empty means a random key per process) and +`RequestStateTtlSeconds` the token lifetime (600 by default). + +Clients on the 2025 revisions cannot answer input requests, so a request +that raises `EMCPInputRequired` in the legacy era is answered with +`-32603`. `MCPServer.Tool.InputRequiredSamples` and +`test_input_required_result_prompt` are the examples the conformance suite +exercises. + ### Creating Custom Resources ```pascal @@ -670,6 +723,13 @@ The Inspector provides a web interface to interact with your MCP server, making - **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 ## Available Example prompts @@ -680,6 +740,8 @@ The Inspector provides a web interface to interact with your MCP server, making **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 From 7183aceb02e69463d321f80926292ae608e91a54 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:14:08 +0200 Subject: [PATCH 45/56] feat: stream notifications on the HTTP response When a request accepts text/event-stream and its handler sends a notification, the response becomes a chunked SSE stream with the notifications before the final JSON-RPC response and X-Accel-Buffering off; a client that disconnects cancels the request. Requests that send nothing are answered as before. The request context gains Log and LogJson for notifications/message, gated by the request's logLevel. --- src/MCPServer.dpr | 1 + src/MCPServer.dproj | 1 + src/Protocol/MCPServer.JsonRpcProcessor.pas | 4 +- src/Protocol/MCPServer.RequestContext.pas | 36 ++++ src/Protocol/MCPServer.Types.pas | 26 +++ src/Server/MCPServer.HttpStream.pas | 176 ++++++++++++++++++++ src/Server/MCPServer.IdHTTPServer.pas | 39 +++-- 7 files changed, 268 insertions(+), 15 deletions(-) create mode 100644 src/Server/MCPServer.HttpStream.pas diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 6e2808d..d155516 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -16,6 +16,7 @@ uses 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', diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index 6f0c7e5..dc9735b 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -133,6 +133,7 @@ + diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 0be23b8..46b6eb1 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -96,8 +96,6 @@ implementation INPUT_REQUIRED_METHODS: array[0..2] of string = ('tools/call', 'resources/read', 'prompts/get'); PARAM_INPUT_RESPONSES = 'inputResponses'; PARAM_REQUEST_STATE = 'requestState'; - LOG_LEVELS: array[0..7] of string = ( - 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); function InArray(const Value: string; const Values: array of string): Boolean; begin @@ -277,7 +275,7 @@ procedure TMCPJsonRpcProcessor.ValidateModernMeta(const Meta: TJSONObject); 'params._meta.' + MCP_META_CLIENT_INFO + ' must be an object', nil, HTTP_STATUS_BAD_REQUEST); var LogLevel := Meta.GetValue(MCP_META_LOG_LEVEL); - if Assigned(LogLevel) and (not (LogLevel is TJSONString) or not InArray(TJSONString(LogLevel).Value, LOG_LEVELS)) then + if Assigned(LogLevel) and (not IsJsonString(LogLevel) or not TMCPLogLevel.IsKnown(TJSONString(LogLevel).Value)) then raise EMCPError.Create(JSONRPC_INVALID_PARAMS, 'params._meta.' + MCP_META_LOG_LEVEL + ' must be one of debug, info, notice, warning, error, critical, alert, emergency', nil, HTTP_STATUS_BAD_REQUEST); diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas index 622ac47..5a47a08 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -79,6 +79,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) function HasProgressToken: Boolean; procedure ReportProgress(const Progress: Double; const Total: Double = -1; const Message: string = ''); function TryGetInputResponse(const Key: string; out Response: TJSONObject): Boolean; + procedure Log(const Level, Text: string; const Logger: string = ''); + procedure LogJson(const Level: string; const Data: TJSONValue; const Logger: string = ''); class function Current: IMCPRequestContext; class procedure SetCurrent(const Value: IMCPRequestContext); @@ -345,6 +347,40 @@ procedure TMCPRequestContext.ReportProgress(const Progress, Total: Double; const end; end; +procedure TMCPRequestContext.Log(const Level, Text: string; const Logger: string); +begin + LogJson(Level, TJSONString.Create(Text), Logger); +end; + +procedure TMCPRequestContext.LogJson(const Level: string; const Data: TJSONValue; const Logger: string); +const + JSON_RPC_VERSION = '2.0'; +begin + var Threshold := GetLogLevel; + var Wanted := Assigned(FSink) and (Threshold <> '') and not IsCancelled + and (TMCPLogLevel.Rank(Level) >= TMCPLogLevel.Rank(Threshold)); + if not Wanted then + begin + Data.Free; + Exit; + end; + + var Notification := TJSONObject.Create; + try + Notification.AddPair('jsonrpc', JSON_RPC_VERSION); + Notification.AddPair('method', MCP_METHOD_NOTIFICATIONS_MESSAGE); + var Params := TJSONObject.Create; + Notification.AddPair('params', Params); + Params.AddPair('level', Level); + if Logger <> '' then + Params.AddPair('logger', Logger); + Params.AddPair('data', Data); + FSink.Send(Notification.ToJSON); + finally + Notification.Free; + end; +end; + class function TMCPRequestContext.Current: IMCPRequestContext; begin Result := IMCPRequestContext(CurrentContextPointer); diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 80077e0..bc392e0 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -61,11 +61,20 @@ interface 'resources/read' ); + MCP_METHOD_NOTIFICATIONS_MESSAGE = 'notifications/message'; + MCP_LOG_LEVELS: array[0..7] of string = ( + 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); + function IsLegacyProtocolVersion(const Version: string): Boolean; function IsModernProtocolVersion(const Version: string): Boolean; function NegotiateLegacyProtocolVersion(const Requested: string): string; type + TMCPLogLevel = record + class function Rank(const Level: string): Integer; static; + class function IsKnown(const Level: string): Boolean; static; + end; + OptionalAttribute = class(TCustomAttribute) end; @@ -261,6 +270,8 @@ TMCPLegacySession = class 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; @@ -410,6 +421,21 @@ 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; + function IsJsonString(const Value: TJSONValue): Boolean; begin Result := (Value is TJSONString) and not (Value is TJSONNumber); diff --git a/src/Server/MCPServer.HttpStream.pas b/src/Server/MCPServer.HttpStream.pas new file mode 100644 index 0000000..6963642 --- /dev/null +++ b/src/Server/MCPServer.HttpStream.pas @@ -0,0 +1,176 @@ +unit MCPServer.HttpStream; + +interface + +uses + System.SysUtils, + System.SyncObjs, + IdContext, + IdCustomHTTPServer, + MCPServer.Types; + +type + TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequestTracker) + public + const MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; + strict private + FConnection: TIdContext; + FResponseInfo: TIdHTTPResponseInfo; + FLock: TCriticalSection; + FOpened: Boolean; + FBroken: Boolean; + FRequest: IMCPRequestContext; + procedure OpenStream; + procedure WriteChunk(const Text: string); + procedure WriteEvent(const Json: string); + procedure MarkBroken(const Reason: string); + public + constructor Create(const Connection: TIdContext; const ResponseInfo: TIdHTTPResponseInfo); + destructor Destroy; override; + + procedure Send(const Json: string); + procedure Track(const Context: IMCPRequestContext); + procedure Untrack(const Context: IMCPRequestContext); + function TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; + procedure Finish(const FinalJson: string); + + class function EventText(const Json: string): string; static; + + property Opened: Boolean read FOpened; + property Broken: Boolean read FBroken; + end; + +implementation + +uses + IdGlobal, + MCPServer.Logger; + +const + SSE_EVENT_PREFIX = 'event: message'#10'data: '; + SSE_EVENT_SUFFIX = #10#10; + CHUNK_TERMINATOR = '0'#13#10#13#10; + CHARSET_UTF8 = 'utf-8'; + HTTP_STATUS_OK = 200; + +{ TMCPHttpResponseStream } + +constructor TMCPHttpResponseStream.Create(const Connection: TIdContext; const ResponseInfo: TIdHTTPResponseInfo); +begin + inherited Create; + FConnection := Connection; + FResponseInfo := ResponseInfo; + FLock := TCriticalSection.Create; +end; + +destructor TMCPHttpResponseStream.Destroy; +begin + FLock.Free; + inherited; +end; + +class function TMCPHttpResponseStream.EventText(const Json: string): string; +begin + Result := SSE_EVENT_PREFIX + Json + SSE_EVENT_SUFFIX; +end; + +procedure TMCPHttpResponseStream.OpenStream; +begin + FResponseInfo.ResponseNo := HTTP_STATUS_OK; + FResponseInfo.ContentType := MEDIA_TYPE_EVENT_STREAM; + FResponseInfo.CharSet := CHARSET_UTF8; + FResponseInfo.ContentLength := -1; + FResponseInfo.TransferEncoding := 'chunked'; + FResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; + FResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; + FResponseInfo.WriteHeader; + FOpened := True; +end; + +procedure TMCPHttpResponseStream.WriteChunk(const Text: string); +begin + var Bytes := TEncoding.UTF8.GetBytes(Text); + var IOHandler := FConnection.Connection.IOHandler; + IOHandler.WriteLn(IntToHex(Length(Bytes), 1)); + IOHandler.Write(TIdBytes(Bytes)); + IOHandler.WriteLn; +end; + +procedure TMCPHttpResponseStream.WriteEvent(const Json: string); +begin + WriteChunk(EventText(Json)); +end; + +procedure TMCPHttpResponseStream.MarkBroken(const Reason: string); +begin + FBroken := True; + TLogger.Info(Format('HTTP response stream closed by the client: %s', [Reason])); + var Request := FRequest; + if Assigned(Request) then + Request.Cancel; +end; + +procedure TMCPHttpResponseStream.Send(const Json: string); +begin + FLock.Enter; + try + if FBroken then + Exit; + try + if not FOpened then + OpenStream; + WriteEvent(Json); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + +procedure TMCPHttpResponseStream.Track(const Context: IMCPRequestContext); +begin + FLock.Enter; + try + FRequest := Context; + finally + FLock.Leave; + end; +end; + +procedure TMCPHttpResponseStream.Untrack(const Context: IMCPRequestContext); +begin + FLock.Enter; + try + FRequest := nil; + finally + FLock.Leave; + end; +end; + +function TMCPHttpResponseStream.TryCancel(const RequestId: TMCPRequestId; const Reason: string): Boolean; +begin + Result := False; +end; + +procedure TMCPHttpResponseStream.Finish(const FinalJson: string); +begin + FLock.Enter; + try + if not FOpened or FBroken then + Exit; + try + if FinalJson <> '' then + WriteEvent(FinalJson); + FConnection.Connection.IOHandler.Write(CHUNK_TERMINATOR); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + +end. diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index e3a149c..b9d0d9e 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -53,7 +53,7 @@ TMCPIdHTTPServer = class(TComponent) function ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; procedure ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); procedure HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo); - procedure HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); + procedure HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); function BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; procedure EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); procedure SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); @@ -82,6 +82,7 @@ implementation MCPServer.Resource.Server, MCPServer.Errors, MCPServer.HttpHeaders, + MCPServer.HttpStream, MCPServer.Logger; const @@ -108,10 +109,6 @@ implementation MEDIA_TYPE_JSON = 'application/json'; MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; - SSE_EVENT_PREFIX = 'event: '; - SSE_DATA_PREFIX = 'data: '; - SSE_MESSAGE_TERMINATOR = #10#10; - LOOPBACK_IPV4 = '127.0.0.1'; LOOPBACK_IPV6 = '::1'; ANY_IPV4 = '0.0.0.0'; @@ -335,7 +332,7 @@ procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; if RequestInfo.Command = 'OPTIONS' then SendEmpty(ResponseInfo, HTTP_NO_CONTENT) else if RequestInfo.CommandType = hcPOST then - HandlePostRequest(RequestInfo, ResponseInfo) + HandlePostRequest(Context, RequestInfo, ResponseInfo) else SendMethodNotAllowed(ResponseInfo); finally @@ -440,7 +437,8 @@ procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo.CustomHeaders.Values[HEADER_SESSION_ID] := SessionId; end; -procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); +procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; + ResponseInfo: TIdHTTPResponseInfo); begin var MaxBodyBytes: Integer := TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES; var MaxDepth: Integer := TMCPSettings.DEFAULT_MAX_JSON_DEPTH; @@ -473,14 +471,33 @@ procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; Re Exit; end; + var AcceptsEventStream := TMCPAcceptHeader.Accepts(HeaderValue(RequestInfo, HEADER_ACCEPT), MEDIA_TYPE_EVENT_STREAM); + var Hints := BuildTransportHints(RequestInfo); + var Stream: TMCPHttpResponseStream := nil; + var StreamRef: IMCPMessageSink := nil; + if AcceptsEventStream then + begin + Stream := TMCPHttpResponseStream.Create(Context, ResponseInfo); + StreamRef := Stream; + Hints.Sink := Stream; + Hints.Tracker := Stream; + end; + var Outcome: TMCPProcessResult; var Message := TJSONObject.ParseJSONValue(RequestBody); try - Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, BuildTransportHints(RequestInfo)); + Outcome := FJsonRpcProcessor.ProcessRequestEx(Message, Hints); finally Message.Free; end; + if Assigned(Stream) and Stream.Opened then + begin + TLogger.Debug('Response (streamed): ' + TLogger.RedactJson(Outcome.Body)); + Stream.Finish(Outcome.Body); + Exit; + end; + if Outcome.Era = TMCPProtocolEra.Legacy then EchoLegacySessionId(RequestInfo, ResponseInfo); @@ -492,8 +509,7 @@ procedure TMCPIdHTTPServer.HandlePostRequest(RequestInfo: TIdHTTPRequestInfo; Re TLogger.Debug('Response: ' + TLogger.RedactJson(Outcome.Body)); - if (Outcome.HttpStatus = HTTP_STATUS_OK) - and TMCPAcceptHeader.Accepts(HeaderValue(RequestInfo, HEADER_ACCEPT), MEDIA_TYPE_EVENT_STREAM) then + if (Outcome.HttpStatus = HTTP_STATUS_OK) and AcceptsEventStream then SendSse(ResponseInfo, Outcome.Body) else SendJson(ResponseInfo, Outcome.HttpStatus, Outcome.Body); @@ -521,8 +537,7 @@ procedure TMCPIdHTTPServer.SendSse(ResponseInfo: TIdHTTPResponseInfo; const Body ResponseInfo.CharSet := 'utf-8'; ResponseInfo.CustomHeaders.Values['Cache-Control'] := 'no-cache'; ResponseInfo.CustomHeaders.Values['X-Accel-Buffering'] := 'no'; - ResponseInfo.ContentStream := TStringStream.Create( - SSE_EVENT_PREFIX + 'message' + #10 + SSE_DATA_PREFIX + Body + SSE_MESSAGE_TERMINATOR, TEncoding.UTF8); + ResponseInfo.ContentStream := TStringStream.Create(TMCPHttpResponseStream.EventText(Body), TEncoding.UTF8); ResponseInfo.FreeContentStream := True; end; From 04b16dfa2f05eed29b8ded0553df3f078e5d271b Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:14:08 +0200 Subject: [PATCH 46/56] feat: logging and streaming example tools with tests test_logging_tool logs at every level, test_streaming_elicitation logs and then asks for a confirmation. HTTP tests cover streamed progress, plain JSON without the event-stream accept, logLevel gating, an InputRequiredResult and a JSON-RPC error as the final event. The progress scenario passes in both eras and the stateless scenario in full; the modern baseline is empty. --- conformance-baseline-2025-11-25.yml | 1 - conformance-baseline-2026-07-28.yml | 4 +- src/Tools/MCPServer.Tool.ContentSamples.pas | 30 +++++++ .../MCPServer.Tool.InputRequiredSamples.pas | 35 ++++++++ tests/MCPServer.Tests.Cancellation.pas | 47 ++++++++++ tests/MCPServer.Tests.Http.pas | 87 +++++++++++++++++++ tests/MCPServer.Tests.Registration.pas | 2 +- tests/MCPServerTests.dpr | 1 + tests/MCPServerTests.dproj | 1 + tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/legacy/tools-list.json | 20 +++++ tests/golden/modern/tools-list.json | 20 +++++ 14 files changed, 249 insertions(+), 11 deletions(-) diff --git a/conformance-baseline-2025-11-25.yml b/conformance-baseline-2025-11-25.yml index e51530d..266d3ba 100644 --- a/conformance-baseline-2025-11-25.yml +++ b/conformance-baseline-2025-11-25.yml @@ -4,7 +4,6 @@ server: - logging-set-level - tools-call-with-logging - - tools-call-with-progress - tools-call-sampling - tools-call-elicitation - elicitation-sep1034-defaults diff --git a/conformance-baseline-2026-07-28.yml b/conformance-baseline-2026-07-28.yml index aea2510..175080f 100644 --- a/conformance-baseline-2026-07-28.yml +++ b/conformance-baseline-2026-07-28.yml @@ -1,6 +1,4 @@ # Known conformance failures for --requirements 2026-07-28 # Scenarios listed here may fail; a listed scenario that passes fails the run (stale entry). # Regenerate with scripts/run-conformance.ps1 -NoBaseline after a change and prune what passes. -server: - - server-stateless - - tools-call-with-progress +server: [] diff --git a/src/Tools/MCPServer.Tool.ContentSamples.pas b/src/Tools/MCPServer.Tool.ContentSamples.pas index e3cc236..44b88c4 100644 --- a/src/Tools/MCPServer.Tool.ContentSamples.pas +++ b/src/Tools/MCPServer.Tool.ContentSamples.pas @@ -81,6 +81,13 @@ TErrorHandlingTool = class(TMCPToolBase) 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; @@ -262,6 +269,24 @@ function TJsonSchema202012Tool.DoExecute(const Arguments: TJSONObject): TValue; Result := TValue.From('ok'); end; +{ TLoggingTool } + +constructor TLoggingTool.Create; +begin + inherited; + FName := 'test_logging_tool'; + FDescription := 'Emits log notifications at every level; the client sees those at or above its requested level'; +end; + +function TLoggingTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + for var Level in MCP_LOG_LEVELS do + begin + Context.Log(Level, Format('%s message from test_logging_tool', [Level]), 'test_logging_tool'); + end; + Result := TMCPToolResult.Text('Logged a message at every level'); +end; + initialization TMCPRegistry.RegisterTool('test_simple_text', function: IMCPTool @@ -298,6 +323,11 @@ initialization begin Result := TErrorHandlingTool.Create; end); + TMCPRegistry.RegisterTool('test_logging_tool', + function: IMCPTool + begin + Result := TLoggingTool.Create; + end); TMCPRegistry.RegisterTool('json_schema_2020_12_tool', function: IMCPTool begin diff --git a/src/Tools/MCPServer.Tool.InputRequiredSamples.pas b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas index 016a947..6f2ee47 100644 --- a/src/Tools/MCPServer.Tool.InputRequiredSamples.pas +++ b/src/Tools/MCPServer.Tool.InputRequiredSamples.pas @@ -74,6 +74,13 @@ TMissingCapabilityTool = class(TMCPToolBase) 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; @@ -394,6 +401,29 @@ function TMissingCapabilityTool.ExecuteWithContext(const Params: TNoParams; cons Result := TMCPToolResult.Text('The client declared the sampling capability'); end; +{ TStreamingElicitationTool } + +constructor TStreamingElicitationTool.Create; +begin + inherited; + FName := 'test_streaming_elicitation'; + FDescription := 'Logs to the response stream, then asks the client for a confirmation'; +end; + +function TStreamingElicitationTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +var + Response: TJSONObject; +begin + Context.Log('info', 'Asking the client to confirm', 'test_streaming_elicitation'); + var Confirmed := Context.TryGetInputResponse(KEY_CONFIRM, Response) + and (TMCPInputResponse.ElicitationField(Response, FIELD_OK) = 'true'); + if not Confirmed then + raise EMCPInputRequired.Create(TMCPInputRequests.Create + .AddElicitation(KEY_CONFIRM, 'Please confirm', TMCPInputRequests.FieldSchema(FIELD_OK, 'boolean'))); + + Result := TMCPToolResult.Text('Confirmed'); +end; + initialization TMCPRegistry.RegisterTool('test_input_required_result_elicitation', function: IMCPTool @@ -440,5 +470,10 @@ initialization begin Result := TMissingCapabilityTool.Create; end); + TMCPRegistry.RegisterTool('test_streaming_elicitation', + function: IMCPTool + begin + Result := TStreamingElicitationTool.Create; + end); end. diff --git a/tests/MCPServer.Tests.Cancellation.pas b/tests/MCPServer.Tests.Cancellation.pas index 1998966..525f6ce 100644 --- a/tests/MCPServer.Tests.Cancellation.pas +++ b/tests/MCPServer.Tests.Cancellation.pas @@ -51,6 +51,9 @@ TCancellationTests = class [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; @@ -217,6 +220,50 @@ procedure TCancellationTests.Progress_WithoutSink_IsNoOp; 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; diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index adc5f17..a3fb2c2 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -66,6 +66,11 @@ THttpTransportTests = class [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; end; implementation @@ -464,4 +469,86 @@ procedure THttpTransportTests.EndpointInfoPath_AnswersJson; 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; + end. diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index 56ff4e8..f85ffd1 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -34,7 +34,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(21, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(23, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index 297be36..ff5f3ac 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -13,6 +13,7 @@ uses 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', diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 1c2de03..0c27bdb 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -77,6 +77,7 @@ + diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 4c5996d..0c4778f 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 5252 +Content-Length: 5668 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 8da36e4..2a0c56a 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 5123 +Content-Length: 5539 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index e8a4b90..b94d322 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 5100 +Content-Length: 5516 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"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}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json index 9157795..10ff171 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -167,6 +167,16 @@ "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", @@ -336,6 +346,16 @@ }, "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 + } } ] } diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json index 8a2476a..2b64d4e 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -178,6 +178,16 @@ "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", @@ -347,6 +357,16 @@ }, "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 + } } ], "ttlMs": 0, From 05ff0322cd5deb1b7de73fb26e4e4aa30c1ba4f2 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:14:08 +0200 Subject: [PATCH 47/56] docs: describe streamed responses and request-scoped logging --- CHANGELOG.md | 12 ++++++++++++ MIGRATION.md | 10 ++++++++++ README.md | 29 ++++++++++++++++++++--------- 3 files changed, 42 insertions(+), 9 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1cf4012..fb97108 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -175,6 +175,18 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). `requestState` tokens bound to the method, a digest of the request parameters, the principal and an expiry; `[Security] RequestStateKey` and `RequestStateTtlSeconds` in `settings.ini`. +- Streaming HTTP responses (`MCPServer.HttpStream`): when a request accepts + `text/event-stream` and its handler sends a notification, the response is a + chunked SSE stream (`X-Accel-Buffering: no`) with the notifications before + the final JSON-RPC response; a client that disconnects cancels the request. + `notifications/progress` therefore reaches HTTP clients in both eras. +- `IMCPRequestContext.Log` and `LogJson`: `notifications/message` on the + request's own stream, only when the request carries + `_meta.io.modelcontextprotocol/logLevel` and the level is at or above it; + `TMCPLogLevel` and `MCP_LOG_LEVELS` in `MCPServer.Types`. +- 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` diff --git a/MIGRATION.md b/MIGRATION.md index ecf2309..89eb327 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -42,6 +42,16 @@ accepted). A missing or different header is `400` with error `-32020`. **SSE responses have no `id:` lines** and no duplicate `Connection` header. +**Responses stream when a tool sends notifications.** A request that accepts +`text/event-stream` and whose tool reports progress or logs (see +`IMCPRequestContext.ReportProgress` and `Log`) is answered with a chunked SSE +stream: the notifications first, the JSON-RPC response as the last event. +Such a stream is `200` even when the request ends in a JSON-RPC error, +because the status line has already been sent. Requests that send no +notification, and requests without `text/event-stream` in `Accept`, are +answered as before (single JSON object, or one SSE event, with a +`Content-Length`). Closing the stream cancels the request. + **TLS 1.0 and 1.1 are disabled** on the OpenSSL 1.0.2 handler (the build without `USE_TAURUS_TLS`). diff --git a/README.md b/README.md index 6a9432d..a58b496 100644 --- a/README.md +++ b/README.md @@ -141,10 +141,19 @@ stdio server never writes `settings.ini` on its own, so this and the other from the defaults. A tool sees the request it is answering through `TMCPRequestContext.Current`: -`CheckCancelled` raises once the client cancels, and `ReportProgress` sends a -`notifications/progress` when the request carries a progress token. See -`test_tool_with_progress` in `MCPServer.Tool.ContentSamples` for a worked -example. +`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. ## Protocol Versions and Dual-Era Behaviour @@ -716,10 +725,10 @@ The Inspector provides a web interface to interact with your MCP server, making - **calculate**: Perform basic arithmetic calculations - **test_simple_text**, **test_image_content**, **test_audio_content**, **test_embedded_resource**, **test_multiple_content_types**, - **test_error_handling**, **test_tool_with_progress**: one small tool per - content type, one that fails, and one that reports progress and honours - cancellation, from `MCPServer.Tool.ContentSamples`; the conformance suite - calls these by name + **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 @@ -729,7 +738,9 @@ The Inspector provides a web interface to interact with your MCP server, making 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 + requires the `sampling` client capability and answers `-32021` without it, + **test_streaming_elicitation** logs to the response stream and then asks + for a confirmation ## Available Example prompts From b36e87cf7158ef4e5003c46badfc114f7e5ce86c Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:28:30 +0200 Subject: [PATCH 48/56] feat: subscriptions/listen with change notifications TMCPSubscriptionsManager keeps a subscriptions/listen request open: the acknowledgement with the honoured filter goes first, every message on the subscription carries the subscription id, HTTP streams get an SSE keep-alive comment, stdio runs the request on its own thread, and the server answers the request with a completion result when it closes the subscription at shutdown. The tools, prompts and resources managers take a ChangeNotifier: with one assigned the modern capabilities announce listChanged and resources.subscribe, and adding, removing or updating notifies the subscribed clients. The managers guard their lists with a lock so run-time changes are safe. --- src/MCPServer.dpr | 15 +- src/MCPServer.dproj | 2 + src/Managers/MCPServer.PromptsManager.pas | 71 ++- src/Managers/MCPServer.ResourcesManager.pas | 98 ++++- .../MCPServer.SubscriptionsManager.pas | 405 ++++++++++++++++++ src/Managers/MCPServer.ToolsManager.pas | 75 +++- src/Protocol/MCPServer.Errors.pas | 3 + src/Protocol/MCPServer.RequestContext.pas | 6 + src/Protocol/MCPServer.Types.pas | 23 + src/Server/MCPServer.HttpStream.pas | 24 +- src/Server/MCPServer.IdHTTPServer.pas | 22 + src/Server/MCPServer.StdioTransport.pas | 47 +- 12 files changed, 760 insertions(+), 31 deletions(-) create mode 100644 src/Managers/MCPServer.SubscriptionsManager.pas diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index d155516..f07a0a6 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -38,6 +38,7 @@ uses 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', @@ -47,6 +48,7 @@ uses 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'; @@ -56,10 +58,11 @@ var Settings: TMCPSettings; ManagerRegistry: IMCPManagerRegistry; CoreManager: IMCPCapabilityManager; - ToolsManager: IMCPCapabilityManager; + ToolsManager: TMCPToolsManager; ResourcesManager: TMCPResourcesManager; PromptsManager: TMCPPromptsManager; CompletionManager: IMCPCapabilityManager; + SubscriptionsManager: TMCPSubscriptionsManager; ShutdownEvent: TEvent; {$IFDEF MSWINDOWS} @@ -106,12 +109,17 @@ begin ResourcesManager := TMCPResourcesManager.Create; PromptsManager := TMCPPromptsManager.Create; CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); + SubscriptionsManager := TMCPSubscriptionsManager.Create; + ToolsManager.ChangeNotifier := SubscriptionsManager; + ResourcesManager.ChangeNotifier := SubscriptionsManager; + PromptsManager.ChangeNotifier := SubscriptionsManager; ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); ManagerRegistry.RegisterManager(PromptsManager); ManagerRegistry.RegisterManager(CompletionManager); + ManagerRegistry.RegisterManager(SubscriptionsManager); Server := TMCPIdHTTPServer.Create(nil); try @@ -153,12 +161,17 @@ begin ResourcesManager := TMCPResourcesManager.Create; PromptsManager := TMCPPromptsManager.Create; CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); + SubscriptionsManager := TMCPSubscriptionsManager.Create; + ToolsManager.ChangeNotifier := SubscriptionsManager; + ResourcesManager.ChangeNotifier := SubscriptionsManager; + PromptsManager.ChangeNotifier := SubscriptionsManager; ManagerRegistry.RegisterManager(CoreManager); ManagerRegistry.RegisterManager(ToolsManager); ManagerRegistry.RegisterManager(ResourcesManager); ManagerRegistry.RegisterManager(PromptsManager); ManagerRegistry.RegisterManager(CompletionManager); + ManagerRegistry.RegisterManager(SubscriptionsManager); StdioTransport := TMCPStdioTransport.Create(ManagerRegistry, CoreManager); try diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index dc9735b..e3bd71d 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -151,6 +151,7 @@ + @@ -162,6 +163,7 @@ + diff --git a/src/Managers/MCPServer.PromptsManager.pas b/src/Managers/MCPServer.PromptsManager.pas index fc8f9ab..e9d32f4 100644 --- a/src/Managers/MCPServer.PromptsManager.pas +++ b/src/Managers/MCPServer.PromptsManager.pas @@ -5,6 +5,7 @@ interface uses System.SysUtils, System.Classes, + System.SyncObjs, System.JSON, System.Rtti, System.Generics.Collections, @@ -17,8 +18,11 @@ TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapab 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); @@ -29,6 +33,8 @@ TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapab 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; @@ -45,6 +51,7 @@ TMCPPromptsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapab property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; end; implementation @@ -59,6 +66,7 @@ implementation constructor TMCPPromptsManager.Create; begin inherited; + FLock := TCriticalSection.Create; FPrompts := TDictionary.Create; FOrder := TList.Create; FListTtlMs := 0; @@ -70,6 +78,7 @@ destructor TMCPPromptsManager.Destroy; begin FPrompts.Free; FOrder.Free; + FLock.Free; inherited; end; @@ -85,8 +94,9 @@ function TMCPPromptsManager.HandlesMethod(const Method: string): Boolean; procedure TMCPPromptsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); var Prompts := TJSONObject.Create; - Prompts.AddPair('listChanged', TJSONBool.Create(False)); + Prompts.AddPair('listChanged', TJSONBool.Create(Announces)); Capabilities.AddPair('prompts', Prompts); end; @@ -116,9 +126,41 @@ function TMCPPromptsManager.ExecuteMethodWithContext(const Method: string; const procedure TMCPPromptsManager.RegisterPrompt(const Prompt: IMCPPrompt); begin - if not FPrompts.ContainsKey(Prompt.Name) then - FOrder.Add(Prompt.Name); - FPrompts.AddOrSetValue(Prompt.Name, Prompt); + 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; @@ -130,11 +172,17 @@ procedure TMCPPromptsManager.RegisterBuiltInPrompts; procedure TMCPPromptsManager.AddPrompt(const Prompt: IMCPPrompt); begin RegisterPrompt(Prompt); + NotifyListChanged; end; function TMCPPromptsManager.TryGetPrompt(const Name: string; out Prompt: IMCPPrompt): Boolean; begin - Result := FPrompts.TryGetValue(Name, Prompt); + FLock.Enter; + try + Result := FPrompts.TryGetValue(Name, Prompt); + finally + FLock.Leave; + end; end; procedure TMCPPromptsManager.CheckCursor(const Params: TJSONObject); @@ -188,8 +236,15 @@ function TMCPPromptsManager.ListPrompts(const Params: TJSONObject; Era: TMCPProt try var PromptsArray := TJSONArray.Create; ResultJSON.AddPair('prompts', PromptsArray); - for var Name in FOrder do - PromptsArray.AddElement(CreatePromptJSON(FPrompts[Name])); + FLock.Enter; + try + for var Name in FOrder do + begin + PromptsArray.AddElement(CreatePromptJSON(FPrompts[Name])); + end; + finally + FLock.Leave; + end; if Era = TMCPProtocolEra.Modern then begin @@ -234,7 +289,7 @@ function TMCPPromptsManager.GetPrompt(const Params: TJSONObject; Era: TMCPProtoc end; try - if not FPrompts.TryGetValue(PromptName, Prompt) then + if not TryGetPrompt(PromptName, Prompt) then raise EMCPError.UnknownPrompt(PromptName); TLogger.Info('MCP GetPrompt called for prompt: ' + PromptName); diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index c01b0a3..f1c48c3 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, @@ -18,8 +19,11 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap 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; @@ -35,6 +39,8 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap destructor Destroy; override; procedure AddResource(const Resource: IMCPResource); + procedure RemoveResource(const URI: string); + procedure ResourceUpdated(const URI: string); procedure AddResourceTemplate(const Template: IMCPResourceTemplate); function TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; function TryGetResourceTemplate(const UriTemplate: string; out Template: IMCPResourceTemplate): Boolean; @@ -55,6 +61,7 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; end; implementation @@ -71,6 +78,7 @@ implementation constructor TMCPResourcesManager.Create; begin inherited; + FLock := TCriticalSection.Create; FResources := TDictionary.Create; FOrder := TList.Create; FTemplates := TList.Create; @@ -85,6 +93,7 @@ destructor TMCPResourcesManager.Destroy; FResources.Free; FOrder.Free; FTemplates.Free; + FLock.Free; inherited; end; @@ -102,9 +111,10 @@ function TMCPResourcesManager.HandlesMethod(const Method: string): Boolean; procedure TMCPResourcesManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); var Resources := TJSONObject.Create; - Resources.AddPair('subscribe', TJSONBool.Create(False)); - Resources.AddPair('listChanged', TJSONBool.Create(False)); + Resources.AddPair('subscribe', TJSONBool.Create(Announces)); + Resources.AddPair('listChanged', TJSONBool.Create(Announces)); Capabilities.AddPair('resources', Resources); end; @@ -136,9 +146,40 @@ function TMCPResourcesManager.ExecuteMethodWithContext(const Method: string; con procedure TMCPResourcesManager.RegisterResource(const Resource: IMCPResource); begin - if not FResources.ContainsKey(Resource.URI) then - FOrder.Add(Resource.URI); - FResources.AddOrSetValue(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; @@ -156,11 +197,18 @@ procedure TMCPResourcesManager.RegisterBuiltInResourceTemplates; procedure TMCPResourcesManager.AddResource(const Resource: IMCPResource); begin RegisterResource(Resource); + NotifyListChanged; end; procedure TMCPResourcesManager.AddResourceTemplate(const Template: IMCPResourceTemplate); begin - FTemplates.Add(Template); + FLock.Enter; + try + FTemplates.Add(Template); + finally + FLock.Leave; + end; + NotifyListChanged; end; function TMCPResourcesManager.TryGetResource(const URI: string; out Resource: IMCPResource): Boolean; @@ -182,15 +230,25 @@ function TMCPResourcesManager.TryGetResourceTemplate(const UriTemplate: string; end; function TMCPResourcesManager.FindResource(const URI: string): IMCPResource; +var + Templates: TArray; begin - if FResources.TryGetValue(URI, Result) then - Exit; + FLock.Enter; + try + if FResources.TryGetValue(URI, Result) then + Exit; + Templates := FTemplates.ToArray; + finally + FLock.Leave; + end; var Vars := TMCPTemplateVars.Create; try - for var Template in FTemplates do + for var Template in Templates do + begin if Template.Matches(URI, Vars) then Exit(Template.CreateResource(URI, Vars)); + end; finally Vars.Free; end; @@ -285,8 +343,15 @@ function TMCPResourcesManager.ListResources(const Params: TJSONObject; Era: TMCP try var ResourcesArray := TJSONArray.Create; ResultJSON.AddPair('resources', ResourcesArray); - for var URI in FOrder do - ResourcesArray.AddElement(CreateResourceJSON(FResources[URI])); + 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); @@ -370,8 +435,15 @@ function TMCPResourcesManager.ListResourceTemplates(const Params: TJSONObject; E try var TemplatesArray := TJSONArray.Create; ResultJSON.AddPair('resourceTemplates', TemplatesArray); - for var Template in FTemplates do - TemplatesArray.AddElement(CreateResourceTemplateJSON(Template)); + 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 diff --git a/src/Managers/MCPServer.SubscriptionsManager.pas b/src/Managers/MCPServer.SubscriptionsManager.pas new file mode 100644 index 0000000..4333c00 --- /dev/null +++ b/src/Managers/MCPServer.SubscriptionsManager.pas @@ -0,0 +1,405 @@ +unit MCPServer.SubscriptionsManager; + +interface + +uses + System.SysUtils, + System.Classes, + System.SyncObjs, + System.JSON, + System.Rtti, + System.Generics.Collections, + MCPServer.Types; + +type + TMCPSubscriptionFilter = record + ToolsListChanged: Boolean; + PromptsListChanged: Boolean; + ResourcesListChanged: Boolean; + ResourceSubscriptions: TArray; + class function FromJson(const Notifications: TJSONValue): TMCPSubscriptionFilter; static; + function ToJson: TJSONObject; + function WantsResource(const Uri: string): Boolean; + function Wants(const Method, Uri: string): Boolean; + end; + + IMCPSubscription = interface + ['{5A1C7E2B-9D3F-4B6A-8C0E-2F1D3B5A7C9E}'] + function GetFilter: TMCPSubscriptionFilter; + function GetSink: IMCPMessageSink; + function GetClosed: TEvent; + procedure Close; + function Notification(const Method: string): TJSONObject; + property Filter: TMCPSubscriptionFilter read GetFilter; + property Sink: IMCPMessageSink read GetSink; + property Closed: TEvent read GetClosed; + end; + + TMCPSubscriptionsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabilityManagerEx, + IMCPSubscriptionHub) + public + const DEFAULT_KEEP_ALIVE_INTERVAL_MS = 15000; + const POLL_INTERVAL_MS = 250; + strict private + FLock: TCriticalSection; + FSubscriptions: TList; + FKeepAliveIntervalMs: Integer; + function Snapshot: TArray; + procedure Deliver(const Method, Uri: string); + function Listen(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; + procedure Acknowledge(const Subscription: IMCPSubscription); + function CompletionResult(const Subscription: IMCPSubscription): TJSONObject; + public + constructor Create; + destructor Destroy; override; + + function GetCapabilityName: string; + function HandlesMethod(const Method: string): Boolean; + function ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; + function ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; + + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + + property KeepAliveIntervalMs: Integer read FKeepAliveIntervalMs write FKeepAliveIntervalMs; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.Logger; + +const + JSONRPC_VERSION = '2.0'; + FILTER_TOOLS = 'toolsListChanged'; + FILTER_PROMPTS = 'promptsListChanged'; + FILTER_RESOURCES = 'resourcesListChanged'; + FILTER_RESOURCE_SUBSCRIPTIONS = 'resourceSubscriptions'; + PARAM_NOTIFICATIONS = 'notifications'; + +type + TMCPSubscription = class(TInterfacedObject, IMCPSubscription) + strict private + FId: TJSONValue; + FFilter: TMCPSubscriptionFilter; + FSink: IMCPMessageSink; + FClosed: TEvent; + public + constructor Create(const Id: TJSONValue; const Filter: TMCPSubscriptionFilter; const Sink: IMCPMessageSink); + destructor Destroy; override; + function GetFilter: TMCPSubscriptionFilter; + function GetSink: IMCPMessageSink; + function GetClosed: TEvent; + procedure Close; + function Notification(const Method: string): TJSONObject; + end; + +{ TMCPSubscriptionFilter } + +class function TMCPSubscriptionFilter.FromJson(const Notifications: TJSONValue): TMCPSubscriptionFilter; +begin + Result := Default(TMCPSubscriptionFilter); + if not (Notifications is TJSONObject) then + Exit; + + var Filter := TJSONObject(Notifications); + Result.ToolsListChanged := Filter.GetValue(FILTER_TOOLS) is TJSONTrue; + Result.PromptsListChanged := Filter.GetValue(FILTER_PROMPTS) is TJSONTrue; + Result.ResourcesListChanged := Filter.GetValue(FILTER_RESOURCES) is TJSONTrue; + + var Uris := Filter.GetValue(FILTER_RESOURCE_SUBSCRIPTIONS); + if Uris is TJSONArray then + begin + for var Item in TJSONArray(Uris) do + begin + if IsJsonString(Item) and (TJSONString(Item).Value <> '') then + Result.ResourceSubscriptions := Result.ResourceSubscriptions + [TJSONString(Item).Value]; + end; + end; +end; + +function TMCPSubscriptionFilter.ToJson: TJSONObject; +begin + Result := TJSONObject.Create; + if ToolsListChanged then + Result.AddPair(FILTER_TOOLS, TJSONBool.Create(True)); + if PromptsListChanged then + Result.AddPair(FILTER_PROMPTS, TJSONBool.Create(True)); + if ResourcesListChanged then + Result.AddPair(FILTER_RESOURCES, TJSONBool.Create(True)); + if Length(ResourceSubscriptions) > 0 then + begin + var Uris := TJSONArray.Create; + Result.AddPair(FILTER_RESOURCE_SUBSCRIPTIONS, Uris); + for var Uri in ResourceSubscriptions do + begin + Uris.Add(Uri); + end; + end; +end; + +function TMCPSubscriptionFilter.WantsResource(const Uri: string): Boolean; +begin + for var Subscribed in ResourceSubscriptions do + begin + if Subscribed = Uri then + Exit(True); + end; + Result := False; +end; + +function TMCPSubscriptionFilter.Wants(const Method, Uri: string): Boolean; +begin + if Method = MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED then + Result := ToolsListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED then + Result := PromptsListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED then + Result := ResourcesListChanged + else if Method = MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED then + Result := WantsResource(Uri) + else + Result := False; +end; + +{ TMCPSubscription } + +constructor TMCPSubscription.Create(const Id: TJSONValue; const Filter: TMCPSubscriptionFilter; + const Sink: IMCPMessageSink); +begin + inherited Create; + FId := TJSONValue(Id.Clone); + FFilter := Filter; + FSink := Sink; + FClosed := TEvent.Create(nil, True, False, ''); +end; + +destructor TMCPSubscription.Destroy; +begin + FClosed.Free; + FId.Free; + inherited; +end; + +function TMCPSubscription.GetFilter: TMCPSubscriptionFilter; +begin + Result := FFilter; +end; + +function TMCPSubscription.GetSink: IMCPMessageSink; +begin + Result := FSink; +end; + +function TMCPSubscription.GetClosed: TEvent; +begin + Result := FClosed; +end; + +procedure TMCPSubscription.Close; +begin + FClosed.SetEvent; +end; + +function TMCPSubscription.Notification(const Method: string): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('jsonrpc', JSONRPC_VERSION); + Result.AddPair('method', Method); + var Params := TJSONObject.Create; + Result.AddPair('params', Params); + var Meta := TJSONObject.Create; + Params.AddPair('_meta', Meta); + Meta.AddPair(MCP_META_SUBSCRIPTION_ID, TJSONValue(FId.Clone)); +end; + +{ TMCPSubscriptionsManager } + +constructor TMCPSubscriptionsManager.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FSubscriptions := TList.Create; + FKeepAliveIntervalMs := DEFAULT_KEEP_ALIVE_INTERVAL_MS; +end; + +destructor TMCPSubscriptionsManager.Destroy; +begin + CloseAll('subscriptions manager destroyed'); + FSubscriptions.Free; + FLock.Free; + inherited; +end; + +function TMCPSubscriptionsManager.GetCapabilityName: string; +begin + Result := 'subscriptions'; +end; + +function TMCPSubscriptionsManager.HandlesMethod(const Method: string): Boolean; +begin + Result := Method = MCP_METHOD_SUBSCRIPTIONS_LISTEN; +end; + +function TMCPSubscriptionsManager.ExecuteMethod(const Method: string; const Params: TJSONObject): TValue; +begin + Result := ExecuteMethodWithContext(Method, Params, nil); +end; + +function TMCPSubscriptionsManager.ExecuteMethodWithContext(const Method: string; const Params: TJSONObject; + const Context: IMCPRequestContext): TValue; +begin + if Method <> MCP_METHOD_SUBSCRIPTIONS_LISTEN then + raise EMCPError.MethodNotFound(Method); + Result := Listen(Params, Context); +end; + +function TMCPSubscriptionsManager.Snapshot: TArray; +begin + FLock.Enter; + try + Result := FSubscriptions.ToArray; + finally + FLock.Leave; + end; +end; + +procedure TMCPSubscriptionsManager.Acknowledge(const Subscription: IMCPSubscription); +begin + var Notification := Subscription.Notification(MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED); + try + TJSONObject(Notification.GetValue('params')).AddPair(PARAM_NOTIFICATIONS, Subscription.Filter.ToJson); + Subscription.Sink.Send(Notification.ToJSON); + finally + Notification.Free; + end; +end; + +function TMCPSubscriptionsManager.CompletionResult(const Subscription: IMCPSubscription): TJSONObject; +begin + var Notification := Subscription.Notification(''); + try + Result := TJSONObject.Create; + Result.AddPair('_meta', TJSONObject(Notification.FindValue('params._meta').Clone)); + finally + Notification.Free; + end; +end; + +function TMCPSubscriptionsManager.Listen(const Params: TJSONObject; const Context: IMCPRequestContext): TValue; +var + KeepAlive: IMCPKeepAlive; +begin + if not Assigned(Context) or not Assigned(Context.Sink) then + raise EMCPError.InvalidRequest(Format( + '%s needs a response stream: accept text/event-stream or use stdio', [MCP_METHOD_SUBSCRIPTIONS_LISTEN])); + + var Notifications: TJSONValue := nil; + if Assigned(Params) then + Notifications := Params.GetValue(PARAM_NOTIFICATIONS); + if Assigned(Notifications) and not (Notifications is TJSONObject) then + raise EMCPError.InvalidParams(Format('params.%s must be an object', [PARAM_NOTIFICATIONS])); + + var Id := Context.RequestId.ToJson; + var Subscription: IMCPSubscription; + try + Subscription := TMCPSubscription.Create(Id, TMCPSubscriptionFilter.FromJson(Notifications), Context.Sink); + finally + Id.Free; + end; + + FLock.Enter; + try + FSubscriptions.Add(Subscription); + finally + FLock.Leave; + end; + try + Acknowledge(Subscription); + TLogger.Info(Format('Subscription %s opened', [Context.RequestId.AsText])); + + Supports(Context.Sink, IMCPKeepAlive, KeepAlive); + var SinceKeepAlive := 0; + while not Context.IsCancelled and (Subscription.Closed.WaitFor(POLL_INTERVAL_MS) = TWaitResult.wrTimeout) do + begin + Inc(SinceKeepAlive, POLL_INTERVAL_MS); + if Assigned(KeepAlive) and (SinceKeepAlive >= FKeepAliveIntervalMs) then + begin + SinceKeepAlive := 0; + KeepAlive.KeepAlive; + end; + end; + finally + FLock.Enter; + try + FSubscriptions.Remove(Subscription); + finally + FLock.Leave; + end; + end; + + TLogger.Info(Format('Subscription %s closed', [Context.RequestId.AsText])); + Result := TValue.From(CompletionResult(Subscription)); +end; + +procedure TMCPSubscriptionsManager.Deliver(const Method, Uri: string); +begin + for var Subscription in Snapshot do + begin + if not Subscription.Filter.Wants(Method, Uri) then + Continue; + + var Notification := Subscription.Notification(Method); + try + if Uri <> '' then + TJSONObject(Notification.GetValue('params')).AddPair('uri', Uri); + Subscription.Sink.Send(Notification.ToJSON); + finally + Notification.Free; + end; + end; +end; + +procedure TMCPSubscriptionsManager.ToolsListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.PromptsListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.ResourcesListChanged; +begin + Deliver(MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED, ''); +end; + +procedure TMCPSubscriptionsManager.ResourceUpdated(const Uri: string); +begin + Deliver(MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED, Uri); +end; + +procedure TMCPSubscriptionsManager.CloseAll(const Reason: string); +begin + var Open := Snapshot; + if Length(Open) > 0 then + TLogger.Info(Format('Closing %d subscription(s): %s', [Length(Open), Reason])); + for var Subscription in Open do + begin + Subscription.Close; + end; +end; + +function TMCPSubscriptionsManager.ActiveCount: Integer; +begin + Result := Integer(Length(Snapshot)); +end; + +end. diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index 19d0b99..b39ba73 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, @@ -17,8 +18,12 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil strict private 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; @@ -35,6 +40,8 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil 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; @@ -50,6 +57,7 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil property ListTtlMs: Integer read FListTtlMs write FListTtlMs; property ListCacheScope: string read FListCacheScope write FListCacheScope; + property ChangeNotifier: IMCPSubscriptionHub read FChangeNotifier write FChangeNotifier; end; implementation @@ -90,6 +98,7 @@ procedure WarnIfStructuredContentMismatchesSchema(const Tool: IMCPTool; const Re constructor TMCPToolsManager.Create; begin inherited; + FLock := TCriticalSection.Create; FTools := TDictionary.Create; FOrder := TList.Create; FListTtlMs := 0; @@ -101,6 +110,7 @@ destructor TMCPToolsManager.Destroy; begin FTools.Free; FOrder.Free; + FLock.Free; inherited; end; @@ -116,8 +126,9 @@ function TMCPToolsManager.HandlesMethod(const Method: string): Boolean; procedure TMCPToolsManager.DescribeCapabilities(const Capabilities: TJSONObject; Era: TMCPProtocolEra); begin + var Announces := Assigned(FChangeNotifier) and (Era = TMCPProtocolEra.Modern); var Tools := TJSONObject.Create; - Tools.AddPair('listChanged', TJSONBool.Create(False)); + Tools.AddPair('listChanged', TJSONBool.Create(Announces)); Capabilities.AddPair('tools', Tools); end; @@ -154,9 +165,51 @@ procedure TMCPToolsManager.ValidateToolName(const Name: string); procedure TMCPToolsManager.RegisterTool(const Tool: IMCPTool); begin ValidateToolName(Tool.Name); - if not FTools.ContainsKey(Tool.Name) then - FOrder.Add(Tool.Name); - FTools.AddOrSetValue(Tool.Name, Tool); + 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; + +function TMCPToolsManager.HasTool(const Name: string): Boolean; +var + Tool: IMCPTool; +begin + 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; + +procedure TMCPToolsManager.NotifyListChanged; +begin + if Assigned(FChangeNotifier) then + FChangeNotifier.ToolsListChanged; end; procedure TMCPToolsManager.RegisterBuiltInTools; @@ -168,6 +221,7 @@ procedure TMCPToolsManager.RegisterBuiltInTools; procedure TMCPToolsManager.AddTool(const Tool: IMCPTool); begin RegisterTool(Tool); + NotifyListChanged; end; procedure TMCPToolsManager.CheckCursor(const Params: TJSONObject); @@ -301,8 +355,15 @@ function TMCPToolsManager.BuildToolListResponse(Era: TMCPProtocolEra): TJSONObje var ToolsArray := TJSONArray.Create; Result.AddPair('tools', ToolsArray); - for var Name in FOrder do - ToolsArray.AddElement(CreateToolJSON(FTools[Name])); + FLock.Enter; + try + for var Name in FOrder do + begin + ToolsArray.AddElement(CreateToolJSON(FTools[Name])); + end; + finally + FLock.Leave; + end; if Era = TMCPProtocolEra.Modern then begin @@ -347,7 +408,7 @@ function TMCPToolsManager.CallTool(const Params: TJSONObject; Era: TMCPProtocolE if ArgumentsValue is TJSONObject then Arguments := TJSONObject(ArgumentsValue); - if not FTools.TryGetValue(ToolName, Tool) then + if not TryGetTool(ToolName, Tool) then raise EMCPError.UnknownTool(ToolName); TLogger.Info('MCP CallTool called for tool: ' + ToolName); diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index 85bcc46..4b85bf3 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -39,6 +39,9 @@ EMCPError = class(Exception) EMCPToolError = class(Exception); + EMCPTransportError = class(Exception) + end; + EMCPRequestCancelled = class(Exception); const diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas index 5a47a08..11a4b8d 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -71,6 +71,7 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) function GetManagerRegistry: IMCPManagerRegistry; function GetInputResponses: TJSONObject; function GetRequestState: TJSONObject; + function GetSink: IMCPMessageSink; function HasClientCapability(const Path: string): Boolean; procedure RequireClientCapability(const Path: string); function IsCancelled: Boolean; @@ -237,6 +238,11 @@ function TMCPRequestContext.GetRequestState: TJSONObject; Result := FRequestState; end; +function TMCPRequestContext.GetSink: IMCPMessageSink; +begin + Result := FSink; +end; + function TMCPRequestContext.TryGetInputResponse(const Key: string; out Response: TJSONObject): Boolean; begin Response := nil; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index bc392e0..95e06db 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -62,6 +62,12 @@ interface ); MCP_METHOD_NOTIFICATIONS_MESSAGE = 'notifications/message'; + MCP_METHOD_SUBSCRIPTIONS_LISTEN = 'subscriptions/listen'; + MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED = 'notifications/subscriptions/acknowledged'; + MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED = 'notifications/tools/list_changed'; + MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED = 'notifications/prompts/list_changed'; + MCP_METHOD_NOTIFICATIONS_RESOURCES_LIST_CHANGED = 'notifications/resources/list_changed'; + MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED = 'notifications/resources/updated'; MCP_LOG_LEVELS: array[0..7] of string = ( 'debug', 'info', 'notice', 'warning', 'error', 'critical', 'alert', 'emergency'); @@ -246,6 +252,21 @@ TMCPLegacySession = class 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; @@ -261,6 +282,7 @@ TMCPLegacySession = class function GetManagerRegistry: IMCPManagerRegistry; function GetInputResponses: TJSONObject; function GetRequestState: TJSONObject; + function GetSink: IMCPMessageSink; function HasClientCapability(const Path: string): Boolean; procedure RequireClientCapability(const Path: string); @@ -286,6 +308,7 @@ TMCPLegacySession = class property ManagerRegistry: IMCPManagerRegistry read GetManagerRegistry; property InputResponses: TJSONObject read GetInputResponses; property RequestState: TJSONObject read GetRequestState; + property Sink: IMCPMessageSink read GetSink; end; IMCPRequestTracker = interface diff --git a/src/Server/MCPServer.HttpStream.pas b/src/Server/MCPServer.HttpStream.pas index 6963642..0712d1a 100644 --- a/src/Server/MCPServer.HttpStream.pas +++ b/src/Server/MCPServer.HttpStream.pas @@ -10,7 +10,7 @@ interface MCPServer.Types; type - TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequestTracker) + TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequestTracker, IMCPKeepAlive) public const MEDIA_TYPE_EVENT_STREAM = 'text/event-stream'; strict private @@ -29,6 +29,7 @@ TMCPHttpResponseStream = class(TInterfacedObject, IMCPMessageSink, IMCPRequest 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; @@ -44,12 +45,14 @@ implementation uses IdGlobal, + MCPServer.Errors, MCPServer.Logger; const SSE_EVENT_PREFIX = 'event: message'#10'data: '; SSE_EVENT_SUFFIX = #10#10; CHUNK_TERMINATOR = '0'#13#10#13#10; + SSE_KEEP_ALIVE_COMMENT = ': keep-alive'#10#10; CHARSET_UTF8 = 'utf-8'; HTTP_STATUS_OK = 200; @@ -129,6 +132,25 @@ procedure TMCPHttpResponseStream.Send(const Json: string); end; end; +procedure TMCPHttpResponseStream.KeepAlive; +begin + FLock.Enter; + try + if FBroken or not FOpened then + Exit; + try + if not FConnection.Connection.Connected then + raise EMCPTransportError.Create('connection closed'); + WriteChunk(SSE_KEEP_ALIVE_COMMENT); + except + on E: Exception do + MarkBroken(E.Message); + end; + finally + FLock.Leave; + end; +end; + procedure TMCPHttpResponseStream.Track(const Context: IMCPRequestContext); begin FLock.Enter; diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index b9d0d9e..85de838 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -62,6 +62,7 @@ TMCPIdHTTPServer = class(TComponent) procedure SendJsonRpcError(ResponseInfo: TIdHTTPResponseInfo; Status, Code: Integer; const Message: string); procedure SendMethodNotAllowed(ResponseInfo: TIdHTTPResponseInfo); function HeaderPresent(RequestInfo: TIdHTTPRequestInfo; const Name: string): Boolean; + procedure CloseSubscriptions; function HeaderValue(RequestInfo: TIdHTTPRequestInfo; const Name: string): string; public constructor Create(Owner: TComponent); override; @@ -93,6 +94,9 @@ implementation HTTP_METHOD_NOT_ALLOWED = 405; HTTP_PAYLOAD_TOO_LARGE = 413; + SUBSCRIPTION_CLOSE_GRACE_MS = 1000; + SUBSCRIPTION_CLOSE_POLL_MS = 10; + CORS_MAX_AGE = 86400; CORS_ALLOW_METHODS = 'POST, OPTIONS'; CORS_ALLOW_HEADERS = 'Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID'; @@ -173,11 +177,29 @@ procedure TMCPIdHTTPServer.Start; 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'); diff --git a/src/Server/MCPServer.StdioTransport.pas b/src/Server/MCPServer.StdioTransport.pas index e66d761..fbd1c66 100644 --- a/src/Server/MCPServer.StdioTransport.pas +++ b/src/Server/MCPServer.StdioTransport.pas @@ -43,6 +43,7 @@ TMCPStdioTransport = class const DEFAULT_SHUTDOWN_DRAIN_MS = 2000; const SHUTDOWN_CANCEL_GRACE_MS = 500; const QUEUE_DEPTH = 1024; + const LISTENER_POLL_MS = 10; strict private FManagerRegistry: IMCPManagerRegistry; FCoreManager: IMCPCapabilityManager; @@ -55,6 +56,7 @@ TMCPStdioTransport = class FWorkersDone: TCountdownEvent; FShutdownDrainMs: Integer; FWorkerStuck: Boolean; + FListeners: Integer; function GetSettings: TMCPSettings; procedure SetSettings(const Value: TMCPSettings); function Hints: TMCPTransportHints; @@ -64,6 +66,8 @@ TMCPStdioTransport = class 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); @@ -323,7 +327,13 @@ procedure TMCPStdioTransport.DispatchLine(const Message: TJSONValue); begin if not FTracker.Reserve(RequestId) then begin - SendError(RequestId, JSONRPC_INVALID_REQUEST, 'Request id ' + RequestId.AsText + ' is still in flight'); + SendError(RequestId, JSONRPC_INVALID_REQUEST, Format('Request id %s is still in flight', [RequestId.AsText])); + Exit; + end; + if Method = MCP_METHOD_SUBSCRIPTIONS_LISTEN then + begin + StartListener(Message); + Queued := True; Exit; end; if FQueue.PushItem(Message) <> TWaitResult.wrSignaled then @@ -359,6 +369,40 @@ procedure TMCPStdioTransport.ProcessQueued(const Message: TJSONValue); end; end; +procedure TMCPStdioTransport.StartListener(const Message: TJSONValue); +begin + AtomicIncrement(FListeners); + TThread.CreateAnonymousThread( + procedure + begin + try + try + ProcessQueued(Message); + except + on E: Exception do + TLogger.Error(Format('Error processing stdio subscription: %s', [E.Message])); + end; + finally + AtomicDecrement(FListeners); + end; + end).Start; +end; + +procedure TMCPStdioTransport.CloseSubscriptions; +var + Hub: IMCPSubscriptionHub; +begin + Supports(FManagerRegistry.GetManagerForMethod(MCP_METHOD_SUBSCRIPTIONS_LISTEN), IMCPSubscriptionHub, Hub); + var Deadline := TThread.GetTickCount64 + UInt64(FShutdownDrainMs); + repeat + if Assigned(Hub) then + Hub.CloseAll('stdin closed'); + if AtomicCmpExchange(FListeners, 0, 0) = 0 then + Break; + Sleep(LISTENER_POLL_MS); + until TThread.GetTickCount64 >= Deadline; +end; + procedure TMCPStdioTransport.WorkerLoop; var Message: TJSONValue; @@ -402,6 +446,7 @@ procedure TMCPStdioTransport.DrainAndStop; FTracker.CancelAll('stdin closed'); FWorkersDone.WaitFor(SHUTDOWN_CANCEL_GRACE_MS); end; + CloseSubscriptions; if FWorkersDone.IsSet then begin From e90d17e0dc94bc9349555b50f5901eed4cec0f11 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:28:30 +0200 Subject: [PATCH 49/56] feat: trigger tools and tests for subscriptions test_trigger_tool_change, test_trigger_prompt_change and test_trigger_resource_change mutate the lists or report a resource as updated. Tests cover the filter, the acknowledgement and tagging, the filter being honoured, cancellation, keep-alives, the manager hooks and the capability flags, the HTTP stream from acknowledgement to graceful close, and the stdio thread with cancellation and end of input. The stateless conformance scenario passes all 30 checks. --- .../MCPServer.Tool.SubscriptionSamples.pas | 179 +++++++ tests/MCPServer.Tests.Capabilities.pas | 8 +- tests/MCPServer.Tests.Harness.pas | 8 + tests/MCPServer.Tests.Http.pas | 50 ++ tests/MCPServer.Tests.Processor.pas | 4 +- tests/MCPServer.Tests.Registration.pas | 2 +- tests/MCPServer.Tests.Stdio.pas | 73 +++ tests/MCPServer.Tests.Subscriptions.pas | 458 ++++++++++++++++++ tests/MCPServerTests.dpr | 3 + tests/MCPServerTests.dproj | 3 + tests/golden/http/modern-discover.txt | 4 +- tests/golden/http/modern-tools-list.txt | 4 +- tests/golden/http/post-tools-list-sse.txt | 4 +- tests/golden/http/post-tools-list.txt | 4 +- tests/golden/legacy/tools-list.json | 30 ++ tests/golden/modern/server-discover.json | 8 +- tests/golden/modern/tools-list.json | 30 ++ 17 files changed, 853 insertions(+), 19 deletions(-) create mode 100644 src/Tools/MCPServer.Tool.SubscriptionSamples.pas create mode 100644 tests/MCPServer.Tests.Subscriptions.pas diff --git a/src/Tools/MCPServer.Tool.SubscriptionSamples.pas b/src/Tools/MCPServer.Tool.SubscriptionSamples.pas new file mode 100644 index 0000000..c9ed240 --- /dev/null +++ b/src/Tools/MCPServer.Tool.SubscriptionSamples.pas @@ -0,0 +1,179 @@ +unit MCPServer.Tool.SubscriptionSamples; + +interface + +uses + System.SysUtils, + System.Rtti, + System.JSON, + MCPServer.Types, + MCPServer.Tool.Base, + MCPServer.Tool.ContentSamples, + MCPServer.Prompt.Base; + +type + TDynamicTool = class(TSimpleTextTool) + public + constructor Create; override; + end; + + TDynamicPrompt = class(TMCPPromptBase) + protected + function ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; override; + public + constructor Create; override; + end; + + TTriggerToolChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TTriggerPromptChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + + TTriggerResourceChangeTool = class(TMCPToolBase) + protected + function ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; override; + public + constructor Create; override; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.Registration, + MCPServer.ToolsManager, + MCPServer.PromptsManager, + MCPServer.ResourcesManager, + MCPServer.Tool.Result; + +const + DYNAMIC_TOOL_NAME = 'test_dynamic_tool'; + DYNAMIC_PROMPT_NAME = 'test_dynamic_prompt'; + UPDATED_RESOURCE_URI = 'test://static-text'; + +{ TDynamicTool } + +constructor TDynamicTool.Create; +begin + inherited; + FName := DYNAMIC_TOOL_NAME; + FDescription := 'Appears and disappears when test_trigger_tool_change runs'; +end; + +{ TDynamicPrompt } + +constructor TDynamicPrompt.Create; +begin + inherited; + FName := DYNAMIC_PROMPT_NAME; + FDescription := 'Appears and disappears when test_trigger_prompt_change runs'; +end; + +function TDynamicPrompt.ExecuteWithParams(const Params: TNoParams; Messages: TMCPPromptMessages): string; +begin + Messages.AddText('user', 'This prompt was added at run time.'); + Result := 'Dynamic prompt'; +end; + +{ TTriggerToolChangeTool } + +constructor TTriggerToolChangeTool.Create; +begin + inherited; + FName := 'test_trigger_tool_change'; + FDescription := 'Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed'; +end; + +function TTriggerToolChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('tools/list') as TObject; + if not (Manager is TMCPToolsManager) then + raise EMCPError.InternalError('No tools manager to change'); + + var Tools := TMCPToolsManager(Manager); + if Tools.HasTool(DYNAMIC_TOOL_NAME) then + begin + Tools.RemoveTool(DYNAMIC_TOOL_NAME); + Result := TMCPToolResult.Text(Format('Removed %s', [DYNAMIC_TOOL_NAME])); + end + else + begin + Tools.AddTool(TDynamicTool.Create); + Result := TMCPToolResult.Text(Format('Added %s', [DYNAMIC_TOOL_NAME])); + end; +end; + +{ TTriggerPromptChangeTool } + +constructor TTriggerPromptChangeTool.Create; +begin + inherited; + FName := 'test_trigger_prompt_change'; + FDescription := 'Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed'; +end; + +function TTriggerPromptChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('prompts/list') as TObject; + if not (Manager is TMCPPromptsManager) then + raise EMCPError.InternalError('No prompts manager to change'); + + var Prompts := TMCPPromptsManager(Manager); + if Prompts.HasPrompt(DYNAMIC_PROMPT_NAME) then + begin + Prompts.RemovePrompt(DYNAMIC_PROMPT_NAME); + Result := TMCPToolResult.Text(Format('Removed %s', [DYNAMIC_PROMPT_NAME])); + end + else + begin + Prompts.AddPrompt(TDynamicPrompt.Create); + Result := TMCPToolResult.Text(Format('Added %s', [DYNAMIC_PROMPT_NAME])); + end; +end; + +{ TTriggerResourceChangeTool } + +constructor TTriggerResourceChangeTool.Create; +begin + inherited; + FName := 'test_trigger_resource_change'; + FDescription := 'Reports test://static-text as updated to the clients subscribed to it'; +end; + +function TTriggerResourceChangeTool.ExecuteWithContext(const Params: TNoParams; const Context: IMCPRequestContext): TValue; +begin + var Manager := Context.ManagerRegistry.GetManagerForMethod('resources/list') as TObject; + if not (Manager is TMCPResourcesManager) then + raise EMCPError.InternalError('No resources manager to change'); + + TMCPResourcesManager(Manager).ResourceUpdated(UPDATED_RESOURCE_URI); + Result := TMCPToolResult.Text(Format('Reported %s as updated', [UPDATED_RESOURCE_URI])); +end; + +initialization + TMCPRegistry.RegisterTool('test_trigger_tool_change', + function: IMCPTool + begin + Result := TTriggerToolChangeTool.Create; + end); + TMCPRegistry.RegisterTool('test_trigger_prompt_change', + function: IMCPTool + begin + Result := TTriggerPromptChangeTool.Create; + end); + TMCPRegistry.RegisterTool('test_trigger_resource_change', + function: IMCPTool + begin + Result := TTriggerResourceChangeTool.Create; + end); + +end. diff --git a/tests/MCPServer.Tests.Capabilities.pas b/tests/MCPServer.Tests.Capabilities.pas index 9502eac..84b6a60 100644 --- a/tests/MCPServer.Tests.Capabilities.pas +++ b/tests/MCPServer.Tests.Capabilities.pas @@ -53,10 +53,10 @@ procedure TCapabilityBuilderTests.Registry_YieldsAllManagersInRegistrationOrder; 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.IsFalse(Capabilities.GetValue('tools.listChanged')); - Assert.IsFalse(Capabilities.GetValue('resources.subscribe')); - Assert.IsFalse(Capabilities.GetValue('resources.listChanged')); - Assert.IsFalse(Capabilities.GetValue('prompts.listChanged')); + 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; diff --git a/tests/MCPServer.Tests.Harness.pas b/tests/MCPServer.Tests.Harness.pas index cdf13dc..e9d9bee 100644 --- a/tests/MCPServer.Tests.Harness.pas +++ b/tests/MCPServer.Tests.Harness.pas @@ -9,6 +9,7 @@ interface MCPServer.ToolsManager, MCPServer.ResourcesManager, MCPServer.PromptsManager, + MCPServer.SubscriptionsManager, MCPServer.JsonRpcProcessor; type @@ -20,6 +21,7 @@ TMCPTestHarness = class FToolsManager: TMCPToolsManager; FResourcesManager: TMCPResourcesManager; FPromptsManager: TMCPPromptsManager; + FSubscriptionsManager: TMCPSubscriptionsManager; FProcessor: TMCPJsonRpcProcessor; public constructor Create; @@ -33,6 +35,7 @@ TMCPTestHarness = class property ToolsManager: TMCPToolsManager read FToolsManager; property ResourcesManager: TMCPResourcesManager read FResourcesManager; property PromptsManager: TMCPPromptsManager read FPromptsManager; + property SubscriptionsManager: TMCPSubscriptionsManager read FSubscriptionsManager; end; implementation @@ -55,12 +58,17 @@ constructor TMCPTestHarness.Create; 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; diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index a3fb2c2..9b4c2e9 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -71,11 +71,14 @@ THttpTransportTests = class [Test] procedure Log_OnlyWithLogLevel_InMeta; [Test] procedure InputRequired_StreamsAsFinalEvent; [Test] procedure StreamedError_IsFinalEvent; + [Test] procedure Listen_StreamsAckAndChanges_UntilStopped; + [Test] procedure Listen_WithoutEventStreamAccept_IsInvalidRequest; end; implementation uses + System.Threading, MCPServer.Types; const @@ -551,4 +554,51 @@ procedure THttpTransportTests.StreamedError_IsFinalEvent; Assert.IsTrue(Events[1].Contains('"code":-32021'), Events[1]); end; +procedure THttpTransportTests.Listen_StreamsAckAndChanges_UntilStopped; +const + LISTEN = '{"jsonrpc":"2.0","id":"sub-1","method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true,"resourceSubscriptions":["test://static-text"]},' + MODERN_META + '}}'; + TRIGGER = '{"jsonrpc":"2.0","id":2,"method":"tools/call","params":{"name":"%s","arguments":{},' + MODERN_META + '}}'; +begin + StartServer; + var Listener := TTask.Future( + function: THttpReply + begin + Result := Post(LISTEN, ['Accept: application/json, text/event-stream', MODERN_VERSION_HEADER, 'Mcp-Method: subscriptions/listen']); + end); + + var Deadline := TThread.GetTickCount64 + 2000; + while (FHarness.SubscriptionsManager.ActiveCount = 0) and (TThread.GetTickCount64 < Deadline) do + Sleep(10); + Assert.AreEqual(1, FHarness.SubscriptionsManager.ActiveCount, 'the subscription is open'); + + Post(Format(TRIGGER, ['test_trigger_tool_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_tool_change']); + Post(Format(TRIGGER, ['test_trigger_prompt_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_prompt_change']); + Post(Format(TRIGGER, ['test_trigger_resource_change']), [MODERN_VERSION_HEADER, 'Mcp-Method: tools/call', 'Mcp-Name: test_trigger_resource_change']); + FServer.Stop; + + var Reply := Listener.Value; + Assert.AreEqual(200, Reply.Status); + var Events := Reply.Body.Split([#10#10], TStringSplitOptions.ExcludeEmpty); + Assert.AreEqual(4, Integer(Length(Events)), Reply.Body); + Assert.IsTrue(Events[0].Contains('"method":"notifications/subscriptions/acknowledged"'), Events[0]); + Assert.IsTrue(Events[0].Contains('"toolsListChanged":true'), Events[0]); + Assert.IsTrue(Events[0].Contains('"resourceSubscriptions":["test://static-text"]'), Events[0]); + Assert.IsTrue(Events[0].Contains('"io.modelcontextprotocol/subscriptionId":"sub-1"'), Events[0]); + Assert.IsTrue(Events[1].Contains('"method":"notifications/tools/list_changed"'), Events[1]); + Assert.IsTrue(Events[2].Contains('"method":"notifications/resources/updated"'), Events[2]); + Assert.IsTrue(Events[2].Contains('"uri":"test://static-text"'), Events[2]); + Assert.IsFalse(Reply.Body.Contains('prompts/list_changed'), 'not requested'); + Assert.IsTrue(Events[3].Contains('"id":"sub-1"'), Events[3]); + Assert.IsTrue(Events[3].Contains('"resultType":"complete"'), Events[3]); + Assert.IsTrue(Events[3].Contains('"io.modelcontextprotocol/subscriptionId":"sub-1"'), Events[3]); +end; + +procedure THttpTransportTests.Listen_WithoutEventStreamAccept_IsInvalidRequest; +begin + var Reply := Post('{"jsonrpc":"2.0","id":1,"method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true},' + MODERN_META + '}}', + [MODERN_VERSION_HEADER, 'Mcp-Method: subscriptions/listen']); + Assert.AreEqual(400, Reply.Status); + Assert.IsTrue(Reply.Body.Contains('-32600'), Reply.Body); +end; + end. diff --git a/tests/MCPServer.Tests.Processor.pas b/tests/MCPServer.Tests.Processor.pas index 61c883d..17fc875 100644 --- a/tests/MCPServer.Tests.Processor.pas +++ b/tests/MCPServer.Tests.Processor.pas @@ -214,8 +214,8 @@ procedure TProcessorTests.Modern_Discover_ListsModernVersionsAndCapabilities; var Versions := Response.FindValue('result.supportedVersions') as TJSONArray; Assert.AreEqual(1, Versions.Count); Assert.AreEqual('2026-07-28', Versions.Items[0].Value); - Assert.IsFalse(Response.GetValue('result.capabilities.tools.listChanged')); - Assert.IsFalse(Response.GetValue('result.capabilities.resources.subscribe')); + 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')); diff --git a/tests/MCPServer.Tests.Registration.pas b/tests/MCPServer.Tests.Registration.pas index f85ffd1..c09df91 100644 --- a/tests/MCPServer.Tests.Registration.pas +++ b/tests/MCPServer.Tests.Registration.pas @@ -34,7 +34,7 @@ procedure TRegistryTests.BuiltInTools_AreRegisteredFromInitialization; Assert.IsTrue(TMCPRegistry.HasTool('get_time')); Assert.IsTrue(TMCPRegistry.HasTool('list_files')); Assert.IsTrue(TMCPRegistry.HasTool('calculate')); - Assert.AreEqual(23, Integer(Length(TMCPRegistry.GetToolNames))); + Assert.AreEqual(26, Integer(Length(TMCPRegistry.GetToolNames))); end; procedure TRegistryTests.BuiltInResources_AreRegisteredFromInitialization; diff --git a/tests/MCPServer.Tests.Stdio.pas b/tests/MCPServer.Tests.Stdio.pas index 7d93130..31f6a4f 100644 --- a/tests/MCPServer.Tests.Stdio.pas +++ b/tests/MCPServer.Tests.Stdio.pas @@ -22,6 +22,7 @@ TStdioTransportTests = class const Separator: string = #10): TArray; function ParseLine(const Line: string): TJSONObject; function FindById(const Lines: TArray; const Id: string): TJSONObject; + function FindNotification(const Lines: TArray; const Method: string): TJSONObject; public [Setup] procedure Setup; @@ -38,6 +39,8 @@ TStdioTransportTests = class [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 @@ -106,6 +109,19 @@ function TStdioTransportTests.FindById(const Lines: TArray; const Id: st Result := nil; end; +function TStdioTransportTests.FindNotification(const Lines: TArray; const Method: string): TJSONObject; +begin + for var Line in Lines do + begin + var Json := ParseLine(Line); + var MethodValue := Json.GetValue('method'); + if IsJsonString(MethodValue) and (TJSONString(MethodValue).Value = Method) then + Exit(Json); + Json.Free; + end; + Result := nil; +end; + procedure TStdioTransportTests.Handshake_And_ToolsList; begin var Lines := Run([INITIALIZE, INITIALIZED, '{"jsonrpc":"2.0","id":2,"method":"tools/list"}']); @@ -258,4 +274,61 @@ procedure TStdioTransportTests.Eof_WithRunningRequest_ReturnsAfterDrain; Assert.IsTrue(FElapsedMs < 3000, 'Run returned after the drain timeout: ' + FElapsedMs.ToString + ' ms'); end; +procedure TStdioTransportTests.Listen_AckThenCancel_HasNoResponse; +const + LISTEN = '{"jsonrpc":"2.0","id":9,"method":"subscriptions/listen","params":{"notifications":{"toolsListChanged":true},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + CANCEL = '{"jsonrpc":"2.0","method":"notifications/cancelled","params":{"requestId":9}}'; + PING = '{"jsonrpc":"2.0","id":10,"method":"ping"}'; +begin + var Lines := Run([LISTEN, PING, CANCEL]); + Assert.AreEqual(2, Integer(Length(Lines)), string.Join(' | ', Lines)); + var Ack := FindNotification(Lines, 'notifications/subscriptions/acknowledged'); + try + Assert.IsNotNull(Ack, 'the subscription is acknowledged'); + Assert.AreEqual(9, TJSONNumber(TJSONObject(Ack.FindValue('params._meta')).GetValue(MCP_META_SUBSCRIPTION_ID)).AsInt); + Assert.IsTrue(Ack.GetValue('params.notifications.toolsListChanged')); + finally + Ack.Free; + end; + var Pong := FindById(Lines, '10'); + try + Assert.IsNotNull(Pong, 'ping is answered while a subscription is open'); + finally + Pong.Free; + end; + var Response := FindById(Lines, '9'); + Assert.IsNull(Response, 'a cancelled subscription gets no response'); +end; + +procedure TStdioTransportTests.Listen_Eof_ClosesGracefully; +const + LISTEN = '{"jsonrpc":"2.0","id":9,"method":"subscriptions/listen","params":{"notifications":{"promptsListChanged":true},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + TRIGGER = '{"jsonrpc":"2.0","id":11,"method":"tools/call","params":{"name":"test_trigger_prompt_change","arguments":{},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}}}'; + SLOW = '{"jsonrpc":"2.0","id":10,"method":"tools/call","params":{"name":"test_tool_with_progress","arguments":{"steps":3,"stepMs":100}}}'; +begin + var Lines := Run([LISTEN, SLOW, TRIGGER]); + Assert.IsTrue(Length(Lines) >= 4, string.Join(' | ', Lines)); + var Ack := FindNotification(Lines, 'notifications/subscriptions/acknowledged'); + try + Assert.IsNotNull(Ack, 'the subscription is acknowledged'); + finally + Ack.Free; + end; + var Changed := False; + for var Line in Lines do + begin + if Line.Contains('"notifications/prompts/list_changed"') then + Changed := True; + end; + Assert.IsTrue(Changed, 'the prompt change reached the subscription'); + var Response := FindById(Lines, '9'); + try + Assert.IsNotNull(Response, 'stdin closing ends the subscription with a response'); + Assert.AreEqual('complete', Response.GetValue('result.resultType')); + Assert.AreEqual(9, TJSONNumber(TJSONObject(Response.FindValue('result._meta')).GetValue(MCP_META_SUBSCRIPTION_ID)).AsInt); + finally + Response.Free; + end; +end; + end. diff --git a/tests/MCPServer.Tests.Subscriptions.pas b/tests/MCPServer.Tests.Subscriptions.pas new file mode 100644 index 0000000..a3128ce --- /dev/null +++ b/tests/MCPServer.Tests.Subscriptions.pas @@ -0,0 +1,458 @@ +unit MCPServer.Tests.Subscriptions; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.SyncObjs, + System.JSON, + MCPServer.Types, + MCPServer.RequestContext, + MCPServer.SubscriptionsManager; + +type + TLockedSink = class(TInterfacedObject, IMCPMessageSink, IMCPKeepAlive) + strict private + FLock: TCriticalSection; + FMessages: TStringList; + FKeepAlives: Integer; + public + constructor Create; + destructor Destroy; override; + procedure Send(const Json: string); + procedure KeepAlive; + function Messages: TArray; + function Count: Integer; + property KeepAlives: Integer read FKeepAlives; + end; + + TRecordingHub = class(TInterfacedObject, IMCPSubscriptionHub) + public + Events: TStringList; + constructor Create; + destructor Destroy; override; + procedure ToolsListChanged; + procedure PromptsListChanged; + procedure ResourcesListChanged; + procedure ResourceUpdated(const Uri: string); + procedure CloseAll(const Reason: string); + function ActiveCount: Integer; + end; + + [TestFixture] + TSubscriptionsTests = class + private + FManager: TMCPSubscriptionsManager; + FManagerRef: IInterface; + FSink: TLockedSink; + FSinkRef: IMCPMessageSink; + FContext: IMCPRequestContext; + FResult: TJSONObject; + FError: string; + FThread: TThread; + procedure StartListen(const ParamsJson: string); + procedure WaitUntilOpen; + procedure JoinListen; + function Parse(const Json: string): TJSONObject; + function SubscriptionIdOf(const Json: TJSONObject; const MetaPath: string): Integer; + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] procedure Filter_FromJson_HonoursBooleansAndUris; + [Test] procedure Listen_AckFirst_ThenTaggedNotifications_ThenCompletion; + [Test] procedure Listen_UnrequestedNotifications_AreNotSent; + [Test] procedure Listen_Cancel_EndsTheWait; + [Test] procedure Listen_KeepAlive_OnInterval; + [Test] procedure Listen_WithoutSink_IsInvalidRequest; + [Test] procedure Listen_NotificationsNotObject_IsInvalidParams; + [Test] procedure Managers_NotifyTheHub_AndAnnounceCapabilities; + end; + +implementation + +uses + MCPServer.Errors, + MCPServer.ToolsManager, + MCPServer.PromptsManager, + MCPServer.ResourcesManager, + MCPServer.Tool.ContentSamples, + MCPServer.Prompt.ContentSamples; + +const + MODERN_META = '{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientCapabilities":{}}'; + WAIT_MS = 3000; + +{ TLockedSink } + +constructor TLockedSink.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FMessages := TStringList.Create; +end; + +destructor TLockedSink.Destroy; +begin + FMessages.Free; + FLock.Free; + inherited; +end; + +procedure TLockedSink.Send(const Json: string); +begin + FLock.Enter; + try + FMessages.Add(Json); + finally + FLock.Leave; + end; +end; + +procedure TLockedSink.KeepAlive; +begin + AtomicIncrement(FKeepAlives); +end; + +function TLockedSink.Messages: TArray; +begin + FLock.Enter; + try + Result := FMessages.ToStringArray; + finally + FLock.Leave; + end; +end; + +function TLockedSink.Count: Integer; +begin + Result := Integer(Length(Messages)); +end; + +{ TRecordingHub } + +constructor TRecordingHub.Create; +begin + inherited Create; + Events := TStringList.Create; +end; + +destructor TRecordingHub.Destroy; +begin + Events.Free; + inherited; +end; + +procedure TRecordingHub.ToolsListChanged; +begin + Events.Add('tools'); +end; + +procedure TRecordingHub.PromptsListChanged; +begin + Events.Add('prompts'); +end; + +procedure TRecordingHub.ResourcesListChanged; +begin + Events.Add('resources'); +end; + +procedure TRecordingHub.ResourceUpdated(const Uri: string); +begin + Events.Add('updated:' + Uri); +end; + +procedure TRecordingHub.CloseAll(const Reason: string); +begin + Events.Add('close'); +end; + +function TRecordingHub.ActiveCount: Integer; +begin + Result := 0; +end; + +{ TSubscriptionsTests } + +procedure TSubscriptionsTests.Setup; +begin + FManager := TMCPSubscriptionsManager.Create; + FManagerRef := FManager; + FSink := TLockedSink.Create; + FSinkRef := FSink; + FResult := nil; + FError := ''; + FThread := nil; +end; + +procedure TSubscriptionsTests.TearDown; +begin + FManager.CloseAll('teardown'); + JoinListen; + FResult.Free; + FContext := nil; + FSinkRef := nil; + FManagerRef := nil; +end; + +function TSubscriptionsTests.SubscriptionIdOf(const Json: TJSONObject; const MetaPath: string): Integer; +begin + var Meta := Json.FindValue(MetaPath); + Assert.IsTrue(Meta is TJSONObject, MetaPath); + var Id := TJSONObject(Meta).GetValue(MCP_META_SUBSCRIPTION_ID); + Assert.IsTrue(Id is TJSONNumber, MCP_META_SUBSCRIPTION_ID); + Result := TJSONNumber(Id).AsInt; +end; + +function TSubscriptionsTests.Parse(const Json: string): TJSONObject; +begin + Result := TJSONObject.ParseJSONValue(Json) as TJSONObject; + Assert.IsNotNull(Result, Json); +end; + +procedure TSubscriptionsTests.StartListen(const ParamsJson: string); +begin + var Meta := TJSONObject.ParseJSONValue(MODERN_META) as TJSONObject; + try + FContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(5), Meta, nil, nil, FSinkRef); + finally + Meta.Free; + end; + + var Params := TJSONObject.ParseJSONValue(ParamsJson) as TJSONObject; + var Context := FContext; + FThread := TThread.CreateAnonymousThread( + procedure + begin + try + try + FResult := FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, Params, Context).AsType; + except + on E: Exception do + FError := E.ClassName + ': ' + E.Message; + end; + finally + Params.Free; + end; + end); + FThread.FreeOnTerminate := False; + FThread.Start; +end; + +procedure TSubscriptionsTests.WaitUntilOpen; +begin + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FManager.ActiveCount = 0) and (FError = '') and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.AreEqual('', FError); + Assert.AreEqual(1, FManager.ActiveCount, 'the subscription is registered'); +end; + +procedure TSubscriptionsTests.JoinListen; +begin + if not Assigned(FThread) then + Exit; + FThread.WaitFor; + FreeAndNil(FThread); +end; + +procedure TSubscriptionsTests.Filter_FromJson_HonoursBooleansAndUris; +begin + var Json := TJSONObject.ParseJSONValue( + '{"toolsListChanged":true,"promptsListChanged":"yes","resourcesListChanged":false,"resourceSubscriptions":["a://x",7,""]}'); + try + var Filter := TMCPSubscriptionFilter.FromJson(Json); + Assert.IsTrue(Filter.ToolsListChanged); + Assert.IsFalse(Filter.PromptsListChanged, 'only a JSON true counts'); + Assert.IsFalse(Filter.ResourcesListChanged); + Assert.AreEqual(1, Integer(Length(Filter.ResourceSubscriptions))); + Assert.IsTrue(Filter.WantsResource('a://x')); + Assert.IsFalse(Filter.WantsResource('a://y')); + var Honoured := Filter.ToJson; + try + Assert.IsTrue(Honoured.GetValue('toolsListChanged')); + Assert.IsNull(Honoured.GetValue('promptsListChanged')); + Assert.AreEqual('a://x', Honoured.GetValue('resourceSubscriptions[0]')); + finally + Honoured.Free; + end; + finally + Json.Free; + end; + var Empty := TMCPSubscriptionFilter.FromJson(nil).ToJson; + try + Assert.AreEqual(0, Empty.Count); + finally + Empty.Free; + end; +end; + +procedure TSubscriptionsTests.Listen_AckFirst_ThenTaggedNotifications_ThenCompletion; +begin + StartListen('{"notifications":{"toolsListChanged":true,"resourceSubscriptions":["a://x"]}}'); + WaitUntilOpen; + Assert.AreEqual(1, FSink.Count, 'the acknowledgement is the first message'); + + FManager.ToolsListChanged; + FManager.ResourceUpdated('a://x'); + FManager.ResourceUpdated('a://other'); + FManager.CloseAll('test'); + FThread.WaitFor; + Assert.AreEqual('', FError); + + var Messages := FSink.Messages; + Assert.AreEqual(3, Integer(Length(Messages)), string.Join(' | ', Messages)); + var Ack := Parse(Messages[0]); + var Changed := Parse(Messages[1]); + var Updated := Parse(Messages[2]); + try + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_SUBSCRIPTIONS_ACKNOWLEDGED, Ack.GetValue('method')); + Assert.AreEqual(5, SubscriptionIdOf(Ack, 'params._meta')); + Assert.IsTrue(Ack.GetValue('params.notifications.toolsListChanged')); + Assert.AreEqual('a://x', Ack.GetValue('params.notifications.resourceSubscriptions[0]')); + Assert.IsNull(Ack.GetValue('id')); + + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_TOOLS_LIST_CHANGED, Changed.GetValue('method')); + Assert.AreEqual(5, SubscriptionIdOf(Changed, 'params._meta')); + + Assert.AreEqual(MCP_METHOD_NOTIFICATIONS_RESOURCES_UPDATED, Updated.GetValue('method')); + Assert.AreEqual('a://x', Updated.GetValue('params.uri')); + finally + Ack.Free; + Changed.Free; + Updated.Free; + end; + + Assert.IsNotNull(FResult, 'closing on the server side completes the request'); + Assert.AreEqual(5, SubscriptionIdOf(FResult, '_meta')); + Assert.AreEqual(0, FManager.ActiveCount); +end; + +procedure TSubscriptionsTests.Listen_UnrequestedNotifications_AreNotSent; +begin + StartListen('{"notifications":{"promptsListChanged":true}}'); + WaitUntilOpen; + FManager.ToolsListChanged; + FManager.ResourcesListChanged; + FManager.ResourceUpdated('a://x'); + FManager.PromptsListChanged; + FManager.CloseAll('test'); + FThread.WaitFor; + + var Messages := FSink.Messages; + Assert.AreEqual(2, Integer(Length(Messages)), string.Join(' | ', Messages)); + Assert.IsTrue(Messages[1].Contains(MCP_METHOD_NOTIFICATIONS_PROMPTS_LIST_CHANGED), Messages[1]); +end; + +procedure TSubscriptionsTests.Listen_Cancel_EndsTheWait; +begin + StartListen('{"notifications":{"toolsListChanged":true}}'); + WaitUntilOpen; + FContext.Cancel; + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FManager.ActiveCount > 0) and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.AreEqual(0, FManager.ActiveCount, 'cancellation ends the subscription'); + FThread.WaitFor; + Assert.AreEqual(1, FSink.Count, 'nothing after the acknowledgement'); +end; + +procedure TSubscriptionsTests.Listen_KeepAlive_OnInterval; +begin + FManager.KeepAliveIntervalMs := TMCPSubscriptionsManager.POLL_INTERVAL_MS; + StartListen('{}'); + WaitUntilOpen; + var Deadline := TThread.GetTickCount64 + WAIT_MS; + while (FSink.KeepAlives < 2) and (TThread.GetTickCount64 < Deadline) do + Sleep(5); + Assert.IsTrue(FSink.KeepAlives >= 2, 'keep-alives are sent while the subscription is quiet'); + Assert.AreEqual(1, FSink.Count, 'keep-alives are not messages'); +end; + +procedure TSubscriptionsTests.Listen_WithoutSink_IsInvalidRequest; +begin + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(1), nil, nil, nil, nil); + try + FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, nil, Context).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_REQUEST, E.Code); + end; +end; + +procedure TSubscriptionsTests.Listen_NotificationsNotObject_IsInvalidParams; +begin + var Context: IMCPRequestContext := TMCPRequestContext.Create(TMCPProtocolEra.Modern, MCP_LATEST_PROTOCOL_VERSION, + MCP_METHOD_SUBSCRIPTIONS_LISTEN, TMCPRequestId.FromNumber(1), nil, nil, nil, FSinkRef); + var Params := TJSONObject.ParseJSONValue('{"notifications":[1]}') as TJSONObject; + try + try + FManager.ExecuteMethodWithContext(MCP_METHOD_SUBSCRIPTIONS_LISTEN, Params, Context).AsType.Free; + Assert.Fail('expected an error'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; + finally + Params.Free; + end; +end; + +procedure TSubscriptionsTests.Managers_NotifyTheHub_AndAnnounceCapabilities; +begin + var Hub := TRecordingHub.Create; + var HubRef: IMCPSubscriptionHub := Hub; + var Tools := TMCPToolsManager.Create; + var Prompts := TMCPPromptsManager.Create; + var Resources := TMCPResourcesManager.Create; + var ToolsRef: IInterface := Tools; + var PromptsRef: IInterface := Prompts; + var ResourcesRef: IInterface := Resources; + var Legacy := TJSONObject.Create; + var Modern := TJSONObject.Create; + try + Tools.DescribeCapabilities(Legacy, TMCPProtocolEra.Legacy); + Assert.IsFalse(Legacy.GetValue('tools.listChanged'), 'without a hub nothing is announced'); + Legacy.RemovePair('tools').Free; + + Tools.ChangeNotifier := HubRef; + Prompts.ChangeNotifier := HubRef; + Resources.ChangeNotifier := HubRef; + Tools.DescribeCapabilities(Legacy, TMCPProtocolEra.Legacy); + Tools.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Resources.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Prompts.DescribeCapabilities(Modern, TMCPProtocolEra.Modern); + Assert.IsFalse(Legacy.GetValue('tools.listChanged'), 'legacy clients cannot listen'); + Assert.IsTrue(Modern.GetValue('tools.listChanged')); + Assert.IsTrue(Modern.GetValue('prompts.listChanged')); + Assert.IsTrue(Modern.GetValue('resources.listChanged')); + Assert.IsTrue(Modern.GetValue('resources.subscribe')); + + Tools.AddTool(TSimpleTextTool.Create); + Assert.IsTrue(Tools.HasTool('test_simple_text')); + Tools.RemoveTool('test_simple_text'); + Tools.RemoveTool('test_simple_text'); + Assert.IsFalse(Tools.HasTool('test_simple_text')); + Prompts.AddPrompt(TSimplePrompt.Create); + Prompts.RemovePrompt('test_simple_prompt'); + Resources.ResourceUpdated('a://x'); + Assert.AreEqual('tools,tools,prompts,prompts,updated:a://x', string.Join(',', Hub.Events.ToStringArray)); + finally + Modern.Free; + Legacy.Free; + ResourcesRef := nil; + PromptsRef := nil; + ToolsRef := nil; + HubRef := nil; + end; +end; + +end. diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index ff5f3ac..fc14db8 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -32,6 +32,7 @@ uses MCPServer.ResourcesManager in '..\src\Managers\MCPServer.ResourcesManager.pas', MCPServer.PromptsManager in '..\src\Managers\MCPServer.PromptsManager.pas', MCPServer.CompletionManager in '..\src\Managers\MCPServer.CompletionManager.pas', + MCPServer.SubscriptionsManager in '..\src\Managers\MCPServer.SubscriptionsManager.pas', MCPServer.StdioTransport in '..\src\Server\MCPServer.StdioTransport.pas', MCPServer.StdioChannel in '..\src\Server\MCPServer.StdioChannel.pas', // The built-in tools and resources register themselves in their @@ -46,6 +47,7 @@ uses 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', @@ -74,6 +76,7 @@ uses 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.PromptsManager in 'MCPServer.Tests.PromptsManager.pas', MCPServer.Tests.CompletionManager in 'MCPServer.Tests.CompletionManager.pas'; diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 0c27bdb..4599dd0 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -96,6 +96,7 @@ + @@ -104,6 +105,7 @@ + @@ -134,6 +136,7 @@ + diff --git a/tests/golden/http/modern-discover.txt b/tests/golden/http/modern-discover.txt index 11034c6..c536011 100644 --- a/tests/golden/http/modern-discover.txt +++ b/tests/golden/http/modern-discover.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 371 +Content-Length: 367 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":false},"resources":{"subscribe":false,"listChanged":false},"prompts":{"listChanged":false},"completions":{}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} +{"jsonrpc":"2.0","id":"d1","result":{"resultType":"complete","supportedVersions":["2026-07-28"],"capabilities":{"tools":{"listChanged":true},"resources":{"subscribe":true,"listChanged":true},"prompts":{"listChanged":true},"completions":{}},"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}},"ttlMs":0,"cacheScope":"public"}} diff --git a/tests/golden/http/modern-tools-list.txt b/tests/golden/http/modern-tools-list.txt index 0c4778f..28861bd 100644 --- a/tests/golden/http/modern-tools-list.txt +++ b/tests/golden/http/modern-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 5668 +Content-Length: 6327 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} +{"jsonrpc":"2.0","id":20,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}],"ttlMs":0,"cacheScope":"private","resultType":"complete","_meta":{"io.modelcontextprotocol/serverInfo":{"name":"delphi-mcp-server","version":"1.0.0"}}}} diff --git a/tests/golden/http/post-tools-list-sse.txt b/tests/golden/http/post-tools-list-sse.txt index 2a0c56a..07775b6 100644 --- a/tests/golden/http/post-tools-list-sse.txt +++ b/tests/golden/http/post-tools-list-sse.txt @@ -1,7 +1,7 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: text/event-stream; charset=utf-8 -Content-Length: 5539 +Content-Length: 6198 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID @@ -11,4 +11,4 @@ Cache-Control: no-cache X-Accel-Buffering: no event: message -data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +data: {"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/http/post-tools-list.txt b/tests/golden/http/post-tools-list.txt index b94d322..697196b 100644 --- a/tests/golden/http/post-tools-list.txt +++ b/tests/golden/http/post-tools-list.txt @@ -1,11 +1,11 @@ HTTP/1.1 200 OK Connection: keep-alive Content-Type: application/json -Content-Length: 5516 +Content-Length: 6175 Access-Control-Allow-Origin: * Access-Control-Allow-Methods: POST, OPTIONS Access-Control-Allow-Headers: Accept, Content-Type, Authorization, MCP-Protocol-Version, Mcp-Method, Mcp-Name, Mcp-Session-Id, Last-Event-ID Access-Control-Expose-Headers: Mcp-Session-Id, WWW-Authenticate Access-Control-Max-Age: 86400 -{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} +{"jsonrpc":"2.0","id":2,"result":{"tools":[{"name":"echo","description":"Echo a message back to the user","inputSchema":{"type":"object","properties":{"message":{"type":"string","description":"Message to echo back"}},"required":["message"]}},{"name":"get_time","description":"Get the current server time in ISO format","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"list_files","description":"List files in a directory","inputSchema":{"type":"object","properties":{"path":{"type":"string","description":"Directory path to list files from"},"includehidden":{"type":"boolean","description":"Include hidden files in the listing"}},"required":["path"]}},{"name":"calculate","description":"Perform basic arithmetic calculations","inputSchema":{"type":"object","properties":{"operation":{"type":"string","description":"Operation: add, subtract, multiply, divide","enum":["add","subtract","multiply","divide"]},"a":{"type":"number","description":"First number"},"b":{"type":"number","description":"Second number"}},"required":["operation","a","b"]}},{"name":"test_simple_text","description":"Returns a plain text result","inputSchema":{"type":"object","properties":{},"additionalProperties":false},"annotations":{"readOnlyHint":true}},{"name":"test_image_content","description":"Returns an image content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_audio_content","description":"Returns an audio content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_embedded_resource","description":"Returns an embedded resource content block","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_multiple_content_types","description":"Returns text, image and embedded resource content in one result","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_tool_with_progress","description":"Runs a few steps and reports progress for each; honours cancellation","inputSchema":{"type":"object","properties":{"steps":{"type":"integer","description":"Number of steps to report (default 5)"},"stepms":{"type":"integer","description":"Pause per step in milliseconds (default 100)"}}}},{"name":"test_error_handling","description":"Always fails with a tool execution error","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_logging_tool","description":"Emits log notifications at every level; the client sees those at or above its requested level","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"json_schema_2020_12_tool","description":"Tool with JSON Schema 2020-12 features","inputSchema":{"$schema":"https://json-schema.org/draft/2020-12/schema","type":"object","$defs":{"address":{"$anchor":"addressDef","type":"object","properties":{"street":{"type":"string"},"city":{"type":"string"}}}},"properties":{"name":{"type":"string"},"address":{"$ref":"#/$defs/address"},"contactMethod":{"type":"string","enum":["phone","email"]},"phone":{"type":"string"},"email":{"type":"string"}},"allOf":[{"anyOf":[{"required":["phone"]},{"required":["email"]}]}],"if":{"properties":{"contactMethod":{"const":"phone"}},"required":["contactMethod"]},"then":{"required":["phone"]},"else":{"required":["email"]},"additionalProperties":false}},{"name":"test_input_required_result_elicitation","description":"Asks the client for a name through an elicitation input request, then greets it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_sampling","description":"Asks the client to sample an answer, then returns that answer","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_list_roots","description":"Asks the client for its roots, then lists them","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_request_state","description":"Asks for a confirmation and carries a signed requestState across the round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multiple_inputs","description":"Asks for a name, a sampled greeting and the client roots in one round trip","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_multi_round","description":"Asks for a name and then a colour in two consecutive round trips","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_tampered_state","description":"Asks for a confirmation with a signed requestState that must come back unchanged","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_input_required_result_capabilities","description":"Asks only for the kinds of input the client declared it can provide","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_missing_capability","description":"Requires the sampling client capability and fails with -32021 when it is absent","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_streaming_elicitation","description":"Logs to the response stream, then asks the client for a confirmation","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_tool_change","description":"Adds or removes test_dynamic_tool, which notifies subscribed clients that the tool list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_prompt_change","description":"Adds or removes test_dynamic_prompt, which notifies subscribed clients that the prompt list changed","inputSchema":{"type":"object","properties":{},"additionalProperties":false}},{"name":"test_trigger_resource_change","description":"Reports test://static-text as updated to the clients subscribed to it","inputSchema":{"type":"object","properties":{},"additionalProperties":false}}]}} diff --git a/tests/golden/legacy/tools-list.json b/tests/golden/legacy/tools-list.json index 10ff171..4046524 100644 --- a/tests/golden/legacy/tools-list.json +++ b/tests/golden/legacy/tools-list.json @@ -356,6 +356,36 @@ }, "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/modern/server-discover.json b/tests/golden/modern/server-discover.json index 6aeddfb..e8c2d7a 100644 --- a/tests/golden/modern/server-discover.json +++ b/tests/golden/modern/server-discover.json @@ -25,14 +25,14 @@ ], "capabilities": { "tools": { - "listChanged": false + "listChanged": true }, "resources": { - "subscribe": false, - "listChanged": false + "subscribe": true, + "listChanged": true }, "prompts": { - "listChanged": false + "listChanged": true }, "completions": { } diff --git a/tests/golden/modern/tools-list.json b/tests/golden/modern/tools-list.json index 2b64d4e..5f03ac8 100644 --- a/tests/golden/modern/tools-list.json +++ b/tests/golden/modern/tools-list.json @@ -367,6 +367,36 @@ }, "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, From c91aef25ad3ea74ac407bd5a7d87feec0ed24cb3 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:28:30 +0200 Subject: [PATCH 50/56] docs: describe subscriptions and change notifications --- CHANGELOG.md | 16 ++++++++++++++++ MIGRATION.md | 22 ++++++++++++++++++++++ README.md | 31 +++++++++++++++++++++++++++++++ 3 files changed, 69 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index fb97108..ca405ee 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -184,6 +184,22 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). 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`. +- `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. diff --git a/MIGRATION.md b/MIGRATION.md index 89eb327..32c92b1 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -162,6 +162,28 @@ at startup. `RequestStateTtlSeconds` bounds the replay window (600 s). nine new example tools plus one example prompt ship with the executable; they are only registered when their units are in the project. +## Subscriptions + +**`subscriptions/listen` replaces `resources/subscribe` and the GET stream.** +The shipped executable registers `TMCPSubscriptionsManager` and assigns it as +`ChangeNotifier` of the tools, prompts and resources managers, so +`server/discover` now announces `tools.listChanged`, `prompts.listChanged`, +`resources.listChanged` and `resources.subscribe` to modern clients (the +`initialize` result for legacy clients still says `false`: those clients have +no stream to receive the notifications on). A library that registers the +managers itself keeps the old behaviour until it does the same. + +**Adding or removing a tool, prompt or resource at run time notifies +subscribed clients.** `AddTool`, `AddPrompt`, `AddResource` and +`AddResourceTemplate` were already there; `RemoveTool`, `RemovePrompt`, +`RemoveResource`, `HasTool`, `HasPrompt` and +`TMCPResourcesManager.ResourceUpdated` are new. The managers guard their +lists with a lock now, so run-time changes are safe from any thread. + +**Shutdown waits for subscriptions.** `TMCPIdHTTPServer.Stop` and the end of +stdin close the open subscriptions with a completion response before the +transport goes down (up to one second, or the stdio drain time). + ## Library use - `TMCPJsonRpcProcessor.ProcessRequest` and the manager interfaces are diff --git a/README.md b/README.md index a58b496..a5f3309 100644 --- a/README.md +++ b/README.md @@ -155,6 +155,32 @@ notifications first and the JSON-RPC response as its last event. A request that sends none is answered as before. A client that closes the stream cancels the request. +### Change notifications (`subscriptions/listen`) + +A modern client that wants to hear about changes opens a long-lived +`subscriptions/listen` request with a `notifications` filter +(`toolsListChanged`, `promptsListChanged`, `resourcesListChanged`, +`resourceSubscriptions`: a list of URIs). `TMCPSubscriptionsManager` +(`MCPServer.SubscriptionsManager`) answers with +`notifications/subscriptions/acknowledged` carrying the honoured filter and +keeps the stream open: over HTTP as an SSE response with a keep-alive comment +every 15 seconds, over stdio on a thread of its own so the worker threads stay +free. Every message on the subscription carries +`_meta.io.modelcontextprotocol/subscriptionId`, the JSON-RPC id of the +`subscriptions/listen` request. Closing the SSE stream, or sending +`notifications/cancelled` for that id over stdio, ends the subscription; +when the server stops (or stdin closes) it answers the request with a +completion result first. + +Assign the manager as `ChangeNotifier` of the tools, prompts and resources +managers, as `MCPServer.dpr` does, and the `tools`, `prompts` and `resources` +capabilities announce `listChanged` (and `resources.subscribe`) to modern +clients. `AddTool`, `RemoveTool`, `AddPrompt`, `RemovePrompt`, `AddResource`, +`RemoveResource` and `AddResourceTemplate` then notify the subscribed clients, +and `TMCPResourcesManager.ResourceUpdated(Uri)` reports a changed resource to +the clients that subscribed to that URI. Without a `ChangeNotifier` nothing is +announced and nothing is sent. + ## Protocol Versions and Dual-Era Behaviour The server decides per request which protocol era it is speaking; nothing is negotiated per connection and no session is minted. @@ -741,6 +767,11 @@ The Inspector provides a web interface to interact with your MCP server, making 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 From 1206a69019039809fb05410f92d57dcc997460d8 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:41:43 +0200 Subject: [PATCH 51/56] feat: bearer authentication for the HTTP endpoint MCPServer.Authorization adds IMCPAuthorizer with a static bearer authorizer (constant-time comparison), an abstract OAuth resource-server base that requires the audience and expiry claims and checks scopes, and an RFC 7662 introspection authorizer. TMCPIdHTTPServer.Authorizer gates every request except OPTIONS and the RFC 9728 protected resource metadata document; failures answer 401, 403 or 400 with a WWW-Authenticate Bearer challenge that names the metadata URL. Tools can demand a scope with [RequiresScope]; the request context exposes the principal and its scopes and the request state sealer binds tokens to the principal. [Auth] BearerTokens, AuthorizationServers, ResourceUri and ScopesSupported configure the executable. --- settings.ini.example | 16 + src/Core/MCPServer.Authorization.pas | 440 ++++++++++++++++++++ src/Core/MCPServer.Settings.pas | 58 +++ src/MCPServer.dpr | 3 + src/MCPServer.dproj | 1 + src/Managers/MCPServer.ToolsManager.pas | 23 + src/Protocol/MCPServer.Errors.pas | 17 + src/Protocol/MCPServer.JsonRpcProcessor.pas | 33 +- src/Protocol/MCPServer.RequestContext.pas | 33 +- src/Protocol/MCPServer.RequestState.pas | 23 +- src/Protocol/MCPServer.Types.pas | 29 ++ src/Server/MCPServer.IdHTTPServer.pas | 145 ++++++- 12 files changed, 783 insertions(+), 38 deletions(-) create mode 100644 src/Core/MCPServer.Authorization.pas diff --git a/settings.ini.example b/settings.ini.example index c2b6080..49b052d 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -42,6 +42,22 @@ 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 diff --git a/src/Core/MCPServer.Authorization.pas b/src/Core/MCPServer.Authorization.pas new file mode 100644 index 0000000..84fbb03 --- /dev/null +++ b/src/Core/MCPServer.Authorization.pas @@ -0,0 +1,440 @@ +unit MCPServer.Authorization; + +interface + +uses + System.SysUtils, + System.JSON, + MCPServer.Types; + +type + TMCPAuthDecision = (Allow, Unauthorized, Forbidden, BadRequest); + + TMCPPrincipal = record + Subject: string; + Scopes: TArray; + function HasScope(const Scope: string): Boolean; + class function None: TMCPPrincipal; static; + end; + + TMCPAuthChallenge = record + Error: string; + ErrorDescription: string; + Scope: string; + class function None: TMCPAuthChallenge; static; + class function InvalidToken(const Description: string): TMCPAuthChallenge; static; + class function InvalidRequest(const Description: string): TMCPAuthChallenge; static; + class function InsufficientScope(const Scope: string): TMCPAuthChallenge; static; + end; + + IMCPAuthorizer = interface + ['{7B3D5F1A-9C2E-4A8B-B6D0-1E3F5A7C9B2D}'] + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + end; + + RequiresScopeAttribute = class(TCustomAttribute) + private + FScope: string; + public + constructor Create(const AScope: string); + property Scope: string read FScope; + end; + + TMCPBearerChallenge = record + const SCHEME = 'Bearer'; + const ERROR_INVALID_TOKEN = 'invalid_token'; + const ERROR_INVALID_REQUEST = 'invalid_request'; + const ERROR_INSUFFICIENT_SCOPE = 'insufficient_scope'; + class function Build(const ResourceMetadataUrl: string; const Challenge: TMCPAuthChallenge): string; static; + class function Quote(const Value: string): string; static; + end; + + TMCPProtectedResourceMetadata = record + const WELL_KNOWN_PATH = '/.well-known/oauth-protected-resource'; + class function Build(const ResourceUri, ResourceName: string; + const AuthorizationServers, ScopesSupported: TArray): TJSONObject; static; + class function WithoutOfflineAccess(const Scopes: TArray): TArray; static; + end; + + TMCPStaticBearerAuthorizer = class(TInterfacedObject, IMCPAuthorizer) + strict private + FTokens: TArray; + FScopes: TArray; + public + constructor Create(const Tokens: TArray; const Scopes: TArray = nil); + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + class function SameToken(const Presented, Expected: TBytes): Boolean; static; + end; + + TMCPOAuthResourceServerAuthorizer = class abstract(TInterfacedObject, IMCPAuthorizer) + strict private + FExpectedAudience: string; + FRequiredScopes: TArray; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; virtual; abstract; + function AudienceMatches(const Claims: TJSONObject): Boolean; virtual; + function IsExpired(const Claims: TJSONObject): Boolean; virtual; + function ScopesOf(const Claims: TJSONObject): TArray; virtual; + public + constructor Create(const ExpectedAudience: string); + function Authorize(const BearerToken, HttpMethod, Path: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + property ExpectedAudience: string read FExpectedAudience; + property RequiredScopes: TArray read FRequiredScopes write FRequiredScopes; + end; + + TMCPIntrospectionAuthorizer = class(TMCPOAuthResourceServerAuthorizer) + strict private + FIntrospectionUrl: string; + FClientId: string; + FClientSecret: string; + FTimeoutMs: Integer; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; override; + public + const DEFAULT_TIMEOUT_MS = 5000; + constructor Create(const ExpectedAudience, IntrospectionUrl, ClientId, ClientSecret: string); + property IntrospectionUrl: string read FIntrospectionUrl; + property TimeoutMs: Integer read FTimeoutMs write FTimeoutMs; + end; + + EMCPAuthorizationConfiguration = class(Exception) + end; + +implementation + +uses + System.Classes, + System.DateUtils, + System.NetEncoding, + System.Net.HttpClient, + System.Net.URLClient, + System.NetConsts, + MCPServer.Logger; + +const + CLAIM_SUBJECT = 'sub'; + CLAIM_AUDIENCE = 'aud'; + CLAIM_EXPIRY = 'exp'; + CLAIM_SCOPE = 'scope'; + CLAIM_SCOPE_ARRAY = 'scp'; + CLAIM_ACTIVE = 'active'; + SCOPE_ANY = '*'; + SCOPE_OFFLINE_ACCESS = 'offline_access'; + SCOPE_SEPARATOR = ' '; + STATIC_SUBJECT_FORMAT = 'token-%d'; + MEDIA_TYPE_FORM = 'application/x-www-form-urlencoded'; + +{ TMCPPrincipal } + +class function TMCPPrincipal.None: TMCPPrincipal; +begin + Result := Default(TMCPPrincipal); +end; + +function TMCPPrincipal.HasScope(const Scope: string): Boolean; +begin + for var Granted in Scopes do + begin + if (Granted = Scope) or (Granted = SCOPE_ANY) then + Exit(True); + end; + Result := False; +end; + +{ TMCPAuthChallenge } + +class function TMCPAuthChallenge.None: TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); +end; + +class function TMCPAuthChallenge.InvalidToken(const Description: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INVALID_TOKEN; + Result.ErrorDescription := Description; +end; + +class function TMCPAuthChallenge.InvalidRequest(const Description: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INVALID_REQUEST; + Result.ErrorDescription := Description; +end; + +class function TMCPAuthChallenge.InsufficientScope(const Scope: string): TMCPAuthChallenge; +begin + Result := Default(TMCPAuthChallenge); + Result.Error := TMCPBearerChallenge.ERROR_INSUFFICIENT_SCOPE; + Result.Scope := Scope; +end; + +{ RequiresScopeAttribute } + +constructor RequiresScopeAttribute.Create(const AScope: string); +begin + inherited Create; + FScope := AScope; +end; + +{ TMCPBearerChallenge } + +class function TMCPBearerChallenge.Quote(const Value: string): string; +begin + var Clean := Value.Replace(#13, ' ').Replace(#10, ' '); + Result := '"' + Clean.Replace('\', '\\').Replace('"', '\"') + '"'; +end; + +class function TMCPBearerChallenge.Build(const ResourceMetadataUrl: string; const Challenge: TMCPAuthChallenge): string; +begin + var Parameters: TArray := nil; + if ResourceMetadataUrl <> '' then + Parameters := Parameters + ['resource_metadata=' + Quote(ResourceMetadataUrl)]; + if Challenge.Error <> '' then + Parameters := Parameters + ['error=' + Quote(Challenge.Error)]; + if Challenge.ErrorDescription <> '' then + Parameters := Parameters + ['error_description=' + Quote(Challenge.ErrorDescription)]; + if Challenge.Scope <> '' then + Parameters := Parameters + ['scope=' + Quote(Challenge.Scope)]; + + Result := SCHEME; + if Length(Parameters) > 0 then + Result := Result + ' ' + string.Join(', ', Parameters); +end; + +{ TMCPProtectedResourceMetadata } + +class function TMCPProtectedResourceMetadata.WithoutOfflineAccess(const Scopes: TArray): TArray; +begin + Result := nil; + for var Scope in Scopes do + begin + if Scope = SCOPE_OFFLINE_ACCESS then + TLogger.Warning('offline_access is not advertised: refresh tokens are not a resource requirement') + else if Scope <> '' then + Result := Result + [Scope]; + end; +end; + +class function TMCPProtectedResourceMetadata.Build(const ResourceUri, ResourceName: string; + const AuthorizationServers, ScopesSupported: TArray): TJSONObject; +begin + Result := TJSONObject.Create; + Result.AddPair('resource', ResourceUri); + var Servers := TJSONArray.Create; + Result.AddPair('authorization_servers', Servers); + for var Server in AuthorizationServers do + begin + Servers.Add(Server); + end; + var Scopes := WithoutOfflineAccess(ScopesSupported); + if Length(Scopes) > 0 then + begin + var ScopesArray := TJSONArray.Create; + Result.AddPair('scopes_supported', ScopesArray); + for var Scope in Scopes do + begin + ScopesArray.Add(Scope); + end; + end; + var Methods := TJSONArray.Create; + Methods.Add('header'); + Result.AddPair('bearer_methods_supported', Methods); + if ResourceName <> '' then + Result.AddPair('resource_name', ResourceName); +end; + +{ TMCPStaticBearerAuthorizer } + +constructor TMCPStaticBearerAuthorizer.Create(const Tokens: TArray; const Scopes: TArray); +begin + inherited Create; + for var Token in Tokens do + begin + if Token.Trim <> '' then + FTokens := FTokens + [TEncoding.UTF8.GetBytes(Token.Trim)]; + end; + if Length(FTokens) = 0 then + raise EMCPAuthorizationConfiguration.Create('A static bearer authorizer needs at least one token'); + FScopes := Scopes; + if Length(FScopes) = 0 then + FScopes := [SCOPE_ANY]; +end; + +class function TMCPStaticBearerAuthorizer.SameToken(const Presented, Expected: TBytes): Boolean; +begin + Result := TMCPConstantTime.SameBytes(Presented, Expected); +end; + +function TMCPStaticBearerAuthorizer.Authorize(const BearerToken, HttpMethod, Path: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +begin + Principal := TMCPPrincipal.None; + Challenge := TMCPAuthChallenge.None; + var Presented := TEncoding.UTF8.GetBytes(BearerToken); + var Matched: Integer := -1; + for var I := 0 to High(FTokens) do + begin + if SameToken(Presented, FTokens[I]) then + Matched := Integer(I); + end; + + if Matched < 0 then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The bearer token is not recognised'); + Exit(TMCPAuthDecision.Unauthorized); + end; + Principal.Subject := Format(STATIC_SUBJECT_FORMAT, [Matched + 1]); + Principal.Scopes := FScopes; + Result := TMCPAuthDecision.Allow; +end; + +{ TMCPOAuthResourceServerAuthorizer } + +constructor TMCPOAuthResourceServerAuthorizer.Create(const ExpectedAudience: string); +begin + inherited Create; + if ExpectedAudience.Trim = '' then + raise EMCPAuthorizationConfiguration.Create('An OAuth resource server authorizer needs the expected audience'); + FExpectedAudience := ExpectedAudience.Trim; +end; + +function TMCPOAuthResourceServerAuthorizer.AudienceMatches(const Claims: TJSONObject): Boolean; +begin + var Audience := Claims.GetValue(CLAIM_AUDIENCE); + if IsJsonString(Audience) then + Exit(SameText(TJSONString(Audience).Value, FExpectedAudience)); + if Audience is TJSONArray then + begin + for var Item in TJSONArray(Audience) do + begin + if IsJsonString(Item) and SameText(TJSONString(Item).Value, FExpectedAudience) then + Exit(True); + end; + end; + Result := False; +end; + +function TMCPOAuthResourceServerAuthorizer.IsExpired(const Claims: TJSONObject): Boolean; +begin + var Expiry := Claims.GetValue(CLAIM_EXPIRY); + if not (Expiry is TJSONNumber) then + Exit(True); + Result := TJSONNumber(Expiry).AsInt64 <= DateTimeToUnix(Now, False); +end; + +function TMCPOAuthResourceServerAuthorizer.ScopesOf(const Claims: TJSONObject): TArray; +begin + Result := nil; + var Scope := Claims.GetValue(CLAIM_SCOPE); + if IsJsonString(Scope) then + Exit(TJSONString(Scope).Value.Split([SCOPE_SEPARATOR], TStringSplitOptions.ExcludeEmpty)); + + var ScopeArray := Claims.GetValue(CLAIM_SCOPE_ARRAY); + if ScopeArray is TJSONArray then + begin + for var Item in TJSONArray(ScopeArray) do + begin + if IsJsonString(Item) then + Result := Result + [TJSONString(Item).Value]; + end; + end; +end; + +function TMCPOAuthResourceServerAuthorizer.Authorize(const BearerToken, HttpMethod, Path: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +var + Claims: TJSONObject; +begin + Principal := TMCPPrincipal.None; + Challenge := TMCPAuthChallenge.None; + if not ValidateToken(BearerToken, Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token is not valid'); + Exit(TMCPAuthDecision.Unauthorized); + end; + + try + if not AudienceMatches(Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token was not issued for this server'); + Exit(TMCPAuthDecision.Unauthorized); + end; + if IsExpired(Claims) then + begin + Challenge := TMCPAuthChallenge.InvalidToken('The access token has expired'); + Exit(TMCPAuthDecision.Unauthorized); + end; + + Principal.Subject := Claims.GetValue(CLAIM_SUBJECT, ''); + Principal.Scopes := ScopesOf(Claims); + for var Required in FRequiredScopes do + begin + if not Principal.HasScope(Required) then + begin + Challenge := TMCPAuthChallenge.InsufficientScope(string.Join(SCOPE_SEPARATOR, FRequiredScopes)); + Exit(TMCPAuthDecision.Forbidden); + end; + end; + Result := TMCPAuthDecision.Allow; + finally + Claims.Free; + end; +end; + +{ TMCPIntrospectionAuthorizer } + +constructor TMCPIntrospectionAuthorizer.Create(const ExpectedAudience, IntrospectionUrl, ClientId, ClientSecret: string); +begin + inherited Create(ExpectedAudience); + if IntrospectionUrl.Trim = '' then + raise EMCPAuthorizationConfiguration.Create('An introspection authorizer needs the introspection endpoint URL'); + FIntrospectionUrl := IntrospectionUrl.Trim; + FClientId := ClientId; + FClientSecret := ClientSecret; + FTimeoutMs := DEFAULT_TIMEOUT_MS; +end; + +function TMCPIntrospectionAuthorizer.ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; +begin + Claims := nil; + var Client := THTTPClient.Create; + var Form := TStringStream.Create('token=' + TNetEncoding.URL.EncodeForm(Token), TEncoding.UTF8); + try + Client.ConnectionTimeout := FTimeoutMs; + Client.ResponseTimeout := FTimeoutMs; + Client.ContentType := MEDIA_TYPE_FORM; + var Headers: TArray := [TNetHeader.Create('Accept', 'application/json')]; + if FClientId <> '' then + Headers := Headers + [TNetHeader.Create('Authorization', 'Basic ' + TNetEncoding.Base64.Encode(FClientId + ':' + FClientSecret))]; + + var Response := Client.Post(FIntrospectionUrl, Form, nil, Headers); + if Response.StatusCode <> 200 then + begin + TLogger.Warning(Format('Token introspection answered HTTP %d', [Response.StatusCode])); + Exit(False); + end; + + var Parsed := TJSONObject.ParseJSONValue(Response.ContentAsString(TEncoding.UTF8)); + if not (Parsed is TJSONObject) then + begin + Parsed.Free; + Exit(False); + end; + if not (TJSONObject(Parsed).GetValue(CLAIM_ACTIVE) is TJSONTrue) then + begin + Parsed.Free; + Exit(False); + end; + Claims := TJSONObject(Parsed); + Result := True; + finally + Form.Free; + Client.Free; + end; +end; + +end. diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index 4e06d08..f60d871 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -38,7 +38,12 @@ TMCPSettings = class FSecurityAllowedOrigins: string; 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; @@ -83,6 +88,13 @@ TMCPSettings = class property AllowedOrigins: string read GetAllowedOrigins; 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; @@ -151,6 +163,35 @@ procedure TMCPSettings.LoadDefaults; FSecurityAllowedOrigins := ''; 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.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; @@ -200,6 +241,13 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + IniFile.WriteString('Auth', '; Bearer tokens accepted on the HTTP endpoint (comma-separated; empty = open server)', ''); + IniFile.WriteString('Auth', 'BearerTokens', FBearerTokens); + IniFile.WriteString('Auth', '; OAuth authorization servers published in the protected resource metadata', ''); + IniFile.WriteString('Auth', 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString('Auth', 'ResourceUri', FResourceUri); + IniFile.WriteString('Auth', 'ScopesSupported', FScopesSupported); + IniFile.WriteString('Protocol', '; Protocol options (1 = on, 0 = off)', ''); IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); @@ -249,6 +297,11 @@ procedure TMCPSettings.LoadFromFile; FRequestStateKey := IniFile.ReadString('Security', 'RequestStateKey', FRequestStateKey); FRequestStateTtlSeconds := IniFile.ReadInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + FBearerTokens := IniFile.ReadString('Auth', 'BearerTokens', FBearerTokens); + FAuthorizationServers := IniFile.ReadString('Auth', 'AuthorizationServers', FAuthorizationServers); + FResourceUri := IniFile.ReadString('Auth', 'ResourceUri', FResourceUri); + FScopesSupported := IniFile.ReadString('Auth', 'ScopesSupported', FScopesSupported); + FLenientModernPing := IniFile.ReadBool('Protocol', 'LenientModernPing', FLenientModernPing); FDiscoverListsLegacyVersions := IniFile.ReadBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); FDiscoverTtlMs := IniFile.ReadInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); @@ -303,6 +356,11 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); + IniFile.WriteString('Auth', 'BearerTokens', FBearerTokens); + IniFile.WriteString('Auth', 'AuthorizationServers', FAuthorizationServers); + IniFile.WriteString('Auth', 'ResourceUri', FResourceUri); + IniFile.WriteString('Auth', 'ScopesSupported', FScopesSupported); + IniFile.WriteBool('Protocol', 'LenientModernPing', FLenientModernPing); IniFile.WriteBool('Protocol', 'DiscoverListsLegacyVersions', FDiscoverListsLegacyVersions); IniFile.WriteInteger('Protocol', 'DiscoverTtlMs', FDiscoverTtlMs); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index f07a0a6..7b9080c 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -23,6 +23,7 @@ uses MCPServer.ContentBlocks in 'Protocol\MCPServer.ContentBlocks.pas', MCPServer.Logger in 'Core\MCPServer.Logger.pas', MCPServer.Settings in 'Core\MCPServer.Settings.pas', + MCPServer.Authorization in 'Core\MCPServer.Authorization.pas', MCPServer.Registration in 'Core\MCPServer.Registration.pas', MCPServer.ManagerRegistry in 'Core\MCPServer.ManagerRegistry.pas', MCPServer.Tool.Base in 'Tools\MCPServer.Tool.Base.pas', @@ -126,6 +127,8 @@ begin Server.Settings := Settings; Server.ManagerRegistry := ManagerRegistry; Server.CoreManager := CoreManager; + if Length(Settings.BearerTokenList) > 0 then + Server.Authorizer := TMCPStaticBearerAuthorizer.Create(Settings.BearerTokenList); Server.Start; diff --git a/src/MCPServer.dproj b/src/MCPServer.dproj index e3bd71d..4abf768 100644 --- a/src/MCPServer.dproj +++ b/src/MCPServer.dproj @@ -140,6 +140,7 @@ + diff --git a/src/Managers/MCPServer.ToolsManager.pas b/src/Managers/MCPServer.ToolsManager.pas index b39ba73..407d468 100644 --- a/src/Managers/MCPServer.ToolsManager.pas +++ b/src/Managers/MCPServer.ToolsManager.pas @@ -31,6 +31,7 @@ TMCPToolsManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCapabil function CreateToolJSON(const Tool: IMCPTool): TJSONObject; procedure CheckCursor(const Params: TJSONObject); procedure ValidateToolName(const Name: string); + procedure CheckRequiredScopes(const Tool: IMCPTool); function EraOf(const Context: IMCPRequestContext): TMCPProtocolEra; private procedure RegisterTool(const Tool: IMCPTool); @@ -66,6 +67,7 @@ implementation System.RegularExpressions, MCPServer.Registration, MCPServer.RequestContext, + MCPServer.Authorization, MCPServer.Errors, MCPServer.Mrtr, MCPServer.Tool.Result, @@ -156,6 +158,26 @@ function TMCPToolsManager.ExecuteMethodWithContext(const Method: string; const P raise Exception.CreateFmt('Method %s not handled by %s', [Method, GetCapabilityName]); end; +procedure TMCPToolsManager.CheckRequiredScopes(const Tool: IMCPTool); +begin + var Context := TMCPRequestContext.Current; + var RttiContext := TRttiContext.Create; + try + var ToolType := RttiContext.GetType((Tool as TObject).ClassType); + for var Attribute in ToolType.GetAttributes do + begin + if not (Attribute is RequiresScopeAttribute) then + Continue; + var Scope := RequiresScopeAttribute(Attribute).Scope; + var Granted := Assigned(Context) and Context.HasScope(Scope); + if not Granted then + raise EMCPError.InsufficientScope(Scope); + end; + finally + RttiContext.Free; + end; +end; + procedure TMCPToolsManager.ValidateToolName(const Name: string); begin if not TRegEx.IsMatch(Name, TOOL_NAME_PATTERN) then @@ -410,6 +432,7 @@ function TMCPToolsManager.CallTool(const Params: TJSONObject; Era: TMCPProtocolE 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)); diff --git a/src/Protocol/MCPServer.Errors.pas b/src/Protocol/MCPServer.Errors.pas index 4b85bf3..cf56ef5 100644 --- a/src/Protocol/MCPServer.Errors.pas +++ b/src/Protocol/MCPServer.Errors.pas @@ -31,6 +31,8 @@ EMCPError = class(Exception) 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; @@ -46,6 +48,7 @@ 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; @@ -141,6 +144,20 @@ class function EMCPError.UnknownPrompt(const Name: string): EMCPError; Result := EMCPError.Create(JSONRPC_INVALID_PARAMS, 'Unknown prompt: ' + Name, Data); end; +function EMCPError.RequiredScope: string; +begin + Result := ''; + if Data is TJSONObject then + Result := TJSONObject(Data).GetValue('requiredScope', ''); +end; + +class function EMCPError.InsufficientScope(const Scope: string): EMCPError; +begin + var Data := TJSONObject.Create; + Data.AddPair('requiredScope', Scope); + Result := EMCPError.Create(JSONRPC_INVALID_REQUEST, Format('The %s scope is required', [Scope]), Data, HTTP_STATUS_FORBIDDEN); +end; + class function EMCPError.ResourceNotFound(const Uri: string; Era: TMCPProtocolEra): EMCPError; begin var Data := TJSONObject.Create; diff --git a/src/Protocol/MCPServer.JsonRpcProcessor.pas b/src/Protocol/MCPServer.JsonRpcProcessor.pas index 46b6eb1..4e59893 100644 --- a/src/Protocol/MCPServer.JsonRpcProcessor.pas +++ b/src/Protocol/MCPServer.JsonRpcProcessor.pas @@ -22,6 +22,7 @@ TMCPProcessResult = record Era: TMCPProtocolEra; IsNotification: Boolean; Cancelled: Boolean; + RequiredScope: string; end; TMCPJsonRpcProcessor = class @@ -40,6 +41,9 @@ TMCPJsonRpcProcessor = class function ClientInputResponses(const Params: TJSONObject): TJSONObject; function OpenClientRequestState(const Method: string; const Params: TJSONObject; const Hints: TMCPTransportHints): TJSONObject; + function NewContext(Era: TMCPProtocolEra; const Version, Method: string; const RequestId: TMCPRequestId; + const Meta: TJSONObject; const Hints: TMCPTransportHints; const InputResponses: TJSONObject = nil; + const RequestState: TJSONObject = nil): IMCPRequestContext; function InputRequiredResult(const Context: IMCPRequestContext; const Params: TJSONObject; const Hints: TMCPTransportHints; const Required: EMCPInputRequired): TMCPProcessResult; function EraFromHeaders(const Hints: TMCPTransportHints): TMCPProtocolEra; @@ -319,6 +323,14 @@ procedure TMCPJsonRpcProcessor.ValidateMirroredHeaders(const Method: string; con [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; var @@ -366,8 +378,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa InputResponses := ClientInputResponses(Params); RequestState := OpenClientRequestState(Method, Params, Hints); end; - Exit(TMCPRequestContext.Create(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry, Hints.Sink, InputResponses, RequestState)); + Exit(NewContext(TMCPProtocolEra.Modern, Version, Method, RequestId, Meta, Hints, InputResponses, RequestState)); end; if Method = 'initialize' then @@ -379,8 +390,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa if IsJsonString(RequestedValue) then Requested := TJSONString(RequestedValue).Value; end; - Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), - Method, RequestId, Meta, Hints.LegacySession, FManagerRegistry, Hints.Sink)); + Exit(NewContext(TMCPProtocolEra.Legacy, NegotiateLegacyProtocolVersion(Requested), Method, RequestId, Meta, Hints)); end; if IsModernOnlyMethod(Method) then @@ -398,8 +408,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa raise EMCPError.Create(JSONRPC_INVALID_REQUEST, 'Unsupported MCP-Protocol-Version header: ' + Header, nil, HTTP_STATUS_BAD_REQUEST); - Exit(TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry, Hints.Sink)); + Exit(NewContext(TMCPProtocolEra.Legacy, Header, Method, RequestId, Meta, Hints)); end; Version := ''; @@ -408,8 +417,7 @@ function TMCPJsonRpcProcessor.BuildRequestContext(const Method: string; const Pa if Version = '' then Version := MCP_LATEST_LEGACY_PROTOCOL_VERSION; - Result := TMCPRequestContext.Create(TMCPProtocolEra.Legacy, Version, Method, RequestId, Meta, - Hints.LegacySession, FManagerRegistry, Hints.Sink); + Result := NewContext(TMCPProtocolEra.Legacy, Version, Method, RequestId, Meta, Hints); end; function TMCPJsonRpcProcessor.ProcessNotification(const Method: string; const Params: TJSONObject; @@ -607,8 +615,8 @@ function TMCPJsonRpcProcessor.StatusForError(Era: TMCPProtocolEra; const Error: begin if Era = TMCPProtocolEra.Legacy then begin - if Error.HttpStatus = HTTP_STATUS_BAD_REQUEST then - Exit(HTTP_STATUS_BAD_REQUEST); + if (Error.HttpStatus = HTTP_STATUS_BAD_REQUEST) or (Error.HttpStatus = HTTP_STATUS_FORBIDDEN) then + Exit(Error.HttpStatus); Exit(HTTP_STATUS_OK); end; @@ -631,6 +639,9 @@ function TMCPJsonRpcProcessor.ErrorResult(Era: TMCPProtocolEra; const RequestId: const Error: EMCPError): TMCPProcessResult; begin TLogger.Error('Error processing request: ' + Error.Message); + var RequiredScope := ''; + if Error.HttpStatus = HTTP_STATUS_FORBIDDEN then + RequiredScope := Error.RequiredScope; var Response := TJSONObject.Create; try @@ -652,6 +663,8 @@ function TMCPJsonRpcProcessor.ErrorResult(Era: TMCPProtocolEra; const RequestId: Result.HttpStatus := StatusForError(Era, Error); Result.Era := Era; Result.IsNotification := False; + Result.Cancelled := False; + Result.RequiredScope := RequiredScope; end; function TMCPJsonRpcProcessor.ExceptionToError(Era: TMCPProtocolEra; const E: Exception): EMCPError; diff --git a/src/Protocol/MCPServer.RequestContext.pas b/src/Protocol/MCPServer.RequestContext.pas index 11a4b8d..13ed78f 100644 --- a/src/Protocol/MCPServer.RequestContext.pas +++ b/src/Protocol/MCPServer.RequestContext.pas @@ -22,6 +22,7 @@ TMCPTransportHints = record NameHeader: string; RemoteAddress: string; Principal: string; + Scopes: TArray; LegacySession: TMCPLegacySession; Sink: IMCPMessageSink; Tracker: IMCPRequestTracker; @@ -45,6 +46,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) FSink: IMCPMessageSink; FInputResponses: TJSONObject; FRequestState: TJSONObject; + FPrincipal: string; + FScopes: TArray; FCancelled: Integer; FProgressSent: Boolean; FLastProgress: Double; @@ -55,7 +58,8 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) 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 RequestState: TJSONObject = nil; const Principal: string = ''; + const Scopes: TArray = nil); destructor Destroy; override; function GetEra: TMCPProtocolEra; @@ -72,7 +76,10 @@ TMCPRequestContext = class(TInterfacedObject, IMCPRequestContext) 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; @@ -129,7 +136,7 @@ class function TMCPTransportHints.ForHttp(const HasVersionHeader: Boolean; const 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 RequestState: TJSONObject; const Principal: string; const Scopes: TArray); begin inherited Create; FEra := Era; @@ -144,6 +151,8 @@ constructor TMCPRequestContext.Create(Era: TMCPProtocolEra; const ProtocolVersio if Assigned(InputResponses) then FInputResponses := TJSONObject(InputResponses.Clone); FRequestState := RequestState; + FPrincipal := Principal; + FScopes := Scopes; end; destructor TMCPRequestContext.Destroy; @@ -243,6 +252,26 @@ function TMCPRequestContext.GetSink: IMCPMessageSink; 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; diff --git a/src/Protocol/MCPServer.RequestState.pas b/src/Protocol/MCPServer.RequestState.pas index 830fe87..06fc53c 100644 --- a/src/Protocol/MCPServer.RequestState.pas +++ b/src/Protocol/MCPServer.RequestState.pas @@ -18,7 +18,6 @@ TMCPRequestStateSealer = class function Signature(const Payload: TBytes): TBytes; class function Base64Url(const Bytes: TBytes): string; static; class function TryFromBase64Url(const Text: string; out Bytes: TBytes): Boolean; static; - class function SameBytes(const A, B: TBytes): Boolean; static; class function CanonicalJson(const Value: TJSONValue): string; static; public constructor Create(const Key: string; TtlSeconds: Integer = DEFAULT_TTL_SECONDS); @@ -41,6 +40,7 @@ implementation System.NetEncoding, System.Generics.Collections, System.Generics.Defaults, + MCPServer.Types, MCPServer.Errors, MCPServer.Logger; @@ -110,25 +110,6 @@ class function TMCPRequestStateSealer.TryFromBase64Url(const Text: string; out B end; end; -class function TMCPRequestStateSealer.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; - class function TMCPRequestStateSealer.CanonicalJson(const Value: TJSONValue): string; begin if Value is TJSONObject then @@ -233,7 +214,7 @@ function TMCPRequestStateSealer.Open(const Token, Method, ArgumentDigest, Princi 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 SameBytes(SignatureBytes, Signature(PayloadBytes)) then + or not TMCPConstantTime.SameBytes(SignatureBytes, Signature(PayloadBytes)) then raise EMCPError.InvalidParams('requestState failed integrity verification'); var Payload := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(PayloadBytes)) as TJSONObject; diff --git a/src/Protocol/MCPServer.Types.pas b/src/Protocol/MCPServer.Types.pas index 95e06db..038f92c 100644 --- a/src/Protocol/MCPServer.Types.pas +++ b/src/Protocol/MCPServer.Types.pas @@ -62,6 +62,7 @@ interface ); 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'; @@ -81,6 +82,10 @@ TMCPLogLevel = record class function IsKnown(const Level: string): Boolean; static; end; + TMCPConstantTime = record + class function SameBytes(const A, B: TBytes): Boolean; static; + end; + OptionalAttribute = class(TCustomAttribute) end; @@ -283,8 +288,11 @@ TMCPLegacySession = class 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; @@ -309,6 +317,8 @@ TMCPLegacySession = class 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 @@ -459,6 +469,25 @@ class function TMCPLogLevel.IsKnown(const Level: string): Boolean; Result := Rank(Level) >= 0; end; +class function TMCPConstantTime.SameBytes(const A, B: TBytes): Boolean; +begin + var Difference := Length(A) xor Length(B); + var Longest := Length(A); + if Length(B) > Longest then + Longest := Length(B); + for var I := 0 to Longest - 1 do + begin + var Left := 0; + var Right := 0; + if I < Length(A) then + Left := A[I]; + if I < Length(B) then + Right := B[I]; + Difference := Difference or (Left xor Right); + end; + Result := Difference = 0; +end; + function IsJsonString(const Value: TJSONValue): Boolean; begin Result := (Value is TJSONString) and not (Value is TJSONNumber); diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 85de838..5b015b0 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -26,6 +26,7 @@ interface IdServerIOHandler, MCPServer.Types, MCPServer.Settings, + MCPServer.Authorization, MCPServer.RequestContext, MCPServer.JsonRpcProcessor; @@ -44,16 +45,28 @@ TMCPIdHTTPServer = class(TComponent) FPort: Word; FActive: Boolean; FSettings: TMCPSettings; + FAuthorizer: IMCPAuthorizer; procedure ConfigureSSL; procedure ConfigureBindings; procedure AddBinding(const IP: string; IPVersion: TIdIPVersion); procedure HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean); + procedure HandleParseAuthentication(Context: TIdContext; const AuthType, AuthData: string; + var VUsername, VPassword: string; var VHandled: Boolean); procedure HandleHTTPRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); function AllowedOrigins: TArray; function ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo): Boolean; procedure ApplyCorsHeaders(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); procedure HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo); - procedure HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); + function IsProtectedResourceMetadataPath(const Document: string): Boolean; + function ResourceUri: string; + function ResourceMetadataUrl: string; + procedure HandleProtectedResourceMetadata(ResponseInfo: TIdHTTPResponseInfo); + function Authenticate(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + out Principal: TMCPPrincipal): Boolean; + procedure SendChallenge(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; const Challenge: TMCPAuthChallenge; + const Message: string); + procedure HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + const Principal: TMCPPrincipal); function BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; procedure EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); procedure SendEmpty(ResponseInfo: TIdHTTPResponseInfo; Status: Integer); @@ -75,6 +88,7 @@ TMCPIdHTTPServer = class(TComponent) 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 @@ -90,6 +104,7 @@ implementation DEFAULT_MCP_PORT = 3000; HTTP_NO_CONTENT = 204; + HTTP_UNAUTHORIZED = 401; HTTP_FORBIDDEN = 403; HTTP_METHOD_NOT_ALLOWED = 405; HTTP_PAYLOAD_TOO_LARGE = 413; @@ -104,6 +119,10 @@ implementation ALLOW_HEADER = 'POST, OPTIONS'; HEADER_ORIGIN = 'Origin'; + HEADER_AUTHORIZATION = 'Authorization'; + HEADER_WWW_AUTHENTICATE = 'WWW-Authenticate'; + BEARER_PREFIX = 'Bearer '; + METADATA_CACHE_CONTROL = 'max-age=3600'; HEADER_ACCEPT = 'Accept'; HEADER_SESSION_ID = 'Mcp-Session-Id'; HEADER_PROTOCOL_VERSION = 'MCP-Protocol-Version'; @@ -132,6 +151,7 @@ constructor TMCPIdHTTPServer.Create(Owner: TComponent); FHTTPServer.OnCommandGet := HandleHTTPRequest; FHTTPServer.OnCommandOther := HandleHTTPRequest; FHTTPServer.OnQuerySSLPort := HandleQuerySSLPort; + FHTTPServer.OnParseAuthentication := HandleParseAuthentication; FSSLHandler := nil; end; @@ -166,6 +186,9 @@ procedure TMCPIdHTTPServer.Start; 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; @@ -304,6 +327,14 @@ procedure TMCPIdHTTPServer.ConfigureSSL; TLogger.Info('Root Certificate: ' + FSettings.SSLRootCertFile); end; +procedure TMCPIdHTTPServer.HandleParseAuthentication(Context: TIdContext; const AuthType, AuthData: string; + var VUsername, VPassword: string; var VHandled: Boolean); +begin + VUsername := ''; + VPassword := ''; + VHandled := True; +end; + procedure TMCPIdHTTPServer.HandleQuerySSLPort(APort: Word; var VUseSSL: Boolean); begin VUseSSL := Assigned(FSettings) and FSettings.SSLEnabled and (APort = FPort); @@ -345,6 +376,13 @@ procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; Exit; end; + if Assigned(FAuthorizer) and (RequestInfo.CommandType = hcGET) + and IsProtectedResourceMetadataPath(RequestInfo.Document) then + begin + HandleProtectedResourceMetadata(ResponseInfo); + Exit; + end; + if RequestInfo.Document <> Endpoint then begin SendEmpty(ResponseInfo, HTTP_STATUS_NOT_FOUND); @@ -352,9 +390,17 @@ procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; end; if RequestInfo.Command = 'OPTIONS' then - SendEmpty(ResponseInfo, HTTP_NO_CONTENT) - else if RequestInfo.CommandType = hcPOST then - HandlePostRequest(Context, RequestInfo, ResponseInfo) + begin + SendEmpty(ResponseInfo, HTTP_NO_CONTENT); + Exit; + end; + + var Principal := TMCPPrincipal.None; + if Assigned(FAuthorizer) and not Authenticate(RequestInfo, ResponseInfo, Principal) then + Exit; + + if RequestInfo.CommandType = hcPOST then + HandlePostRequest(Context, RequestInfo, ResponseInfo, Principal) else SendMethodNotAllowed(ResponseInfo); finally @@ -441,6 +487,90 @@ procedure TMCPIdHTTPServer.HandleEndpointInfo(ResponseInfo: TIdHTTPResponseInfo) end; end; +function TMCPIdHTTPServer.IsProtectedResourceMetadataPath(const Document: string): Boolean; +begin + var Endpoint := '/mcp'; + if Assigned(FSettings) then + Endpoint := FSettings.Endpoint; + Result := (Document = TMCPProtectedResourceMetadata.WELL_KNOWN_PATH) + or (Document = TMCPProtectedResourceMetadata.WELL_KNOWN_PATH + Endpoint); +end; + +function TMCPIdHTTPServer.ResourceUri: string; +begin + Result := ''; + if Assigned(FSettings) then + Result := FSettings.ResourceUri.Trim; + if Result <> '' then + Exit; + + Result := Format('%s://%s:%d%s', [FSettings.Protocol.ToLower, FSettings.Host.ToLower, FPort, FSettings.Endpoint]); +end; + +function TMCPIdHTTPServer.ResourceMetadataUrl: string; +begin + Result := ''; + if not Assigned(FSettings) or (Length(FSettings.AuthorizationServerList) = 0) then + Exit; + Result := Format('%s://%s:%d%s%s', [FSettings.Protocol.ToLower, FSettings.Host.ToLower, FPort, + TMCPProtectedResourceMetadata.WELL_KNOWN_PATH, FSettings.Endpoint]); +end; + +procedure TMCPIdHTTPServer.HandleProtectedResourceMetadata(ResponseInfo: TIdHTTPResponseInfo); +begin + var Metadata := TMCPProtectedResourceMetadata.Build(ResourceUri, FSettings.ServerName, + FSettings.AuthorizationServerList, FSettings.ScopesSupportedList); + try + ResponseInfo.CustomHeaders.Values['Cache-Control'] := METADATA_CACHE_CONTROL; + SendJson(ResponseInfo, HTTP_STATUS_OK, Metadata.ToJSON); + finally + Metadata.Free; + end; +end; + +procedure TMCPIdHTTPServer.SendChallenge(ResponseInfo: TIdHTTPResponseInfo; Status: Integer; + const Challenge: TMCPAuthChallenge; const Message: string); +begin + ResponseInfo.CustomHeaders.Values[HEADER_WWW_AUTHENTICATE] := TMCPBearerChallenge.Build(ResourceMetadataUrl, Challenge); + SendJsonRpcError(ResponseInfo, Status, JSONRPC_INVALID_REQUEST, Message); +end; + +function TMCPIdHTTPServer.Authenticate(RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo; + out Principal: TMCPPrincipal): Boolean; +var + Challenge: TMCPAuthChallenge; +begin + Principal := TMCPPrincipal.None; + Result := False; + + var Header := HeaderValue(RequestInfo, HEADER_AUTHORIZATION); + if Header = '' then + begin + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, TMCPAuthChallenge.None, 'Authorization required'); + Exit; + end; + if not Header.StartsWith(BEARER_PREFIX, True) or (Header.Length <= BEARER_PREFIX.Length) then + begin + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, + TMCPAuthChallenge.InvalidRequest('Only the Bearer scheme is supported'), 'Malformed Authorization header'); + Exit; + end; + + var Token := Header.Substring(BEARER_PREFIX.Length).Trim; + case FAuthorizer.Authorize(Token, RequestInfo.Command, RequestInfo.Document, Principal, Challenge) of + TMCPAuthDecision.Allow: + Result := True; + TMCPAuthDecision.Unauthorized: + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Challenge, 'Unauthorized'); + TMCPAuthDecision.Forbidden: + SendChallenge(ResponseInfo, HTTP_FORBIDDEN, Challenge, 'Forbidden'); + TMCPAuthDecision.BadRequest: + SendChallenge(ResponseInfo, HTTP_STATUS_BAD_REQUEST, Challenge, 'Malformed authorization request'); + else + SendChallenge(ResponseInfo, HTTP_UNAUTHORIZED, Challenge, 'Unauthorized'); + end; +end; + function TMCPIdHTTPServer.BuildTransportHints(RequestInfo: TIdHTTPRequestInfo): TMCPTransportHints; begin Result := TMCPTransportHints.ForHttp( @@ -460,7 +590,7 @@ procedure TMCPIdHTTPServer.EchoLegacySessionId(RequestInfo: TIdHTTPRequestInfo; end; procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; - ResponseInfo: TIdHTTPResponseInfo); + ResponseInfo: TIdHTTPResponseInfo; const Principal: TMCPPrincipal); begin var MaxBodyBytes: Integer := TMCPSettings.DEFAULT_MAX_REQUEST_BODY_BYTES; var MaxDepth: Integer := TMCPSettings.DEFAULT_MAX_JSON_DEPTH; @@ -495,6 +625,8 @@ procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: T var AcceptsEventStream := TMCPAcceptHeader.Accepts(HeaderValue(RequestInfo, HEADER_ACCEPT), MEDIA_TYPE_EVENT_STREAM); var Hints := BuildTransportHints(RequestInfo); + Hints.Principal := Principal.Subject; + Hints.Scopes := Principal.Scopes; var Stream: TMCPHttpResponseStream := nil; var StreamRef: IMCPMessageSink := nil; if AcceptsEventStream then @@ -522,6 +654,9 @@ procedure TMCPIdHTTPServer.HandlePostRequest(Context: TIdContext; RequestInfo: T if Outcome.Era = TMCPProtocolEra.Legacy then EchoLegacySessionId(RequestInfo, ResponseInfo); + if Outcome.RequiredScope <> '' then + ResponseInfo.CustomHeaders.Values[HEADER_WWW_AUTHENTICATE] := + TMCPBearerChallenge.Build(ResourceMetadataUrl, TMCPAuthChallenge.InsufficientScope(Outcome.RequiredScope)); if Outcome.Body = '' then begin From 6039c5ccaa1e315d5ac826d54722f46ddf915067 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:41:43 +0200 Subject: [PATCH 52/56] test: authorizers, challenges, metadata and the HTTP authentication flow --- tests/MCPServer.Tests.Authorization.pas | 273 ++++++++++++++++++++++++ tests/MCPServer.Tests.Http.pas | 132 +++++++++++- tests/MCPServerTests.dpr | 2 + tests/MCPServerTests.dproj | 2 + 4 files changed, 406 insertions(+), 3 deletions(-) create mode 100644 tests/MCPServer.Tests.Authorization.pas diff --git a/tests/MCPServer.Tests.Authorization.pas b/tests/MCPServer.Tests.Authorization.pas new file mode 100644 index 0000000..883fb3c --- /dev/null +++ b/tests/MCPServer.Tests.Authorization.pas @@ -0,0 +1,273 @@ +unit MCPServer.Tests.Authorization; + +interface + +uses + DUnitX.TestFramework, + System.SysUtils, + System.Classes, + System.JSON, + IdHTTPServer, + IdContext, + IdCustomHTTPServer, + MCPServer.Types, + MCPServer.Authorization; + +type + TClaimsAuthorizer = class(TMCPOAuthResourceServerAuthorizer) + strict private + FClaimsJson: string; + protected + function ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; override; + public + constructor Create(const ExpectedAudience, ClaimsJson: string); + end; + + [TestFixture] + TAuthorizationTests = class + private + FIntrospection: TIdHTTPServer; + FSeenAuthorization: string; + FSeenBody: string; + procedure HandleIntrospection(Context: TIdContext; Request: TIdHTTPRequestInfo; Response: TIdHTTPResponseInfo); + function Decide(const Authorizer: IMCPAuthorizer; const Token: string; out Principal: TMCPPrincipal; + out Challenge: TMCPAuthChallenge): TMCPAuthDecision; + public + [TearDown] + procedure TearDown; + + [Test] procedure StaticBearer_AcceptsListedTokens_RejectsOthers; + [Test] procedure StaticBearer_NeedsAToken; + [Test] procedure ConstantTime_ComparesWholeToken; + [Test] procedure Principal_HasScope_HonoursWildcard; + [Test] procedure OAuth_RejectsWrongAudience_Expiry_AndScope; + [Test] procedure OAuth_AcceptsAudienceArray_AndScopeArray; + [Test] procedure OAuth_NeedsAnAudience; + [Test] procedure Challenge_Build_QuotesParameters; + [Test] procedure Metadata_Build_DropsOfflineAccess; + [Test] procedure Introspection_PostsTokenWithClientCredentials; + end; + +implementation + +uses + System.DateUtils; + +const + AUDIENCE = 'https://mcp.example/mcp'; + +{ TClaimsAuthorizer } + +constructor TClaimsAuthorizer.Create(const ExpectedAudience, ClaimsJson: string); +begin + inherited Create(ExpectedAudience); + FClaimsJson := ClaimsJson; +end; + +function TClaimsAuthorizer.ValidateToken(const Token: string; out Claims: TJSONObject): Boolean; +begin + Claims := nil; + if Token <> 'valid' then + Exit(False); + Claims := TJSONObject.ParseJSONValue(FClaimsJson) as TJSONObject; + Result := True; +end; + +{ TAuthorizationTests } + +procedure TAuthorizationTests.TearDown; +begin + FIntrospection.Free; + FIntrospection := nil; +end; + +function TAuthorizationTests.Decide(const Authorizer: IMCPAuthorizer; const Token: string; + out Principal: TMCPPrincipal; out Challenge: TMCPAuthChallenge): TMCPAuthDecision; +begin + Result := Authorizer.Authorize(Token, 'POST', '/mcp', Principal, Challenge); +end; + +procedure TAuthorizationTests.StaticBearer_AcceptsListedTokens_RejectsOthers; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Authorizer: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha', ' beta ']); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'alpha', Principal, Challenge)); + Assert.AreEqual('token-1', Principal.Subject); + Assert.IsTrue(Principal.HasScope('anything'), 'pre-shared tokens grant every scope'); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'beta', Principal, Challenge)); + Assert.AreEqual('token-2', Principal.Subject); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, 'alph', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); + Assert.AreEqual('', Principal.Subject); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, '', Principal, Challenge)); + + var Scoped: IMCPAuthorizer := TMCPStaticBearerAuthorizer.Create(['alpha'], ['read']); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Scoped, 'alpha', Principal, Challenge)); + Assert.IsTrue(Principal.HasScope('read')); + Assert.IsFalse(Principal.HasScope('write')); +end; + +procedure TAuthorizationTests.StaticBearer_NeedsAToken; +begin + Assert.WillRaise( + procedure + begin + TMCPStaticBearerAuthorizer.Create(['', ' ']).Free; + end, EMCPAuthorizationConfiguration); +end; + +procedure TAuthorizationTests.ConstantTime_ComparesWholeToken; +begin + Assert.IsTrue(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secret'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secret2'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(TEncoding.UTF8.GetBytes('secret'), TEncoding.UTF8.GetBytes('secreT'))); + Assert.IsFalse(TMCPConstantTime.SameBytes(nil, TEncoding.UTF8.GetBytes('x'))); + Assert.IsTrue(TMCPConstantTime.SameBytes(nil, nil)); +end; + +procedure TAuthorizationTests.Principal_HasScope_HonoursWildcard; +begin + var Principal := TMCPPrincipal.None; + Assert.IsFalse(Principal.HasScope('read')); + Principal.Scopes := ['read', 'files:write']; + Assert.IsTrue(Principal.HasScope('files:write')); + Assert.IsFalse(Principal.HasScope('admin')); + Principal.Scopes := ['*']; + Assert.IsTrue(Principal.HasScope('admin')); +end; + +procedure TAuthorizationTests.OAuth_RejectsWrongAudience_Expiry_AndScope; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Future := System.DateUtils.DateTimeToUnix(Now, False) + 600; + var Past := System.DateUtils.DateTimeToUnix(Now, False) - 600; + + var Invalid: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d}', [AUDIENCE, Future])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Invalid, 'nope', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); + + var WrongAudience: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"https://other","exp":%d}', [Future])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(WrongAudience, 'valid', Principal, Challenge)); + Assert.IsTrue(Challenge.ErrorDescription.Contains('not issued for this server'), Challenge.ErrorDescription); + + var Expired: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d}', [AUDIENCE, Past])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Expired, 'valid', Principal, Challenge)); + Assert.IsTrue(Challenge.ErrorDescription.Contains('expired'), Challenge.ErrorDescription); + + var NoExpiry: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s"}', [AUDIENCE])); + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(NoExpiry, 'valid', Principal, Challenge), 'exp is mandatory'); + + var Scoped := TClaimsAuthorizer.Create(AUDIENCE, Format('{"sub":"u","aud":"%s","exp":%d,"scope":"read"}', [AUDIENCE, Future])); + var ScopedRef: IMCPAuthorizer := Scoped; + Scoped.RequiredScopes := ['read', 'write']; + Assert.AreEqual(TMCPAuthDecision.Forbidden, Decide(ScopedRef, 'valid', Principal, Challenge)); + Assert.AreEqual('insufficient_scope', Challenge.Error); + Assert.AreEqual('read write', Challenge.Scope); + + Scoped.RequiredScopes := ['read']; + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(ScopedRef, 'valid', Principal, Challenge)); + Assert.AreEqual('u', Principal.Subject); + Assert.IsTrue(Principal.HasScope('read')); + Assert.IsFalse(Principal.HasScope('write')); +end; + +procedure TAuthorizationTests.OAuth_AcceptsAudienceArray_AndScopeArray; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + var Future := System.DateUtils.DateTimeToUnix(Now, False) + 600; + var Authorizer: IMCPAuthorizer := TClaimsAuthorizer.Create(AUDIENCE, + Format('{"sub":"u","aud":["https://other","%s"],"exp":%d,"scp":["a","b"]}', [AUDIENCE.ToUpper, Future])); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'valid', Principal, Challenge)); + Assert.IsTrue(Principal.HasScope('a')); + Assert.IsTrue(Principal.HasScope('b')); + Assert.IsFalse(Principal.HasScope('c')); +end; + +procedure TAuthorizationTests.OAuth_NeedsAnAudience; +begin + Assert.WillRaise( + procedure + begin + TClaimsAuthorizer.Create(' ', '{}').Free; + end, EMCPAuthorizationConfiguration); +end; + +procedure TAuthorizationTests.Challenge_Build_QuotesParameters; +begin + Assert.AreEqual('Bearer', TMCPBearerChallenge.Build('', TMCPAuthChallenge.None)); + Assert.AreEqual('Bearer resource_metadata="https://s/.well-known/oauth-protected-resource/mcp"', + TMCPBearerChallenge.Build('https://s/.well-known/oauth-protected-resource/mcp', TMCPAuthChallenge.None)); + Assert.AreEqual('Bearer error="invalid_token", error_description="say \"hi\""', + TMCPBearerChallenge.Build('', TMCPAuthChallenge.InvalidToken('say "hi"'))); + Assert.AreEqual('Bearer resource_metadata="https://s/m", error="insufficient_scope", scope="read write"', + TMCPBearerChallenge.Build('https://s/m', TMCPAuthChallenge.InsufficientScope('read write'))); + Assert.IsFalse(TMCPBearerChallenge.Build('', TMCPAuthChallenge.InvalidRequest('a'#13#10'b')).Contains(#10)); +end; + +procedure TAuthorizationTests.Metadata_Build_DropsOfflineAccess; +begin + var Metadata := TMCPProtectedResourceMetadata.Build('https://mcp.example/mcp', 'demo', + ['https://auth.example'], ['read', 'offline_access', 'write']); + try + Assert.AreEqual('https://mcp.example/mcp', Metadata.GetValue('resource')); + Assert.AreEqual('https://auth.example', Metadata.GetValue('authorization_servers[0]')); + Assert.AreEqual(2, (Metadata.GetValue('scopes_supported') as TJSONArray).Count); + Assert.AreEqual('header', Metadata.GetValue('bearer_methods_supported[0]')); + Assert.AreEqual('demo', Metadata.GetValue('resource_name')); + finally + Metadata.Free; + end; + + var Bare := TMCPProtectedResourceMetadata.Build('https://mcp.example/mcp', '', nil, nil); + try + Assert.AreEqual(0, (Bare.GetValue('authorization_servers') as TJSONArray).Count); + Assert.IsNull(Bare.GetValue('scopes_supported')); + Assert.IsNull(Bare.GetValue('resource_name')); + finally + Bare.Free; + end; +end; + +procedure TAuthorizationTests.HandleIntrospection(Context: TIdContext; Request: TIdHTTPRequestInfo; + Response: TIdHTTPResponseInfo); +begin + FSeenAuthorization := Request.RawHeaders.Values['Authorization']; + FSeenBody := Request.FormParams; + Response.ContentType := 'application/json'; + if FSeenBody.Contains('token=good') then + Response.ContentText := Format('{"active":true,"sub":"alice","aud":"%s","exp":%d,"scope":"read"}', + [AUDIENCE, System.DateUtils.DateTimeToUnix(Now, False) + 600]) + else + Response.ContentText := '{"active":false}'; +end; + +procedure TAuthorizationTests.Introspection_PostsTokenWithClientCredentials; +var + Principal: TMCPPrincipal; + Challenge: TMCPAuthChallenge; +begin + FIntrospection := TIdHTTPServer.Create(nil); + FIntrospection.Bindings.Add.IP := '127.0.0.1'; + FIntrospection.Bindings[0].Port := 0; + FIntrospection.OnCommandGet := HandleIntrospection; + FIntrospection.Active := True; + var Url := Format('http://127.0.0.1:%d/introspect', [FIntrospection.Bindings[0].Port]); + + var Authorizer: IMCPAuthorizer := TMCPIntrospectionAuthorizer.Create(AUDIENCE, Url, 'mcp', 's3cret'); + Assert.AreEqual(TMCPAuthDecision.Allow, Decide(Authorizer, 'good', Principal, Challenge)); + Assert.AreEqual('alice', Principal.Subject); + Assert.IsTrue(Principal.HasScope('read')); + Assert.AreEqual('token=good', FSeenBody); + Assert.IsTrue(FSeenAuthorization.StartsWith('Basic '), FSeenAuthorization); + + Assert.AreEqual(TMCPAuthDecision.Unauthorized, Decide(Authorizer, 'stale', Principal, Challenge)); + Assert.AreEqual('invalid_token', Challenge.Error); +end; + +end. diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index 9b4c2e9..2a1e9f1 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -8,8 +8,12 @@ interface System.Classes, System.JSON, IdHTTP, + MCPServer.Types, MCPServer.Settings, + MCPServer.Authorization, MCPServer.IdHTTPServer, + MCPServer.Tool.Base, + MCPServer.Tool.ContentSamples, MCPServer.Tests.Harness; type @@ -22,6 +26,12 @@ THttpReply = record function Json: TJSONObject; end; + [RequiresScope('admin')] + TScopedTool = class(TSimpleTextTool) + public + constructor Create; override; + end; + [TestFixture] THttpTransportTests = class private @@ -73,13 +83,19 @@ THttpTransportTests = class [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; end; implementation uses - System.Threading, - MCPServer.Types; + System.Threading; const MODERN_VERSION_HEADER = 'MCP-Protocol-Version: 2026-07-28'; @@ -106,6 +122,14 @@ function THttpReply.Json: TJSONObject; Assert.IsNotNull(Result, 'body is not a JSON object: ' + Body); end; +{ TScopedTool } + +constructor TScopedTool.Create; +begin + inherited; + FName := 'test_scoped'; +end; + { THttpTransportTests } procedure THttpTransportTests.Setup; @@ -145,7 +169,8 @@ function THttpTransportTests.Send(const Method, Path, Body: string; const Header var Request := TStringStream.Create(Body, TEncoding.UTF8); var Response := TMemoryStream.Create; try - Http.HTTPOptions := Http.HTTPOptions + [hoNoProtocolErrorException, hoWantProtocolErrorContent]; + 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 @@ -601,4 +626,105 @@ procedure THttpTransportTests.Listen_WithoutEventStreamAccept_IsInvalidRequest; 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; + end. diff --git a/tests/MCPServerTests.dpr b/tests/MCPServerTests.dpr index fc14db8..e4f294a 100644 --- a/tests/MCPServerTests.dpr +++ b/tests/MCPServerTests.dpr @@ -21,6 +21,7 @@ uses MCPServer.ContentBlocks in '..\src\Protocol\MCPServer.ContentBlocks.pas', MCPServer.Logger in '..\src\Core\MCPServer.Logger.pas', MCPServer.Settings in '..\src\Core\MCPServer.Settings.pas', + MCPServer.Authorization in '..\src\Core\MCPServer.Authorization.pas', MCPServer.Registration in '..\src\Core\MCPServer.Registration.pas', MCPServer.ManagerRegistry in '..\src\Core\MCPServer.ManagerRegistry.pas', MCPServer.Tool.Base in '..\src\Tools\MCPServer.Tool.Base.pas', @@ -77,6 +78,7 @@ uses 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'; diff --git a/tests/MCPServerTests.dproj b/tests/MCPServerTests.dproj index 4599dd0..5a765e1 100644 --- a/tests/MCPServerTests.dproj +++ b/tests/MCPServerTests.dproj @@ -85,6 +85,7 @@ + @@ -106,6 +107,7 @@ + From 9a1f9c64362c3186eddc3e9750aba1efdf347306 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:41:43 +0200 Subject: [PATCH 53/56] docs: describe authentication, scopes and the protected resource metadata --- CHANGELOG.md | 12 ++++++++++++ MIGRATION.md | 19 +++++++++++++++++++ README.md | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 79 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ca405ee..5415cfb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -184,6 +184,18 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). 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`. +- 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, diff --git a/MIGRATION.md b/MIGRATION.md index 32c92b1..ca4e5ce 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -162,6 +162,25 @@ at startup. `RequestStateTtlSeconds` bounds the replay window (600 s). nine new example tools plus one example prompt ship with the executable; they are only registered when their units are in the project. +## 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.** diff --git a/README.md b/README.md index a5f3309..a4b55de 100644 --- a/README.md +++ b/README.md @@ -802,6 +802,54 @@ The server provides six resources and two resource templates, accessible via URI 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. From 359b4cd549ecb0f7ebd8c4b71806093c03df81e3 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:44:49 +0200 Subject: [PATCH 54/56] feat: host allow-list and a switch for the diagnostics resources [Security] AllowedHosts rejects requests whose Host header is not listed with 403, so a rebinding DNS name cannot reach a server that is published under a public name. [Server] ExposeDiagnosticsResources=0 keeps logs://recent, logs://{level} and server://status off the executable; TMCPResourcesManager gains RemoveResourceTemplate. --- settings.ini.example | 8 +++++ src/Core/MCPServer.Settings.pas | 20 +++++++++++++ src/MCPServer.dpr | 12 ++++++++ src/Managers/MCPServer.ResourcesManager.pas | 21 +++++++++++++ src/Server/MCPServer.HttpHeaders.pas | 33 +++++++++++++++++++++ src/Server/MCPServer.IdHTTPServer.pas | 13 +++++++- 6 files changed, 106 insertions(+), 1 deletion(-) diff --git a/settings.ini.example b/settings.ini.example index 49b052d..4e78632 100644 --- a/settings.ini.example +++ b/settings.ini.example @@ -27,6 +27,9 @@ MaxRequestBodyBytes=4194304 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 @@ -35,6 +38,11 @@ MaxConcurrentRequests=1 ; 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. diff --git a/src/Core/MCPServer.Settings.pas b/src/Core/MCPServer.Settings.pas index f60d871..09afae8 100644 --- a/src/Core/MCPServer.Settings.pas +++ b/src/Core/MCPServer.Settings.pas @@ -36,6 +36,8 @@ TMCPSettings = class FMaxConnections: Integer; FMaxConcurrentRequests: Integer; FSecurityAllowedOrigins: string; + FAllowedHosts: string; + FExposeDiagnosticsResources: Boolean; FRequestStateKey: string; FRequestStateTtlSeconds: Integer; FBearerTokens: string; @@ -86,6 +88,9 @@ TMCPSettings = class 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; @@ -161,6 +166,8 @@ procedure TMCPSettings.LoadDefaults; FMaxConcurrentRequests := DEFAULT_MAX_CONCURRENT_REQUESTS; FMaxConnections := 0; FSecurityAllowedOrigins := ''; + FAllowedHosts := ''; + FExposeDiagnosticsResources := True; FRequestStateKey := ''; FRequestStateTtlSeconds := DEFAULT_REQUEST_STATE_TTL_SECONDS; FBearerTokens := ''; @@ -179,6 +186,11 @@ function TMCPSettings.SplitList(const Value: string): TArray; end; end; +function TMCPSettings.AllowedHostList: TArray; +begin + Result := SplitList(FAllowedHosts); +end; + function TMCPSettings.BearerTokenList: TArray; begin Result := SplitList(FBearerTokens); @@ -234,9 +246,13 @@ procedure TMCPSettings.CreateDefaultSettingsFile; IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + IniFile.WriteString('Server', '; Serve logs://recent, logs://{level} and server://status (0 = keep diagnostics private)', ''); + IniFile.WriteBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); IniFile.WriteString('Security', '; Origins allowed next to the loopback origins (empty = [CORS] AllowedOrigins)', ''); IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', '; Host header values accepted, comma-separated host[:port] (empty = any)', ''); + IniFile.WriteString('Security', 'AllowedHosts', FAllowedHosts); IniFile.WriteString('Security', '; Secret that signs requestState tokens (empty = random per process)', ''); IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); @@ -294,6 +310,8 @@ procedure TMCPSettings.LoadFromFile; FMaxConnections := IniFile.ReadInteger('Server', 'MaxConnections', FMaxConnections); FSecurityAllowedOrigins := IniFile.ReadString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + FAllowedHosts := IniFile.ReadString('Security', 'AllowedHosts', FAllowedHosts); + FExposeDiagnosticsResources := IniFile.ReadBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); FRequestStateKey := IniFile.ReadString('Security', 'RequestStateKey', FRequestStateKey); FRequestStateTtlSeconds := IniFile.ReadInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); @@ -351,8 +369,10 @@ procedure TMCPSettings.SaveToFile; IniFile.WriteInteger('Server', 'MaxJsonDepth', FMaxJsonDepth); IniFile.WriteInteger('Server', 'MaxConcurrentRequests', FMaxConcurrentRequests); IniFile.WriteInteger('Server', 'MaxConnections', FMaxConnections); + IniFile.WriteBool('Server', 'ExposeDiagnosticsResources', FExposeDiagnosticsResources); IniFile.WriteString('Security', 'AllowedOrigins', FSecurityAllowedOrigins); + IniFile.WriteString('Security', 'AllowedHosts', FAllowedHosts); IniFile.WriteString('Security', 'RequestStateKey', FRequestStateKey); IniFile.WriteInteger('Security', 'RequestStateTtlSeconds', FRequestStateTtlSeconds); diff --git a/src/MCPServer.dpr b/src/MCPServer.dpr index 7b9080c..916cba4 100644 --- a/src/MCPServer.dpr +++ b/src/MCPServer.dpr @@ -108,6 +108,12 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + if not Settings.ExposeDiagnosticsResources then + begin + ResourcesManager.RemoveResource('logs://recent'); + ResourcesManager.RemoveResource('server://status'); + ResourcesManager.RemoveResourceTemplate('logs://{level}'); + end; PromptsManager := TMCPPromptsManager.Create; CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); SubscriptionsManager := TMCPSubscriptionsManager.Create; @@ -162,6 +168,12 @@ begin CoreManager := TMCPCoreManager.Create(Settings); ToolsManager := TMCPToolsManager.Create; ResourcesManager := TMCPResourcesManager.Create; + if not Settings.ExposeDiagnosticsResources then + begin + ResourcesManager.RemoveResource('logs://recent'); + ResourcesManager.RemoveResource('server://status'); + ResourcesManager.RemoveResourceTemplate('logs://{level}'); + end; PromptsManager := TMCPPromptsManager.Create; CompletionManager := TMCPCompletionManager.Create(PromptsManager, ResourcesManager); SubscriptionsManager := TMCPSubscriptionsManager.Create; diff --git a/src/Managers/MCPServer.ResourcesManager.pas b/src/Managers/MCPServer.ResourcesManager.pas index f1c48c3..3f8c5d4 100644 --- a/src/Managers/MCPServer.ResourcesManager.pas +++ b/src/Managers/MCPServer.ResourcesManager.pas @@ -42,6 +42,7 @@ TMCPResourcesManager = class(TInterfacedObject, IMCPCapabilityManager, IMCPCap 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; @@ -200,6 +201,26 @@ procedure TMCPResourcesManager.AddResource(const Resource: IMCPResource); 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; diff --git a/src/Server/MCPServer.HttpHeaders.pas b/src/Server/MCPServer.HttpHeaders.pas index 35c2fdb..ccc2921 100644 --- a/src/Server/MCPServer.HttpHeaders.pas +++ b/src/Server/MCPServer.HttpHeaders.pas @@ -28,6 +28,11 @@ TMCPOriginPolicy = record 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; @@ -211,6 +216,34 @@ class function TMCPOriginPolicy.IsAllowed(const Origin: string; const AllowList: Result := False; end; +{ TMCPHostPolicy } + +class function TMCPHostPolicy.Matches(const HostHeader, Pattern: string): Boolean; +var + Scheme, HostName, HostPort, PatternName, PatternPort: string; +begin + if Pattern.Trim = TMCPOriginPolicy.ALLOW_ALL then + Exit(True); + + SplitOrigin('http://' + HostHeader.Trim, Scheme, HostName, HostPort); + SplitOrigin('http://' + Pattern.Trim, Scheme, PatternName, PatternPort); + if (HostName = '') or (PatternName = '') or (HostName <> PatternName) then + Exit(False); + Result := (PatternPort = '') or (PatternPort = '*') or (PatternPort = HostPort); +end; + +class function TMCPHostPolicy.IsAllowed(const HostHeader: string; const AllowList: TArray): Boolean; +begin + if Length(AllowList) = 0 then + Exit(True); + for var Pattern in AllowList do + begin + if Matches(HostHeader, Pattern) then + Exit(True); + end; + Result := False; +end; + { TMCPJsonLimits } class function TMCPJsonLimits.NestingDepth(const Json: string): Integer; diff --git a/src/Server/MCPServer.IdHTTPServer.pas b/src/Server/MCPServer.IdHTTPServer.pas index 5b015b0..e419405 100644 --- a/src/Server/MCPServer.IdHTTPServer.pas +++ b/src/Server/MCPServer.IdHTTPServer.pas @@ -55,6 +55,7 @@ TMCPIdHTTPServer = class(TComponent) procedure HandleHTTPRequest(Context: TIdContext; RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); 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; @@ -357,7 +358,7 @@ procedure TMCPIdHTTPServer.HandleHTTPRequest(Context: TIdContext; try TServerStatusResource.IncrementRequestCount; - if not ValidateOrigin(RequestInfo, ResponseInfo) then + if not ValidateHost(RequestInfo, ResponseInfo) or not ValidateOrigin(RequestInfo, ResponseInfo) then Exit; ApplyCorsHeaders(RequestInfo, ResponseInfo); @@ -439,6 +440,16 @@ function TMCPIdHTTPServer.ValidateOrigin(RequestInfo: TIdHTTPRequestInfo; Respon Result := False; 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 From 1a4eb97d2b9d81a5da78cc1a7ee4eb6f678b95ef Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:44:49 +0200 Subject: [PATCH 55/56] test: host policy, host rejection over HTTP and template removal --- tests/MCPServer.Tests.Http.pas | 12 ++++++++++++ tests/MCPServer.Tests.HttpHeaders.pas | 15 +++++++++++++++ tests/MCPServer.Tests.ResourcesManager.pas | 13 +++++++++++++ 3 files changed, 40 insertions(+) diff --git a/tests/MCPServer.Tests.Http.pas b/tests/MCPServer.Tests.Http.pas index 2a1e9f1..b3a2f87 100644 --- a/tests/MCPServer.Tests.Http.pas +++ b/tests/MCPServer.Tests.Http.pas @@ -90,6 +90,7 @@ THttpTransportTests = class [Test] procedure Auth_PreflightAndMetadata_NeedNoToken; [Test] procedure Auth_ScopedTool_Is403_WithInsufficientScope; [Test] procedure Auth_ScopedTool_OnOpenServer_Is403; + [Test] procedure Host_NotAllowed_Is403; end; implementation @@ -727,4 +728,15 @@ procedure THttpTransportTests.Auth_ScopedTool_OnOpenServer_Is403; Assert.AreEqual(403, Reply.Status, 'nobody holds a scope on an open server'); end; +procedure THttpTransportTests.Host_NotAllowed_Is403; +begin + FSettings.AllowedHosts := 'mcp.example, localhost'; + var Denied := Post(LEGACY_PING, []); + Assert.AreEqual(403, Denied.Status, 'the client sends Host: 127.0.0.1'); + Assert.IsTrue(Denied.Body.Contains('Host not allowed'), Denied.Body); + + FSettings.AllowedHosts := '127.0.0.1:*'; + Assert.AreEqual(200, Post(LEGACY_PING, []).Status); +end; + end. diff --git a/tests/MCPServer.Tests.HttpHeaders.pas b/tests/MCPServer.Tests.HttpHeaders.pas index c098438..52fcbe3 100644 --- a/tests/MCPServer.Tests.HttpHeaders.pas +++ b/tests/MCPServer.Tests.HttpHeaders.pas @@ -23,6 +23,7 @@ THttpHeadersTests = class [Test] procedure Origin_AllowListMatchesSchemeHostAndPort; [Test] procedure Origin_PortWildcardAndAllowAll; [Test] procedure Origin_DefaultPortEqualsExplicitPort; + [Test] procedure Host_AllowList_MatchesNameAndPort; [Test] procedure NestingDepth_CountsObjectsAndArraysOutsideStrings; end; @@ -154,6 +155,20 @@ procedure THttpHeadersTests.Origin_DefaultPortEqualsExplicitPort; 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"')); diff --git a/tests/MCPServer.Tests.ResourcesManager.pas b/tests/MCPServer.Tests.ResourcesManager.pas index bd93874..1ee4d3e 100644 --- a/tests/MCPServer.Tests.ResourcesManager.pas +++ b/tests/MCPServer.Tests.ResourcesManager.pas @@ -68,6 +68,7 @@ TResourcesManagerTests = class [Test] procedure Read_TemplateMismatch_IsNotFound; [Test] procedure Read_ViaTemplate_PercentDecodes_KeepsPlusLiteral; [Test] procedure Read_ViaTemplate_ConcurrentReads_Succeed; + [Test] procedure RemoveResourceTemplate_StopsMatching; end; implementation @@ -355,6 +356,18 @@ procedure TResourcesManagerTests.Read_ViaTemplate_ConcurrentReads_Succeed; end); end; +procedure TResourcesManagerTests.RemoveResourceTemplate_StopsMatching; +begin + FManager.RemoveResourceTemplate('echo://{value}'); + try + Read('echo://hello', TMCPProtocolEra.Modern).Free; + Assert.Fail('the template is gone'); + except + on E: EMCPError do + Assert.AreEqual(JSONRPC_INVALID_PARAMS, E.Code); + end; +end; + procedure TResourcesManagerTests.Read_TemplateMismatch_IsNotFound; begin try From f06cdfb35c546fe1de5a46c80097b1a24a8f4bb0 Mon Sep 17 00:00:00 2001 From: Marco Geuze Date: Fri, 4 Sep 2026 08:44:49 +0200 Subject: [PATCH 56/56] docs: security section, host allow-list and diagnostics switch --- CHANGELOG.md | 4 ++++ MIGRATION.md | 11 +++++++++++ README.md | 8 +++++++- 3 files changed, 22 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5415cfb..a76333f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -184,6 +184,10 @@ follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). 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 diff --git a/MIGRATION.md b/MIGRATION.md index ca4e5ce..d29fda1 100644 --- a/MIGRATION.md +++ b/MIGRATION.md @@ -162,6 +162,17 @@ at startup. `RequestStateTtlSeconds` bounds the replay window (600 s). 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` diff --git a/README.md b/README.md index a4b55de..1e7d406 100644 --- a/README.md +++ b/README.md @@ -19,8 +19,11 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte - [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) @@ -33,7 +36,8 @@ A Model Context Protocol (MCP) server implementation in Delphi, designed to inte - **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**: `Origin` validation against DNS rebinding on every request, loopback binding by default, CORS headers for browser clients, request size and nesting limits +- **Security**: `Origin` and `Host` validation against DNS rebinding on every request, loopback binding by default, CORS headers for browser clients, request size and nesting limits, opt-in bearer authentication with OAuth 2.1 resource-server discovery +- **Multi round-trip requests, streaming and subscriptions**: `InputRequiredResult` with signed `requestState`, progress and log notifications on the response stream, `subscriptions/listen` for change notifications - **High Performance**: Native implementation using Indy HTTP Server with keep-alive support - **Optional Parameters**: Support for optional tool parameters using custom attributes - **Cross-Platform**: Supports Windows (Win32/Win64) and Linux (x64) @@ -854,6 +858,8 @@ consults an authorizer. - `[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.