| 1 |
root |
1.1 |
=head1 NAME |
| 2 |
|
|
|
| 3 |
|
|
AnyEvent::MCP::Server - MCP request dispatch and JSON-RPC framing |
| 4 |
|
|
|
| 5 |
|
|
=head1 DESCRIPTION |
| 6 |
|
|
|
| 7 |
|
|
An MCP server needs to understand requests, but it does not necessarily need |
| 8 |
|
|
to own a listening socket. This class handles the protocol: it accepts decoded |
| 9 |
|
|
JSON-RPC objects (or UTF-8 JSON), dispatches requests and delivers responses |
| 10 |
|
|
through callbacks. Its subclasses L<AnyEvent::MCP::Server::JSONL> and |
| 11 |
|
|
L<AnyEvent::MCP::Server::HTTP> handle the actual connections. If you are |
| 12 |
|
|
writing a standalone server, L<AnyEvent::MCP::Server::Simple> is usually |
| 13 |
|
|
the easier starting point. |
| 14 |
|
|
|
| 15 |
|
|
The server implements discovery, initialization, ping and tool listing/calls. |
| 16 |
|
|
The 2025 compatibility path supports ordinary requests and responses, but |
| 17 |
|
|
not server-initiated requests. Permission asking supports modern input |
| 18 |
|
|
challenges as well as local helpers. SSE, subscriptions and schema validation |
| 19 |
|
|
are not implemented yet. |
| 20 |
|
|
|
| 21 |
|
|
=head1 METHODS |
| 22 |
|
|
|
| 23 |
|
|
=head2 $server = AnyEvent::MCP::Server->new (%config) |
| 24 |
|
|
|
| 25 |
|
|
C<toolsets> is an array reference of Toolsets searched in order. |
| 26 |
|
|
C<server_info> contains the server name and version; C<instructions> is optional |
| 27 |
|
|
human-readable guidance. C<capabilities> defaults to tool support. |
| 28 |
|
|
C<versions> lists supported protocol revisions, newest first. |
| 29 |
|
|
|
| 30 |
|
|
C<permissions> supplies an L<AnyEvent::MCP::Server::Permissions> object for |
| 31 |
|
|
C<< $req->require_permission >>. Permission-needed exceptions are handled |
| 32 |
|
|
by the server: modern MCP callers receive an input challenge; local or legacy |
| 33 |
|
|
asking retries the handler internally. Checks must precede side effects. |
| 34 |
|
|
|
| 35 |
|
|
C<instructions> is stripped of surrounding whitespace and common indentation. |
| 36 |
|
|
|
| 37 |
|
|
=head2 $req = $server->rpc ($message, $reply->($message), %context) |
| 38 |
|
|
|
| 39 |
|
|
Accepts the decoded JSON-RPC hash reference C<$message>. C<$reply> receives |
| 40 |
|
|
the decoded response, or undef when a notification is accepted. Returns the |
| 41 |
|
|
Request object for a request, or undef for notifications and rejected messages. |
| 42 |
|
|
C<$reply> can be called before this method returns, or later. |
| 43 |
|
|
|
| 44 |
|
|
C<peer> in C<%context> is a hash reference shared by messages on one connection. |
| 45 |
|
|
It holds legacy initialization state and weak references to outstanding |
| 46 |
|
|
requests for cancellation. Embedders supply a different peer for each |
| 47 |
|
|
independent connection. Modern request metadata takes precedence over legacy |
| 48 |
|
|
peer state. |
| 49 |
|
|
|
| 50 |
|
|
C<protocol_version> supplies the legacy HTTP protocol version. |
| 51 |
|
|
C<on_notify> is an optional C<$callback->($req, $message)> receiving decoded |
| 52 |
|
|
outgoing notifications. Without it, notifications are dropped. |
| 53 |
|
|
|
| 54 |
|
|
=head2 $req = $server->json_rpc ($json, $reply->($json), %context) |
| 55 |
|
|
|
| 56 |
|
|
Like C<rpc>, but C<$json> and the response are UTF-8 encoded JSON strings. |
| 57 |
|
|
The notification callback still receives decoded objects. Parse errors are |
| 58 |
|
|
returned as JSON-RPC errors. |
| 59 |
|
|
|
| 60 |
|
|
=head2 $server->dispatch ($req) |
| 61 |
|
|
|
| 62 |
|
|
Dispatches an already constructed Request. Normally called by C<rpc>. |
| 63 |
|
|
Subclasses can override this method while retaining JSON-RPC handling. |
| 64 |
|
|
|
| 65 |
|
|
=head1 EVENTS |
| 66 |
|
|
|
| 67 |
|
|
=head2 on_request => $callback->($server, $req) |
| 68 |
|
|
|
| 69 |
|
|
Called before each dispatch attempt, including permission retries. This |
| 70 |
|
|
synchronous hook can inspect the request or refresh application state. |
| 71 |
|
|
It does not replace dispatch; avoid side effects that must happen only once. |
| 72 |
|
|
|
| 73 |
|
|
=head2 on_tools_list => $callback->($server, $req) |
| 74 |
|
|
|
| 75 |
|
|
Replaces the default Toolset listing. C<$callback> completes C<$req>. |
| 76 |
|
|
|
| 77 |
|
|
=head2 on_tools_call => $callback->($server, $req, $args) |
| 78 |
|
|
|
| 79 |
|
|
Replaces the default Toolset lookup and invocation. C<$args> is also available |
| 80 |
|
|
as C<< $req->{args} >>. C<$callback> completes C<$req>. |
| 81 |
|
|
|
| 82 |
|
|
=head2 on_error => $callback->($server, $req, $error) |
| 83 |
|
|
|
| 84 |
|
|
Reports an exception caught during synchronous dispatch. A tool exception |
| 85 |
|
|
becomes a text tool-error result; other exceptions become internal JSON-RPC |
| 86 |
|
|
errors. Exceptions after a reply are propagated, as are exceptions from |
| 87 |
|
|
asynchronous application callbacks. |
| 88 |
|
|
|
| 89 |
|
|
=cut |
| 90 |
|
|
|
| 91 |
|
|
package AnyEvent::MCP::Server; |
| 92 |
|
|
|
| 93 |
|
|
use common::sense; |
| 94 |
|
|
use AnyEvent::MCP (); |
| 95 |
|
|
use AnyEvent::MCP::Server::Request (); |
| 96 |
|
|
use JSON::XS (); |
| 97 |
|
|
use Scalar::Util qw(weaken); |
| 98 |
|
|
|
| 99 |
|
|
our @ISA = qw(AnyEvent::MCP::Base); |
| 100 |
|
|
|
| 101 |
|
|
sub new { |
| 102 |
|
|
my $class = shift; |
| 103 |
|
|
|
| 104 |
|
|
my $self = $class->SUPER::new ( |
| 105 |
|
|
toolsets => [], |
| 106 |
|
|
server_info => { name => "AnyEvent::MCP", version => $AnyEvent::MCP::VERSION }, |
| 107 |
|
|
capabilities => { tools => {} }, |
| 108 |
|
|
versions => [qw(2026-07-28 2025-11-25 2025-06-18 2025-03-26)], |
| 109 |
|
|
@_, |
| 110 |
|
|
); |
| 111 |
|
|
|
| 112 |
|
|
$self->{instructions} = AnyEvent::MCP::_clean_text $self->{instructions} |
| 113 |
|
|
if exists $self->{instructions}; |
| 114 |
|
|
|
| 115 |
|
|
$self |
| 116 |
|
|
} |
| 117 |
|
|
|
| 118 |
|
|
sub _rpc_error { |
| 119 |
|
|
my ($self, $reply, $id, $code, $message, $data) = @_; |
| 120 |
|
|
|
| 121 |
|
|
my $error = { code => $code, message => $message }; |
| 122 |
|
|
$error->{data} = $data if defined $data; |
| 123 |
|
|
|
| 124 |
|
|
$reply->({ jsonrpc => "2.0", id => $id, error => $error }); |
| 125 |
|
|
undef |
| 126 |
|
|
} |
| 127 |
|
|
|
| 128 |
|
|
sub json_rpc { |
| 129 |
|
|
my ($self, $json, $reply, @context) = @_; |
| 130 |
|
|
|
| 131 |
|
|
my $send = sub { $reply->(defined $_[0] ? JSON::XS::encode_json $_[0] : undef) }; |
| 132 |
|
|
my $message = eval { JSON::XS::decode_json $json }; |
| 133 |
|
|
|
| 134 |
|
|
return $self->_rpc_error ($send, undef, -32700, "Parse error") |
| 135 |
|
|
if $@; |
| 136 |
|
|
|
| 137 |
|
|
$self->rpc ($message, $send, @context) |
| 138 |
|
|
} |
| 139 |
|
|
|
| 140 |
|
|
sub rpc { |
| 141 |
|
|
my ($self, $message, $reply, %context) = @_; |
| 142 |
|
|
|
| 143 |
|
|
return $self->_rpc_error ($reply, undef, -32600, "Invalid request") |
| 144 |
|
|
unless ref $message eq "HASH" |
| 145 |
|
|
&& $message->{jsonrpc} eq "2.0" |
| 146 |
|
|
&& defined $message->{method} && !ref $message->{method} |
| 147 |
|
|
&& (!exists $message->{id} || defined $message->{id} && !ref $message->{id}); |
| 148 |
|
|
|
| 149 |
|
|
my $id = $message->{id}; |
| 150 |
|
|
my $key = $id; # Hash lookups must not stringify the wire ID. |
| 151 |
|
|
my $method = $message->{method}; |
| 152 |
|
|
my $params = exists $message->{params} ? $message->{params} : {}; |
| 153 |
|
|
my $peer = $context{peer} || {}; |
| 154 |
|
|
|
| 155 |
|
|
unless (exists $message->{id}) { |
| 156 |
|
|
if ($method eq "notifications/cancelled" && ref $params eq "HASH" && defined $params->{requestId}) { |
| 157 |
|
|
my $req = delete $peer->{requests}{$params->{requestId}}; |
| 158 |
|
|
$req->cancel ($params->{reason}) if $req; |
| 159 |
|
|
} |
| 160 |
|
|
|
| 161 |
|
|
$reply->(undef); |
| 162 |
|
|
return |
| 163 |
|
|
} |
| 164 |
|
|
|
| 165 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Invalid params") |
| 166 |
|
|
unless ref $params eq "HASH" |
| 167 |
|
|
&& (!exists $params->{_meta} || ref $params->{_meta} eq "HASH"); |
| 168 |
|
|
|
| 169 |
|
|
my $meta = $params->{_meta} || {}; |
| 170 |
|
|
my $version = $meta->{"io.modelcontextprotocol/protocolVersion"} |
| 171 |
|
|
|| $context{protocol_version} || $peer->{protocol_version}; |
| 172 |
|
|
|
| 173 |
|
|
if ($method eq "initialize") { |
| 174 |
|
|
$version = $params->{protocolVersion}; |
| 175 |
|
|
|
| 176 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Invalid initialize params") |
| 177 |
|
|
unless defined $version && !ref $version |
| 178 |
|
|
&& ref $params->{capabilities} eq "HASH" |
| 179 |
|
|
&& ref $params->{clientInfo} eq "HASH"; |
| 180 |
|
|
|
| 181 |
|
|
unless (grep $_ eq $version && $_ lt "2026", @{$self->{versions}}) { |
| 182 |
|
|
($version) = grep $_ lt "2026", @{$self->{versions}}; |
| 183 |
|
|
return $self->_rpc_error ($reply, $id, -32601, "Legacy initialization is not supported") |
| 184 |
|
|
unless defined $version; |
| 185 |
|
|
} |
| 186 |
|
|
} else { |
| 187 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Missing protocol version") |
| 188 |
|
|
unless defined $version && !ref $version; |
| 189 |
|
|
|
| 190 |
|
|
return $self->_rpc_error ($reply, $id, -32022, "Unsupported protocol version", { |
| 191 |
|
|
requested => $version, |
| 192 |
|
|
supported => $self->{versions}, |
| 193 |
|
|
}) unless grep $_ eq $version, @{$self->{versions}}; |
| 194 |
|
|
|
| 195 |
|
|
if ($version ge "2026") { |
| 196 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Missing per-request metadata") |
| 197 |
|
|
unless $meta->{"io.modelcontextprotocol/protocolVersion"} eq $version |
| 198 |
|
|
&& ref $meta->{"io.modelcontextprotocol/clientCapabilities"} eq "HASH"; |
| 199 |
|
|
} |
| 200 |
|
|
} |
| 201 |
|
|
|
| 202 |
|
|
return $self->_rpc_error ($reply, $id, -32600, "Request id already outstanding") |
| 203 |
|
|
if $peer->{requests}{$key}; |
| 204 |
|
|
|
| 205 |
|
|
my $req = AnyEvent::MCP::Server::Request->new ( |
| 206 |
|
|
server => $self, |
| 207 |
|
|
peer => $peer, |
| 208 |
|
|
id => $id, |
| 209 |
|
|
method => $method, |
| 210 |
|
|
params => $params, |
| 211 |
|
|
protocol_version => $version, |
| 212 |
|
|
on_reply => sub { |
| 213 |
|
|
my ($req, $result) = @_; |
| 214 |
|
|
|
| 215 |
|
|
delete $peer->{requests}{$key}; |
| 216 |
|
|
|
| 217 |
|
|
if ($req->{protocol_version} ge "2026") { |
| 218 |
|
|
$result = { |
| 219 |
|
|
resultType => "complete", |
| 220 |
|
|
%$result, |
| 221 |
|
|
_meta => { |
| 222 |
|
|
"io.modelcontextprotocol/serverInfo" => $self->{server_info}, |
| 223 |
|
|
%{$result->{_meta} || {}}, |
| 224 |
|
|
}, |
| 225 |
|
|
}; |
| 226 |
|
|
} |
| 227 |
|
|
|
| 228 |
|
|
$reply->({ jsonrpc => "2.0", id => $id, result => $result }); |
| 229 |
|
|
}, |
| 230 |
|
|
); |
| 231 |
|
|
|
| 232 |
|
|
if (my $notify = $context{on_notify}) { |
| 233 |
|
|
$req->{on_notify} = sub { |
| 234 |
|
|
my ($req, $method, $params) = @_; |
| 235 |
|
|
|
| 236 |
|
|
$notify->($req, { jsonrpc => "2.0", method => $method, params => $params }); |
| 237 |
|
|
}; |
| 238 |
|
|
} |
| 239 |
|
|
|
| 240 |
|
|
$peer->{requests}{$key} = $req; |
| 241 |
|
|
weaken $peer->{requests}{$key}; |
| 242 |
|
|
|
| 243 |
|
|
if ($method eq "tools/call") { |
| 244 |
|
|
unless (defined $params->{name} && !ref $params->{name} |
| 245 |
|
|
&& (!exists $params->{arguments} || ref $params->{arguments} eq "HASH")) { |
| 246 |
|
|
$self->_reject ($req, $reply, -32602, "Invalid tool call"); |
| 247 |
|
|
return $req |
| 248 |
|
|
} |
| 249 |
|
|
|
| 250 |
|
|
$req->{tool} = $params->{name}; |
| 251 |
|
|
$req->{args} = exists $params->{arguments} ? $params->{arguments} : {}; |
| 252 |
|
|
} |
| 253 |
|
|
|
| 254 |
|
|
$req->{_reply} = $reply; |
| 255 |
|
|
|
| 256 |
|
|
$self->_dispatch ($req); |
| 257 |
|
|
|
| 258 |
|
|
$req |
| 259 |
|
|
} |
| 260 |
|
|
|
| 261 |
|
|
sub _dispatch { |
| 262 |
|
|
my ($self, $req) = @_; |
| 263 |
|
|
|
| 264 |
|
|
eval { |
| 265 |
|
|
$self->{permissions}->_resume ($req) |
| 266 |
|
|
if $self->{permissions} && $req->{method} eq "tools/call"; |
| 267 |
|
|
$self->event (request => $req); |
| 268 |
|
|
$self->dispatch ($req) unless $req->{finished}; |
| 269 |
|
|
1 |
| 270 |
|
|
} or do { |
| 271 |
|
|
my $error = $@; |
| 272 |
|
|
die $error if $req->{finished}; |
| 273 |
|
|
|
| 274 |
|
|
if (ref $error eq "AnyEvent::MCP::Server::Permissions::Required" && $self->{permissions}) { |
| 275 |
|
|
eval { |
| 276 |
|
|
$self->{permissions}->require ($req, $error->{request}, sub { |
| 277 |
|
|
my ($success, $grant) = @_; |
| 278 |
|
|
return if $req->{finished}; |
| 279 |
|
|
return $req->error ($grant) unless $success; |
| 280 |
|
|
|
| 281 |
|
|
$self->{permissions}->_remember ($req, $error->{request}, $grant); |
| 282 |
|
|
$self->_dispatch ($req); |
| 283 |
|
|
}); |
| 284 |
|
|
1 |
| 285 |
|
|
} or do { |
| 286 |
|
|
my $failure = $@; |
| 287 |
|
|
die $failure if $req->{finished}; |
| 288 |
|
|
$self->event (error => $req, $failure); |
| 289 |
|
|
$req->error ($failure); |
| 290 |
|
|
}; |
| 291 |
|
|
} else { |
| 292 |
|
|
$self->event (error => $req, $error); |
| 293 |
|
|
|
| 294 |
|
|
if ($req->{method} eq "tools/call") { |
| 295 |
|
|
$req->error ($error); |
| 296 |
|
|
} else { |
| 297 |
|
|
$self->_reject ($req, $req->{_reply}, -32603, "Internal error"); |
| 298 |
|
|
} |
| 299 |
|
|
} |
| 300 |
|
|
}; |
| 301 |
|
|
} |
| 302 |
|
|
|
| 303 |
|
|
sub _reject { |
| 304 |
|
|
my ($self, $req, $reply, $code, $message) = @_; |
| 305 |
|
|
|
| 306 |
|
|
$req->{finished} = 1; |
| 307 |
|
|
my $key = $req->{id}; |
| 308 |
|
|
delete $req->{peer}{requests}{$key}; |
| 309 |
|
|
delete @$req{qw(on_reply on_notify on_cancel _reply)}; |
| 310 |
|
|
|
| 311 |
|
|
$self->_rpc_error ($reply, $req->{id}, $code, $message) |
| 312 |
|
|
} |
| 313 |
|
|
|
| 314 |
|
|
sub dispatch { |
| 315 |
|
|
my ($self, $req) = @_; |
| 316 |
|
|
my $method = $req->{method}; |
| 317 |
|
|
|
| 318 |
|
|
if ($method eq "initialize") { |
| 319 |
|
|
$req->{peer}{protocol_version} = $req->{protocol_version}; |
| 320 |
|
|
$req->{peer}{client_info} = $req->{params}{clientInfo}; |
| 321 |
|
|
$req->{peer}{client_capabilities} = $req->{params}{capabilities}; |
| 322 |
|
|
|
| 323 |
|
|
my $result = { |
| 324 |
|
|
protocolVersion => $req->{protocol_version}, |
| 325 |
|
|
serverInfo => $self->{server_info}, |
| 326 |
|
|
capabilities => $self->{capabilities}, |
| 327 |
|
|
}; |
| 328 |
|
|
$result->{instructions} = $self->{instructions} if exists $self->{instructions}; |
| 329 |
|
|
|
| 330 |
|
|
$req->reply ($result); |
| 331 |
|
|
|
| 332 |
|
|
} elsif ($method eq "server/discover") { |
| 333 |
|
|
my $result = { |
| 334 |
|
|
supportedVersions => $self->{versions}, |
| 335 |
|
|
capabilities => $self->{capabilities}, |
| 336 |
|
|
}; |
| 337 |
|
|
$result->{instructions} = $self->{instructions} if exists $self->{instructions}; |
| 338 |
|
|
|
| 339 |
|
|
$req->reply ($result); |
| 340 |
|
|
|
| 341 |
|
|
} elsif ($method eq "ping") { |
| 342 |
|
|
$req->reply ({}); |
| 343 |
|
|
|
| 344 |
|
|
} elsif ($method eq "tools/list") { |
| 345 |
|
|
if ($self->{on_tools_list}) { |
| 346 |
|
|
$self->event (tools_list => $req); |
| 347 |
|
|
} else { |
| 348 |
|
|
$req->reply ({ tools => [map @{$_->list}, @{$self->{toolsets}}] }); |
| 349 |
|
|
} |
| 350 |
|
|
|
| 351 |
|
|
} elsif ($method eq "tools/call") { |
| 352 |
|
|
if ($self->{on_tools_call}) { |
| 353 |
|
|
$self->event (tools_call => $req, $req->{args}); |
| 354 |
|
|
} else { |
| 355 |
|
|
my ($toolset) = grep exists $_->{tool}{$req->{tool}}, @{$self->{toolsets}}; |
| 356 |
|
|
|
| 357 |
|
|
if ($toolset) { |
| 358 |
|
|
$toolset->call ($req); |
| 359 |
|
|
} else { |
| 360 |
|
|
$self->_reject ($req, $req->{_reply}, -32602, "Unknown tool '$req->{tool}'"); |
| 361 |
|
|
} |
| 362 |
|
|
} |
| 363 |
|
|
|
| 364 |
|
|
} else { |
| 365 |
|
|
$self->_reject ($req, $req->{_reply}, -32601, "Method not found"); |
| 366 |
|
|
} |
| 367 |
|
|
} |
| 368 |
|
|
|
| 369 |
|
|
1 |
