ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-MCP/lib/AnyEvent/MCP/Server.pm
Revision: 1.7
Committed: Sun Oct 18 06:55:21 2026 UTC (3 weeks, 3 days ago) by root
Branch: MAIN
Changes since 1.6: +5 -0 lines
Log Message:
*** empty log message ***

File Contents

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