| 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 |
root |
1.5 |
=over |
| 24 |
root |
1.1 |
|
| 25 |
root |
1.5 |
=item $server = AnyEvent::MCP::Server->new (%config) |
| 26 |
root |
1.1 |
|
| 27 |
root |
1.5 |
Creates the protocol object without opening a listener or starting an |
| 28 |
|
|
event loop. Options are: |
| 29 |
root |
1.1 |
|
| 30 |
root |
1.5 |
=over |
| 31 |
|
|
|
| 32 |
|
|
=item toolsets => [$toolset...] |
| 33 |
|
|
|
| 34 |
|
|
L<AnyEvent::MCP::Server::Toolset> objects searched in order, defaulting to |
| 35 |
|
|
an empty array. The first Toolset containing a called tool handles it. |
| 36 |
|
|
|
| 37 |
|
|
=item server_info => { name => $name, version => $version } |
| 38 |
|
|
|
| 39 |
|
|
Advertised server identity, defaulting to C<AnyEvent::MCP> and this |
| 40 |
|
|
distribution's version. |
| 41 |
|
|
|
| 42 |
|
|
=item instructions => $text |
| 43 |
|
|
|
| 44 |
|
|
Optional human-readable guidance. Surrounding whitespace and common |
| 45 |
|
|
indentation are stripped. Empty instructions are omitted from discovery |
| 46 |
|
|
and initialization results. |
| 47 |
|
|
|
| 48 |
root |
1.8 |
=item short_instructions => $text |
| 49 |
|
|
|
| 50 |
|
|
Optional condensed guidance for deciding when to discover this server's tools. |
| 51 |
|
|
Used instead of C<instructions> in discovery when C<auto_instructions> is true. |
| 52 |
|
|
Without either short or custom instructions, the full instructions remain |
| 53 |
|
|
advertised. |
| 54 |
|
|
|
| 55 |
|
|
=item custom_instructions => $text |
| 56 |
|
|
|
| 57 |
|
|
Instance-specific purpose, prepended to the advertised instructions. |
| 58 |
|
|
|
| 59 |
|
|
=item auto_instructions => $boolean |
| 60 |
|
|
|
| 61 |
|
|
When true, expose full C<instructions>, prefixed by any custom instance |
| 62 |
|
|
purpose, in a C<meta-instructions> tool's description and call result. |
| 63 |
root |
1.9 |
Advertise C<short_instructions> instead, when provided, preceded by any |
| 64 |
|
|
custom purpose. Append a pointer to the generated tool's description when |
| 65 |
|
|
short or custom instructions exist. With neither, advertise the original |
| 66 |
|
|
full instructions without a redundant pointer. Defaults to false; |
| 67 |
root |
1.8 |
a conflicting tool name is an error. |
| 68 |
|
|
|
| 69 |
root |
1.5 |
=item capabilities => { %capabilities } |
| 70 |
|
|
|
| 71 |
|
|
Advertised server capabilities, defaulting to C<{ tools =E<gt> {} }>. |
| 72 |
|
|
Declaring a capability does not implement it. |
| 73 |
|
|
|
| 74 |
|
|
=item versions => [$version...] |
| 75 |
|
|
|
| 76 |
|
|
Supported revisions in preference order. Defaults to C<2026-07-28>, |
| 77 |
|
|
C<2025-11-25>, C<2025-06-18> and C<2025-03-26>. The 2026 protocol uses |
| 78 |
|
|
discovery and per-request metadata; the 2025 protocol uses initialization. |
| 79 |
|
|
|
| 80 |
|
|
=item permissions => $permissions |
| 81 |
|
|
|
| 82 |
|
|
L<AnyEvent::MCP::Server::Permissions> object used by |
| 83 |
|
|
C<< $req->require_permission >>. The server handles permission-needed |
| 84 |
|
|
exceptions. The permission object's C<ask> setting chooses between modern |
| 85 |
|
|
input challenges and local prompts; local asking retries the handler |
| 86 |
|
|
internally. Checks must precede side effects. |
| 87 |
|
|
|
| 88 |
|
|
=back |
| 89 |
|
|
|
| 90 |
|
|
Event callbacks are also constructor options; see L</EVENTS>. |
| 91 |
|
|
|
| 92 |
|
|
=item $req = $server->rpc ($message, $reply->($message), %context) |
| 93 |
root |
1.1 |
|
| 94 |
|
|
Accepts the decoded JSON-RPC hash reference C<$message>. C<$reply> receives |
| 95 |
root |
1.6 |
the decoded response, or undef when a notification is accepted or a request |
| 96 |
|
|
is cancelled. Undef completes transport bookkeeping without a JSON-RPC |
| 97 |
|
|
response. Returns the Request object for a request, or undef for |
| 98 |
|
|
notifications and rejected messages. |
| 99 |
root |
1.1 |
C<$reply> can be called before this method returns, or later. |
| 100 |
|
|
|
| 101 |
|
|
C<peer> in C<%context> is a hash reference shared by messages on one connection. |
| 102 |
|
|
It holds legacy initialization state and weak references to outstanding |
| 103 |
|
|
requests for cancellation. Embedders supply a different peer for each |
| 104 |
|
|
independent connection. Modern request metadata takes precedence over legacy |
| 105 |
|
|
peer state. |
| 106 |
|
|
|
| 107 |
|
|
C<protocol_version> supplies the legacy HTTP protocol version. |
| 108 |
|
|
C<on_notify> is an optional C<$callback->($req, $message)> receiving decoded |
| 109 |
|
|
outgoing notifications. Without it, notifications are dropped. |
| 110 |
|
|
|
| 111 |
root |
1.5 |
=item $req = $server->json_rpc ($json, $reply->($json), %context) |
| 112 |
root |
1.1 |
|
| 113 |
|
|
Like C<rpc>, but C<$json> and the response are UTF-8 encoded JSON strings. |
| 114 |
|
|
The notification callback still receives decoded objects. Parse errors are |
| 115 |
|
|
returned as JSON-RPC errors. |
| 116 |
|
|
|
| 117 |
root |
1.5 |
=item $server->dispatch ($req) |
| 118 |
root |
1.1 |
|
| 119 |
|
|
Dispatches an already constructed Request. Normally called by C<rpc>. |
| 120 |
|
|
Subclasses can override this method while retaining JSON-RPC handling. |
| 121 |
|
|
|
| 122 |
root |
1.5 |
=back |
| 123 |
|
|
|
| 124 |
root |
1.1 |
=head1 EVENTS |
| 125 |
|
|
|
| 126 |
root |
1.5 |
=over |
| 127 |
|
|
|
| 128 |
|
|
=item on_request => $callback->($server, $req) |
| 129 |
root |
1.1 |
|
| 130 |
|
|
Called before each dispatch attempt, including permission retries. This |
| 131 |
|
|
synchronous hook can inspect the request or refresh application state. |
| 132 |
|
|
It does not replace dispatch; avoid side effects that must happen only once. |
| 133 |
|
|
|
| 134 |
root |
1.5 |
=item on_tools_list => $callback->($server, $req) |
| 135 |
root |
1.1 |
|
| 136 |
|
|
Replaces the default Toolset listing. C<$callback> completes C<$req>. |
| 137 |
|
|
|
| 138 |
root |
1.5 |
=item on_tools_call => $callback->($server, $req, $args) |
| 139 |
root |
1.1 |
|
| 140 |
|
|
Replaces the default Toolset lookup and invocation. C<$args> is also available |
| 141 |
|
|
as C<< $req->{args} >>. C<$callback> completes C<$req>. |
| 142 |
|
|
|
| 143 |
root |
1.5 |
=item on_error => $callback->($server, $req, $error) |
| 144 |
root |
1.1 |
|
| 145 |
|
|
Reports an exception caught during synchronous dispatch. A tool exception |
| 146 |
|
|
becomes a text tool-error result; other exceptions become internal JSON-RPC |
| 147 |
|
|
errors. Exceptions after a reply are propagated, as are exceptions from |
| 148 |
|
|
asynchronous application callbacks. |
| 149 |
|
|
|
| 150 |
root |
1.5 |
=back |
| 151 |
|
|
|
| 152 |
root |
1.1 |
=cut |
| 153 |
|
|
|
| 154 |
|
|
package AnyEvent::MCP::Server; |
| 155 |
|
|
|
| 156 |
|
|
use common::sense; |
| 157 |
|
|
use AnyEvent::MCP (); |
| 158 |
|
|
use AnyEvent::MCP::Server::Request (); |
| 159 |
|
|
use JSON::XS (); |
| 160 |
|
|
use Scalar::Util qw(weaken); |
| 161 |
|
|
|
| 162 |
|
|
our @ISA = qw(AnyEvent::MCP::Base); |
| 163 |
|
|
|
| 164 |
|
|
sub new { |
| 165 |
|
|
my $class = shift; |
| 166 |
|
|
|
| 167 |
|
|
my $self = $class->SUPER::new ( |
| 168 |
|
|
toolsets => [], |
| 169 |
|
|
server_info => { name => "AnyEvent::MCP", version => $AnyEvent::MCP::VERSION }, |
| 170 |
|
|
capabilities => { tools => {} }, |
| 171 |
|
|
versions => [qw(2026-07-28 2025-11-25 2025-06-18 2025-03-26)], |
| 172 |
|
|
@_, |
| 173 |
|
|
); |
| 174 |
|
|
|
| 175 |
|
|
$self->{instructions} = AnyEvent::MCP::_clean_text $self->{instructions} |
| 176 |
|
|
if exists $self->{instructions}; |
| 177 |
|
|
|
| 178 |
root |
1.8 |
my $instructions = $self->{instructions}; |
| 179 |
|
|
my $custom = exists $self->{custom_instructions} |
| 180 |
|
|
? AnyEvent::MCP::_clean_text $self->{custom_instructions} : ""; |
| 181 |
|
|
|
| 182 |
|
|
if ($self->{auto_instructions} && length $instructions) { |
| 183 |
|
|
require AnyEvent::MCP::Server::Toolset; |
| 184 |
|
|
|
| 185 |
|
|
my $name = "meta-instructions"; |
| 186 |
|
|
!grep (exists $_->{tool}{$name}, @{$self->{toolsets}}) |
| 187 |
|
|
or die "duplicate MCP tool '$name'\n"; |
| 188 |
|
|
|
| 189 |
|
|
my $full = join "\n\n", grep length, $custom, $instructions; |
| 190 |
|
|
my $toolset = AnyEvent::MCP::Server::Toolset->new; |
| 191 |
|
|
$toolset->tool (meta_instructions => |
| 192 |
|
|
"Server instructions. Call for full text if truncated.\n\n$full", |
| 193 |
|
|
{ type => "object", properties => {} }, |
| 194 |
|
|
sub { $_[0]->reply ({ content => [{ type => "text", text => $full }] }) }, |
| 195 |
|
|
); |
| 196 |
|
|
$self->{toolsets} = [@{$self->{toolsets}}, $toolset]; |
| 197 |
|
|
|
| 198 |
|
|
my $short = exists $self->{short_instructions} |
| 199 |
|
|
? AnyEvent::MCP::_clean_text $self->{short_instructions} : ""; |
| 200 |
root |
1.9 |
$self->{instructions} = length $custom || length $short |
| 201 |
|
|
? join ("\n\n", grep length, $custom, $short, "Full instructions: meta-instructions tool description.") |
| 202 |
|
|
: $instructions; |
| 203 |
root |
1.8 |
|
| 204 |
|
|
} elsif (length $custom) { |
| 205 |
|
|
$self->{instructions} = join "\n\n", grep length, $custom, $instructions; |
| 206 |
|
|
} |
| 207 |
|
|
|
| 208 |
root |
1.1 |
$self |
| 209 |
|
|
} |
| 210 |
|
|
|
| 211 |
|
|
sub _rpc_error { |
| 212 |
|
|
my ($self, $reply, $id, $code, $message, $data) = @_; |
| 213 |
|
|
|
| 214 |
|
|
my $error = { code => $code, message => $message }; |
| 215 |
|
|
$error->{data} = $data if defined $data; |
| 216 |
|
|
|
| 217 |
|
|
$reply->({ jsonrpc => "2.0", id => $id, error => $error }); |
| 218 |
|
|
undef |
| 219 |
|
|
} |
| 220 |
|
|
|
| 221 |
|
|
sub json_rpc { |
| 222 |
|
|
my ($self, $json, $reply, @context) = @_; |
| 223 |
|
|
|
| 224 |
|
|
my $send = sub { $reply->(defined $_[0] ? JSON::XS::encode_json $_[0] : undef) }; |
| 225 |
|
|
my $message = eval { JSON::XS::decode_json $json }; |
| 226 |
|
|
|
| 227 |
|
|
return $self->_rpc_error ($send, undef, -32700, "Parse error") |
| 228 |
|
|
if $@; |
| 229 |
|
|
|
| 230 |
|
|
$self->rpc ($message, $send, @context) |
| 231 |
|
|
} |
| 232 |
|
|
|
| 233 |
|
|
sub rpc { |
| 234 |
|
|
my ($self, $message, $reply, %context) = @_; |
| 235 |
|
|
|
| 236 |
|
|
return $self->_rpc_error ($reply, undef, -32600, "Invalid request") |
| 237 |
|
|
unless ref $message eq "HASH" |
| 238 |
|
|
&& $message->{jsonrpc} eq "2.0" |
| 239 |
|
|
&& defined $message->{method} && !ref $message->{method} |
| 240 |
|
|
&& (!exists $message->{id} || defined $message->{id} && !ref $message->{id}); |
| 241 |
|
|
|
| 242 |
|
|
my $id = $message->{id}; |
| 243 |
|
|
my $key = $id; # Hash lookups must not stringify the wire ID. |
| 244 |
|
|
my $method = $message->{method}; |
| 245 |
|
|
my $params = exists $message->{params} ? $message->{params} : {}; |
| 246 |
|
|
my $peer = $context{peer} || {}; |
| 247 |
|
|
|
| 248 |
|
|
unless (exists $message->{id}) { |
| 249 |
|
|
if ($method eq "notifications/cancelled" && ref $params eq "HASH" && defined $params->{requestId}) { |
| 250 |
|
|
my $req = delete $peer->{requests}{$params->{requestId}}; |
| 251 |
|
|
$req->cancel ($params->{reason}) if $req; |
| 252 |
|
|
} |
| 253 |
|
|
|
| 254 |
|
|
$reply->(undef); |
| 255 |
|
|
return |
| 256 |
|
|
} |
| 257 |
|
|
|
| 258 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Invalid params") |
| 259 |
|
|
unless ref $params eq "HASH" |
| 260 |
|
|
&& (!exists $params->{_meta} || ref $params->{_meta} eq "HASH"); |
| 261 |
|
|
|
| 262 |
|
|
my $meta = $params->{_meta} || {}; |
| 263 |
|
|
my $version = $meta->{"io.modelcontextprotocol/protocolVersion"} |
| 264 |
|
|
|| $context{protocol_version} || $peer->{protocol_version}; |
| 265 |
|
|
|
| 266 |
|
|
if ($method eq "initialize") { |
| 267 |
|
|
$version = $params->{protocolVersion}; |
| 268 |
|
|
|
| 269 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Invalid initialize params") |
| 270 |
|
|
unless defined $version && !ref $version |
| 271 |
|
|
&& ref $params->{capabilities} eq "HASH" |
| 272 |
|
|
&& ref $params->{clientInfo} eq "HASH"; |
| 273 |
|
|
|
| 274 |
|
|
unless (grep $_ eq $version && $_ lt "2026", @{$self->{versions}}) { |
| 275 |
|
|
($version) = grep $_ lt "2026", @{$self->{versions}}; |
| 276 |
|
|
return $self->_rpc_error ($reply, $id, -32601, "Legacy initialization is not supported") |
| 277 |
|
|
unless defined $version; |
| 278 |
|
|
} |
| 279 |
|
|
} else { |
| 280 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Missing protocol version") |
| 281 |
|
|
unless defined $version && !ref $version; |
| 282 |
|
|
|
| 283 |
|
|
return $self->_rpc_error ($reply, $id, -32022, "Unsupported protocol version", { |
| 284 |
|
|
requested => $version, |
| 285 |
|
|
supported => $self->{versions}, |
| 286 |
|
|
}) unless grep $_ eq $version, @{$self->{versions}}; |
| 287 |
|
|
|
| 288 |
|
|
if ($version ge "2026") { |
| 289 |
|
|
return $self->_rpc_error ($reply, $id, -32602, "Missing per-request metadata") |
| 290 |
|
|
unless $meta->{"io.modelcontextprotocol/protocolVersion"} eq $version |
| 291 |
|
|
&& ref $meta->{"io.modelcontextprotocol/clientCapabilities"} eq "HASH"; |
| 292 |
|
|
} |
| 293 |
|
|
} |
| 294 |
|
|
|
| 295 |
|
|
return $self->_rpc_error ($reply, $id, -32600, "Request id already outstanding") |
| 296 |
|
|
if $peer->{requests}{$key}; |
| 297 |
|
|
|
| 298 |
root |
1.4 |
# the private multibroker protocol uses the normal MCP capability handshake. |
| 299 |
|
|
# keep the negotiated version on this stream's peer, not on the server. |
| 300 |
root |
1.3 |
my $capabilities = $method eq "initialize" |
| 301 |
|
|
? $params->{capabilities} : $meta->{"io.modelcontextprotocol/clientCapabilities"}; |
| 302 |
|
|
if (ref $capabilities eq "HASH") { |
| 303 |
|
|
my $extensions = $capabilities->{extensions}; |
| 304 |
|
|
if (ref $extensions eq "HASH") { |
| 305 |
|
|
my $extension = $extensions->{"anyevent-mcp/multibroker"}; |
| 306 |
|
|
$peer->{aemcp_multibroker} = 1 |
| 307 |
|
|
if ref $extension eq "HASH" && ($extension->{version} || 0) eq "1"; |
| 308 |
|
|
} |
| 309 |
|
|
} |
| 310 |
|
|
|
| 311 |
root |
1.1 |
my $req = AnyEvent::MCP::Server::Request->new ( |
| 312 |
root |
1.4 |
server => $self, |
| 313 |
|
|
peer => $peer, |
| 314 |
|
|
id => $id, |
| 315 |
|
|
method => $method, |
| 316 |
|
|
params => $params, |
| 317 |
root |
1.1 |
protocol_version => $version, |
| 318 |
root |
1.4 |
on_reply => sub { |
| 319 |
root |
1.1 |
my ($req, $result) = @_; |
| 320 |
|
|
|
| 321 |
|
|
delete $peer->{requests}{$key}; |
| 322 |
|
|
|
| 323 |
|
|
if ($req->{protocol_version} ge "2026") { |
| 324 |
|
|
$result = { |
| 325 |
|
|
resultType => "complete", |
| 326 |
|
|
%$result, |
| 327 |
|
|
_meta => { |
| 328 |
|
|
"io.modelcontextprotocol/serverInfo" => $self->{server_info}, |
| 329 |
|
|
%{$result->{_meta} || {}}, |
| 330 |
|
|
}, |
| 331 |
|
|
}; |
| 332 |
|
|
} |
| 333 |
|
|
|
| 334 |
|
|
$reply->({ jsonrpc => "2.0", id => $id, result => $result }); |
| 335 |
|
|
}, |
| 336 |
|
|
); |
| 337 |
|
|
|
| 338 |
|
|
if (my $notify = $context{on_notify}) { |
| 339 |
|
|
$req->{on_notify} = sub { |
| 340 |
|
|
my ($req, $method, $params) = @_; |
| 341 |
|
|
|
| 342 |
|
|
$notify->($req, { jsonrpc => "2.0", method => $method, params => $params }); |
| 343 |
|
|
}; |
| 344 |
|
|
} |
| 345 |
|
|
|
| 346 |
|
|
$peer->{requests}{$key} = $req; |
| 347 |
|
|
weaken $peer->{requests}{$key}; |
| 348 |
|
|
|
| 349 |
|
|
if ($method eq "tools/call") { |
| 350 |
|
|
unless (defined $params->{name} && !ref $params->{name} |
| 351 |
|
|
&& (!exists $params->{arguments} || ref $params->{arguments} eq "HASH")) { |
| 352 |
|
|
$self->_reject ($req, $reply, -32602, "Invalid tool call"); |
| 353 |
|
|
return $req |
| 354 |
|
|
} |
| 355 |
|
|
|
| 356 |
|
|
$req->{tool} = $params->{name}; |
| 357 |
|
|
$req->{args} = exists $params->{arguments} ? $params->{arguments} : {}; |
| 358 |
|
|
} |
| 359 |
|
|
|
| 360 |
|
|
$req->{_reply} = $reply; |
| 361 |
|
|
|
| 362 |
|
|
$self->_dispatch ($req); |
| 363 |
|
|
|
| 364 |
|
|
$req |
| 365 |
|
|
} |
| 366 |
|
|
|
| 367 |
|
|
sub _dispatch { |
| 368 |
|
|
my ($self, $req) = @_; |
| 369 |
|
|
|
| 370 |
|
|
eval { |
| 371 |
root |
1.7 |
if ($self->{permissions} && $req->{method} eq "tools/call" |
| 372 |
|
|
&& $self->{permissions}->auto_decision ($req->{tool}) eq "deny") { |
| 373 |
|
|
die "Permission denied by --auto-deny\n"; |
| 374 |
|
|
} |
| 375 |
|
|
|
| 376 |
root |
1.1 |
$self->{permissions}->_resume ($req) |
| 377 |
|
|
if $self->{permissions} && $req->{method} eq "tools/call"; |
| 378 |
|
|
$self->event (request => $req); |
| 379 |
|
|
$self->dispatch ($req) unless $req->{finished}; |
| 380 |
|
|
1 |
| 381 |
|
|
} or do { |
| 382 |
|
|
my $error = $@; |
| 383 |
|
|
die $error if $req->{finished}; |
| 384 |
|
|
|
| 385 |
|
|
if (ref $error eq "AnyEvent::MCP::Server::Permissions::Required" && $self->{permissions}) { |
| 386 |
|
|
eval { |
| 387 |
|
|
$self->{permissions}->require ($req, $error->{request}, sub { |
| 388 |
|
|
my ($success, $grant) = @_; |
| 389 |
root |
1.4 |
|
| 390 |
root |
1.1 |
return if $req->{finished}; |
| 391 |
|
|
return $req->error ($grant) unless $success; |
| 392 |
|
|
|
| 393 |
|
|
$self->{permissions}->_remember ($req, $error->{request}, $grant); |
| 394 |
|
|
$self->_dispatch ($req); |
| 395 |
|
|
}); |
| 396 |
|
|
1 |
| 397 |
|
|
} or do { |
| 398 |
|
|
my $failure = $@; |
| 399 |
|
|
die $failure if $req->{finished}; |
| 400 |
|
|
$self->event (error => $req, $failure); |
| 401 |
|
|
$req->error ($failure); |
| 402 |
|
|
}; |
| 403 |
|
|
} else { |
| 404 |
|
|
$self->event (error => $req, $error); |
| 405 |
|
|
|
| 406 |
|
|
if ($req->{method} eq "tools/call") { |
| 407 |
|
|
$req->error ($error); |
| 408 |
|
|
} else { |
| 409 |
|
|
$self->_reject ($req, $req->{_reply}, -32603, "Internal error"); |
| 410 |
|
|
} |
| 411 |
|
|
} |
| 412 |
|
|
}; |
| 413 |
|
|
} |
| 414 |
|
|
|
| 415 |
|
|
sub _reject { |
| 416 |
|
|
my ($self, $req, $reply, $code, $message) = @_; |
| 417 |
|
|
|
| 418 |
|
|
$req->{finished} = 1; |
| 419 |
|
|
my $key = $req->{id}; |
| 420 |
|
|
delete $req->{peer}{requests}{$key}; |
| 421 |
|
|
delete @$req{qw(on_reply on_notify on_cancel _reply)}; |
| 422 |
|
|
|
| 423 |
|
|
$self->_rpc_error ($reply, $req->{id}, $code, $message) |
| 424 |
|
|
} |
| 425 |
|
|
|
| 426 |
|
|
sub dispatch { |
| 427 |
|
|
my ($self, $req) = @_; |
| 428 |
root |
1.4 |
|
| 429 |
root |
1.1 |
my $method = $req->{method}; |
| 430 |
|
|
|
| 431 |
|
|
if ($method eq "initialize") { |
| 432 |
|
|
$req->{peer}{protocol_version} = $req->{protocol_version}; |
| 433 |
|
|
$req->{peer}{client_info} = $req->{params}{clientInfo}; |
| 434 |
|
|
$req->{peer}{client_capabilities} = $req->{params}{capabilities}; |
| 435 |
|
|
|
| 436 |
|
|
my $result = { |
| 437 |
|
|
protocolVersion => $req->{protocol_version}, |
| 438 |
|
|
serverInfo => $self->{server_info}, |
| 439 |
|
|
capabilities => $self->{capabilities}, |
| 440 |
|
|
}; |
| 441 |
root |
1.2 |
$result->{instructions} = $self->{instructions} if length $self->{instructions}; |
| 442 |
root |
1.1 |
|
| 443 |
|
|
$req->reply ($result); |
| 444 |
|
|
|
| 445 |
|
|
} elsif ($method eq "server/discover") { |
| 446 |
|
|
my $result = { |
| 447 |
|
|
supportedVersions => $self->{versions}, |
| 448 |
|
|
capabilities => $self->{capabilities}, |
| 449 |
|
|
}; |
| 450 |
root |
1.2 |
$result->{instructions} = $self->{instructions} if length $self->{instructions}; |
| 451 |
root |
1.1 |
|
| 452 |
|
|
$req->reply ($result); |
| 453 |
|
|
|
| 454 |
|
|
} elsif ($method eq "ping") { |
| 455 |
|
|
$req->reply ({}); |
| 456 |
|
|
|
| 457 |
|
|
} elsif ($method eq "tools/list") { |
| 458 |
|
|
if ($self->{on_tools_list}) { |
| 459 |
|
|
$self->event (tools_list => $req); |
| 460 |
|
|
} else { |
| 461 |
|
|
$req->reply ({ tools => [map @{$_->list}, @{$self->{toolsets}}] }); |
| 462 |
|
|
} |
| 463 |
|
|
|
| 464 |
|
|
} elsif ($method eq "tools/call") { |
| 465 |
|
|
if ($self->{on_tools_call}) { |
| 466 |
|
|
$self->event (tools_call => $req, $req->{args}); |
| 467 |
|
|
} else { |
| 468 |
|
|
my ($toolset) = grep exists $_->{tool}{$req->{tool}}, @{$self->{toolsets}}; |
| 469 |
|
|
|
| 470 |
|
|
if ($toolset) { |
| 471 |
|
|
$toolset->call ($req); |
| 472 |
|
|
} else { |
| 473 |
|
|
$self->_reject ($req, $req->{_reply}, -32602, "Unknown tool '$req->{tool}'"); |
| 474 |
|
|
} |
| 475 |
|
|
} |
| 476 |
|
|
|
| 477 |
|
|
} else { |
| 478 |
|
|
$self->_reject ($req, $req->{_reply}, -32601, "Method not found"); |
| 479 |
|
|
} |
| 480 |
|
|
} |
| 481 |
|
|
|
| 482 |
|
|
1 |
