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