ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-MCP/lib/AnyEvent/MCP/Server/HTTP.pm
Revision: 1.23
Committed: Fri Nov 6 03:08:19 2026 UTC (10 hours, 20 minutes ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.22: +9 -1 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3     AnyEvent::MCP::Server::HTTP - an optional MCP HTTP listener and socket handler
4    
5     =head1 DESCRIPTION
6    
7 root 1.3 A subclass of L<AnyEvent::MCP::Server> that handles HTTP POST requests.
8     It can open its own listener, or you can give it sockets accepted elsewhere.
9     If your application already parses HTTP, you can pass decoded requests to
10     L<AnyEvent::MCP::Server> instead of running another HTTP implementation.
11    
12     Requests sharing one connection are dispatched in sequence, preserving their
13     HTTP response order; requests on other connections are independent. This
14     implementation returns JSON and drops notifications. It does not support
15     SSE or subscriptions.
16    
17     Request bodies need C<Content-Length>: chunked transfer encoding is not
18     supported. The server does not assign protocol sessions. Legacy clients
19     use the 2025 request/response subset.
20 root 1.1
21 root 1.10 C<Mcp-Param-*> headers from C<x-mcp-header> tool schema annotations are not
22 root 1.13 currently validated against the body. The built-in protocol headers
23     C<Mcp-Protocol-Version>, C<Mcp-Method> and, where applicable, C<Mcp-Name>
24     must agree with modern request metadata and parameters; a mismatch is
25     rejected. Custom schema-derived headers do not receive this check.
26 root 1.10
27 root 1.16 =head1 FIRST USE
28    
29     For an application that already registers tools in
30     L<AnyEvent::MCP::Server::Toolset>, start an HTTP listener:
31    
32     use AnyEvent;
33     use AnyEvent::MCP::Server::HTTP;
34    
35     my $server = AnyEvent::MCP::Server::HTTP->new (
36     toolsets => [$tools], tokens => [$secret],
37     host => "127.0.0.1", port => 31740,
38     );
39     $server->listen;
40     print $server->url, "\n";
41     AE::cv->recv;
42    
43     C<$tools> is a Toolset and C<$secret> is a previously generated private
44     URL-safe token. Do not use a sample or hardcoded token in a real service.
45     This object handles sockets and HTTP; L<AnyEvent::MCP::Server> dispatches
46     requests, while the Toolset runs tool callbacks. For a standalone program
47     with automatic configuration and startup, prefer
48     L<AnyEvent::MCP::Server::Simple>.
49    
50 root 1.7 =head1 AUTHENTICATION
51    
52     Unlike L<AnyEvent::MCP::Server::Simple/mcp_start>, this low-level object
53     does not load global configuration or derive credentials. Supply C<tokens>
54     explicitly, for example:
55    
56     my $server = AnyEvent::MCP::Server::HTTP->new (
57     host => "127.0.0.1",
58     port => 31740,
59     path => "/mcp/",
60     tokens => ["a-long-random-secret", "another-long-random-secret"],
61     );
62     $server->listen;
63    
64     Each token authorizes the same requests. For either token, a client may
65     POST to C</TOKEN/mcp/> without an Authorization header, or POST to
66     C</mcp/> with C<Authorization: Bearer TOKEN>. URL credentials are path
67     components, B<not> HTTP cookies. C<url> advertises the first token;
68 root 1.17 C<url (0)> returns the clean endpoint. A trailing slash may be omitted
69     from either request path when the configured endpoint path ends in one;
70     this accommodates clients that strip it from a configured URL.
71 root 1.7
72     The accepted tokens are static, URL-safe strings. HTTP Basic and OAuth
73     access-token validation are not implemented here. There is no automatic
74     fallback to the master-secret-derived token: that belongs to C<mcp_start>
75     or L<AnyEvent::MCP::Config/http_settings>.
76    
77 root 1.8 Authentication defaults to C<tokens>, and construction B<fails> unless a
78     nonempty array of valid tokens is provided. To deliberately delegate
79     authentication to a trusted embedding layer (for example, a reverse proxy
80     that rejects unauthorized requests before they reach MCP), specify
81     C<auth =E<gt> "none"> instead, B<without> C<tokens>. This is an explicit
82     opt-out, not a permissive default. The embedding layer then owns the
83     entire authentication boundary.
84 root 1.7 The C<origins> setting filters browser origins; it is not authentication.
85     URLs can leak through logs and histories, and HTTP alone does not encrypt
86     tokens. Use TLS when credentials cross an untrusted network. A local address
87     is a sensible default, but not a credential.
88    
89 root 1.1 =head1 METHODS
90    
91 root 1.13 =over
92    
93     =item $server = AnyEvent::MCP::Server::HTTP->new (%config)
94 root 1.1
95     Construction does not start a listener. In addition to Server options,
96     the following configuration options are supported:
97    
98 root 1.3 =over
99 root 1.1
100     =item host => $host
101    
102     The listening address, defaulting to C<127.0.0.1>.
103    
104     =item port => $port
105    
106     The listening port, defaulting to zero for an automatically assigned port.
107    
108     =item path => $path
109    
110 root 1.6 The MCP endpoint path, defaulting to C</mcp/>. Bearer authentication uses
111 root 1.17 C<$path> directly; URL tokens prefix it with C</TOKEN>. If this path ends
112     in C</>, requests without that final slash are also accepted. Other
113     path differences are not normalized.
114 root 1.1
115     =item connection_close => $boolean
116    
117     When true, disables persistent connections, sends C<Connection: close> and
118     closes the socket after draining each response. Defaults to false.
119     This is useful when an existing listener routes sockets by their first
120     request and cannot route subsequent requests independently.
121    
122     =item max_size => $bytes
123    
124 root 1.18 Limits incoming headers and request bodies, defaulting to 8 MiB.
125 root 1.1
126     =item origins => [$origin...]
127    
128 root 1.4 Allowed Origin header values. Defaults to C<["*"]>, permitting browser requests
129     from any origin. An empty array rejects requests with an Origin header, while
130     requests without one are accepted. Allowed origins receive CORS response headers,
131     and nonempty origin lists enable OPTIONS preflight for POST. Preflight does not
132 root 1.1 require authentication; the subsequent POST still does.
133    
134     =item handle => { %handle }
135    
136     AnyEvent::Handle constructor options, such as C<tls>, C<tls_ctx>, C<timeout>
137     or C<on_starttls>. The socket and the read/error/EOF handlers belong to this
138     class.
139    
140 root 1.20 =item tls_cert => $file
141    
142     Serve HTTP and HTTPS opportunistically on the same port. FILE contains
143     a PEM certificate chain and optionally its private key. The TLS context
144     is loaded once when listening starts. TLS needs L<Net::SSLeay>.
145    
146     =item tls_key => $file
147    
148     PEM private key for C<tls_cert>. If only one TLS option is supplied, its
149     file must contain both certificate and private key. On accepted connections,
150     C<< $handle->{tls} >> identifies encrypted traffic. Plain HTTP remains
151     available; TLS is not required of clients.
152    
153 root 1.6 =item tokens => [$token, ...]
154 root 1.1
155 root 1.6 Ordered tokens accepted either as C</TOKEN> before the configured
156     C<path> or in an C<Authorization: Bearer TOKEN> header. The first token
157 root 1.8 is used in advertised URLs. Token strings must be URL-safe and nonempty.
158    
159     =item auth => "tokens" | "none"
160    
161     Select authentication mode. C<tokens> is the default and requires at least
162     one token; C<none> explicitly disables HTTP authentication and cannot be
163     combined with tokens. Other values are rejected. Browser origins are
164     not a replacement for authentication.
165 root 1.1
166     =item name => $name
167    
168 root 1.6 Identifies the service. Use L<AnyEvent::MCP::Config/http_settings>
169     to resolve named listener configuration before constructing this transport.
170 root 1.1
171     =item url_host => $hostname
172    
173     Overrides the advertised hostname, for example when listening on a wildcard
174     address. Otherwise a wildcard uses the nodename from C<uname>.
175    
176     =item url_scheme => $scheme
177    
178 root 1.20 Overrides the advertised scheme; otherwise TLS credentials or handle options
179     select C<https>, and plain handles select C<http>.
180 root 1.1
181     =back
182    
183 root 1.6 Every configured token authenticates in either the URL or the Authorization
184 root 1.8 header. Without tokens, the constructor requires C<auth =E<gt> "none">.
185 root 1.6
186 root 1.13 =item $url = $server->url ($with_token)
187 root 1.6
188     Returns the advertised URL with the actual listening port. C<$with_token>
189     defaults to true, including the first configured token. Pass false for
190     the clean URL to use with an Authorization bearer token.
191 root 1.1
192     The port must be known. Wildcard hostname resolution and reverse-proxy
193     routing remain the caller's responsibility.
194    
195 root 1.13 =item $server->listen ($host, $port, %handle)
196 root 1.1
197     Starts a listener, replacing any previous listener. Omitted arguments use
198     the configured host and port. The actual bound port is stored in
199     C<< $server->{port} >>, including when requesting an ephemeral port.
200    
201     C<%handle> overrides the configured C<handle> options for connections
202     accepted by this listener.
203    
204 root 1.13 =item $handle = $server->accept ($socket, %handle)
205 root 1.1
206     Starts handling an already accepted socket. The server takes ownership of
207     C<$socket>. No listener is needed.
208    
209     C<%handle> overrides the configured C<handle> options for this connection.
210    
211 root 1.13 =item $server->close
212 root 1.1
213     Stops listening, closes accepted sockets and cancels outstanding requests.
214     The same object can subsequently listen or accept again.
215    
216 root 1.13 =back
217    
218 root 1.1 =head1 EVENTS
219    
220 root 1.13 =over
221    
222 root 1.14 =item on_extension => $callback->($server, $handle, $hello)
223    
224     Accept raw extension connections on the HTTP listener. A first byte of C<[>
225     selects a bounded, newline-terminated JSON hello whose first two fields are
226     the protocol name and an accepted listener token. Authenticate before invoking
227     this callback, which validates the protocol-specific fields and takes ownership
228     of the handle, preserving buffered input. Throw an exception to reject it.
229     HTTP connections continue through the normal parser. This dispatch examines
230     decrypted bytes when TLS is configured, but the built-in reverse connector
231     currently supports only plain C<http://> endpoints.
232    
233 root 1.15 =item on_http_request => $callback->($server, $request, $reply)
234    
235     Called for every complete, syntactically valid HTTP request before MCP routing
236     or authentication. C<$request> is a hash containing the parsed HTTP fields
237     (including C<method>, C<uri>, and C<http_version>) and a C<body> field holding
238     the raw request body. Return false to use the normal MCP handling, or true to
239     handle the request yourself.
240    
241     C<$reply-E<gt>($status, $reason, \%headers, $body)> sends a response, either
242     immediately or asynchronously after the callback returns. C<%headers> is
243     optional; C<Content-Type> defaults to C<application/json>, and the server
244     generates C<Content-Length> and manages persistent connections. The body is
245     an octet string. Reply at most once, and return true when taking ownership
246     of the request, even if the response will be sent later. The next request on
247     the same connection is not read until that response is sent.
248    
249     The hook runs B<before> MCP authentication and CORS checks. Application
250     endpoints must perform their own authentication and browser request checks.
251     It does not replace or bypass the normal authentication of unhandled MCP
252     requests. Malformed or oversized requests are rejected before the hook.
253    
254 root 1.13 =item on_connection_error => $callback->($server, $handle, $message)
255 root 1.1
256     Called for socket errors before closing the connection.
257    
258 root 1.13 =item on_close => $callback->($server)
259 root 1.1
260     Called once after C<close> stops the listener and closes all connections.
261     Calling C<listen> or C<accept> again starts a new lifetime.
262    
263 root 1.13 =back
264    
265 root 1.1 =cut
266    
267     package AnyEvent::MCP::Server::HTTP;
268    
269     use common::sense;
270     use parent "AnyEvent::MCP::Server";
271 root 1.23 use AnyEvent::Log ();
272 root 1.1 use AnyEvent::Handle ();
273     use AnyEvent::Socket ();
274     use JSON::XS ();
275 root 1.23 use Scalar::Util qw(refaddr weaken);
276 root 1.1 use POSIX ();
277    
278     sub new {
279     my ($class, %kv) = @_;
280 root 1.12
281 root 1.6 !grep (exists $kv{$_}, qw(cookie bearer users))
282     or die "Legacy HTTP authentication options are unsupported; use tokens\n";
283 root 1.1
284 root 1.8 $kv{auth} //= "tokens";
285     if ($kv{auth} eq "tokens") {
286 root 1.6 ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
287     or die "HTTP server requires nonempty tokens\n";
288     /\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
289     for @{$kv{tokens}};
290 root 1.8 } elsif ($kv{auth} eq "none") {
291     !exists $kv{tokens}
292     or die "Unauthenticated HTTP server must not configure tokens\n";
293     } else {
294     die "Unsupported HTTP authentication type '$kv{auth}'\n";
295 root 1.1 }
296    
297 root 1.4 $class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
298 root 1.1 }
299    
300 root 1.20 sub _tls_context {
301     my ($self) = @_;
302    
303     return unless defined $self->{tls_cert} || defined $self->{tls_key};
304    
305     $self->{_tls_context} ||= do {
306     require AnyEvent::TLS;
307     AnyEvent::TLS->new (
308     cert_file => $self->{tls_cert} // $self->{tls_key},
309     (defined $self->{tls_key} ? (key_file => $self->{tls_key}) : ()),
310     )
311     }
312     }
313    
314 root 1.1 sub listen {
315     my ($self, $host, $port, %handle) = @_;
316    
317 root 1.20 $self->_tls_context;
318 root 1.1 delete $self->{_closed};
319     $host = $self->{host} unless defined $host;
320     $port = $self->{port} unless defined $port;
321    
322     $self->{listen_host} = $host;
323     $self->{listen_handle} = { %{$self->{handle} || {}}, %handle };
324    
325     delete $self->{listener};
326     weaken $self;
327    
328     $self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
329 root 1.19 return unless $self;
330     my ($socket, $host, $port) = @_;
331     my $handle = $self->accept ($socket, %handle);
332     $handle->{mcp_remote} = AnyEvent::Socket::format_hostport ($host, $port);
333 root 1.1 }, sub {
334     $self->{port} = $_[2] if $self;
335     ()
336     };
337     }
338    
339 root 1.6 sub _token_path {
340     my ($self, $token) = @_;
341 root 1.12
342 root 1.6 "/$token$self->{path}"
343 root 1.1 }
344    
345     sub url {
346 root 1.12 my ($self, $with_token) = @_;
347 root 1.1
348 root 1.12 $with_token = 1 unless defined $with_token;
349 root 1.1
350     my $host = $self->{url_host}
351     || (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
352     $host = (POSIX::uname)[1] if !length $host || $host eq "0.0.0.0" || $host eq "::";
353 root 1.9 $host =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts
354 root 1.1
355     my $port = $self->{port} or die "HTTP port is not known\n";
356     my $scheme = $self->{url_scheme}
357 root 1.20 || (defined $self->{tls_cert} || defined $self->{tls_key}
358     || ($self->{listen_handle} || $self->{handle} || {})->{tls} ? "https" : "http");
359 root 1.12 my $path = $with_token && $self->{tokens} && @{$self->{tokens}}
360 root 1.6 ? $self->_token_path ($self->{tokens}[0]) : $self->{path};
361 root 1.1
362 root 1.9 "$scheme://" . AnyEvent::Socket::format_hostport ($host, $port) . $path
363 root 1.1 }
364    
365     sub accept {
366     my ($self, $socket, %handle) = @_;
367    
368     delete $self->{_closed};
369     weaken $self;
370    
371     my $handle = AnyEvent::Handle->new (
372 root 1.18 rbuf_max => $self->{max_size} || 8 * 1024 * 1024,
373 root 1.1 %{$self->{handle}},
374     %handle,
375     fh => $socket,
376     on_read => undef,
377     on_error => sub {
378     $self->event (connection_error => $_[0], $_[2]) if $self;
379     $self->_close ($_[0]) if $self;
380     },
381     on_eof => sub { $self->_close ($_[0]) if $self },
382     );
383    
384     $handle->{mcp_peer} = {};
385     $self->{connections}{$handle} = $handle;
386 root 1.20 $handle->push_read (tls_autostart => $self->_tls_context, "accept")
387     if (defined $self->{tls_cert} || defined $self->{tls_key}) && !$handle->{tls};
388    
389 root 1.14 if ($self->{on_extension}) {
390     $handle->rtimeout (15);
391 root 1.20 $handle->on_read (sub {
392     my ($handle) = @_;
393    
394     $handle->on_read (undef);
395 root 1.14 return unless $self;
396    
397 root 1.20 if (substr ($handle->{rbuf}, 0, 1) eq "[") {
398 root 1.14 require AnyEvent::MCP::Extension;
399 root 1.21 AnyEvent::MCP::Extension::accept ($handle, $self->{connect_tokens} || $self->{tokens} || [], sub {
400 root 1.14 my ($handle, $hello) = @_;
401     return $handle->destroy unless $self;
402     delete $self->{connections}{$handle};
403     $self->{on_extension}->($self, $handle, $hello);
404     }, sub { $self->_close ($_[0]) if $self });
405     } else {
406     $handle->rtimeout (0);
407 root 1.20 $self->_read ($handle, 1);
408 root 1.14 }
409     });
410     } else {
411     $self->_read ($handle);
412     }
413 root 1.1
414     $handle
415     }
416    
417 root 1.12 # parse a request line and HTTP fields, using the same comma-combining
418 root 1.10 # approach as AnyEvent::HTTP::_parse_hdr. The caller already bounds headers.
419     sub _parse_request_headers {
420     local $_ = $_[0] . "\r\n";
421     /\A([!#$%&'*+.^_\x60|~0-9A-Za-z-]+) [ ]+
422     ([^\x00-\x20]+) [ ]+ HTTP\/0*([0-9.]+)\r\n/gcix
423     or return;
424     my ($method, $uri, $version) = ($1, $2, $3);
425     return unless $version =~ /\A1\.[0-9]+\z/;
426     my %hdr;
427    
428     $hdr{lc $1} .= ",$2"
429     while /\G
430     ([!\#$%&'*+.^_\x60|~0-9A-Za-z-]+):
431     [\t ]*
432     ([^\x00-\x08\x0a-\x1f\x7f]*)
433     \r\n
434     /gcx;
435    
436     /\G\z/gc or return;
437    
438 root 1.12 # discard the prefix used for comma-combining repeated field values.
439 root 1.10 substr $_, 0, 1, "" for values %hdr;
440     s/[\t ]+\z// for values %hdr;
441    
442 root 1.12 # request-line fields override any colliding HTTP header names.
443 root 1.11 +{ %hdr, method => $method, uri => $uri, http_version => $version }
444 root 1.10 }
445    
446 root 1.1 sub _read {
447 root 1.20 my ($self, $handle, $immediate) = @_;
448 root 1.1
449     weaken $self;
450    
451 root 1.20 if ($immediate) {
452 root 1.19 $handle->push_read (line => "\r\n\r\n", sub {
453     my ($handle, $header) = @_;
454 root 1.12
455 root 1.19 return unless $self;
456 root 1.1
457 root 1.19 my $hdr = _parse_request_headers ($header);
458 root 1.23 $handle->{mcp_method} = $hdr ? substr ($hdr->{method}, 0, 32) : "-";
459 root 1.19 $handle->{mcp_close} = $self->{connection_close}
460     || !$hdr || $hdr->{http_version} =~ m{\A1\.0+\z}
461     || $hdr->{connection} =~ /\bclose\b/i;
462    
463     return $self->_respond ($handle, 400, "Bad Request", "") unless $hdr;
464    
465     $hdr->{"content-length"} = 0 unless defined $hdr->{"content-length"};
466     return $self->_respond ($handle, 400, "Bad Request", "")
467     if exists $hdr->{"transfer-encoding"}
468     || $hdr->{"content-length"} !~ /\A[0-9]+\z/;
469    
470     return $self->_respond ($handle, 413, "Content Too Large", "")
471     if $hdr->{"content-length"} > ($self->{max_size} || 8 * 1024 * 1024);
472    
473     if ($hdr->{expect}) {
474     return $self->_respond ($handle, 417, "Expectation Failed", "")
475     unless lc $hdr->{expect} eq "100-continue";
476 root 1.1
477 root 1.19 $handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
478     }
479 root 1.1
480 root 1.19 $handle->push_read (chunk => $hdr->{"content-length"}, sub {
481     my ($handle, $body) = @_;
482 root 1.1
483 root 1.19 $self->_request ($handle, $hdr, $body) if $self;
484     });
485 root 1.1 });
486 root 1.20 } else {
487     $handle->on_read (sub {
488     my ($handle) = @_;
489     $handle->on_read (undef);
490     $self->_read ($handle, 1) if $self;
491     });
492     }
493 root 1.1 }
494    
495     sub _request {
496 root 1.11 my ($self, $handle, $hdr, $body) = @_;
497 root 1.1
498     delete $handle->{mcp_origin};
499    
500 root 1.15 if (my $hook = $self->{on_http_request}) {
501     weaken $self;
502     my $replied;
503     my $reply = sub {
504     return if $replied++ || !$self || $handle->{mcp_closed};
505     my ($status, $reason, $headers, $content) = @_;
506     $self->_respond ($handle, $status, $reason, $content, $headers);
507     };
508    
509     return if $hook->($self, { %$hdr, body => $body }, $reply);
510     }
511    
512 root 1.22 # some MCP clients strip a trailing slash from the configured URL.
513 root 1.17 my $uri = $hdr->{uri};
514     $uri .= "/" if $self->{path} =~ m{/$} && $uri !~ m{/$};
515 root 1.21 my ($path_token) = $self->{tokens}
516     ? grep $uri eq $self->_token_path ($_), @{$self->{tokens}} : ();
517     my $token_path = defined $path_token;
518 root 1.1
519     return $self->_respond ($handle, 404, "Not Found", "")
520 root 1.17 unless $uri eq $self->{path} || $token_path;
521 root 1.1
522 root 1.11 if (exists $hdr->{origin}) {
523 root 1.1 my $wildcard = grep $_ eq "*", @{$self->{origins}};
524    
525     return $self->_respond ($handle, 403, "Forbidden", "")
526 root 1.11 unless $wildcard || grep $_ eq $hdr->{origin}, @{$self->{origins}};
527 root 1.1
528 root 1.11 $handle->{mcp_origin} = $wildcard ? "*" : $hdr->{origin};
529 root 1.1 }
530    
531 root 1.11 if ($hdr->{method} eq "OPTIONS" && @{$self->{origins}}) {
532 root 1.1 return $self->_respond ($handle, 405, "Method Not Allowed", "")
533 root 1.11 if exists $hdr->{"access-control-request-method"}
534     && $hdr->{"access-control-request-method"} ne "POST";
535 root 1.1
536     return $self->_respond ($handle, 204, "No Content", "");
537     }
538    
539     return $self->_respond ($handle, 405, "Method Not Allowed", "")
540 root 1.11 unless $hdr->{method} eq "POST";
541 root 1.1
542 root 1.21 my $authenticated = $path_token;
543 root 1.6 if ($self->{tokens}) {
544 root 1.11 my $authorization = $hdr->{authorization};
545 root 1.1
546 root 1.6 if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
547     my $token = $1;
548 root 1.21 if (grep $_ eq $token, @{$self->{tokens}}) {
549     return $self->_respond ($handle, 401, "Unauthorized", "")
550     if defined $authenticated && $authenticated ne $token;
551     $authenticated = $token;
552     }
553 root 1.1 }
554    
555     return $self->_respond ($handle, 401, "Unauthorized", "")
556 root 1.21 unless defined $authenticated;
557 root 1.1 }
558    
559     return $self->_respond ($handle, 415, "Unsupported Media Type", "")
560 root 1.11 unless $hdr->{"content-type"} =~ m{\Aapplication/json(?:\s*;|\z)}i;
561 root 1.1
562     my $message = eval { JSON::XS::decode_json $body };
563    
564     if ($@) {
565     return $self->_rpc_error (sub {
566     $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
567     }, undef, -32700, "Parse error");
568     }
569    
570     my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
571     my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
572     my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
573 root 1.11 || $hdr->{"mcp-protocol-version"} ge "2026";
574 root 1.1
575     if ($modern && ref $message eq "HASH" && exists $message->{id}) {
576 root 1.11 my %expected = (
577     "mcp-protocol-version" => $meta->{"io.modelcontextprotocol/protocolVersion"},
578     "mcp-method" => $message->{method},
579 root 1.1 );
580    
581 root 1.11 $expected{"mcp-name"} = exists $params->{name} ? $params->{name} : $params->{uri}
582 root 1.1 if $message->{method} =~ /\A(?:tools\/call|prompts\/get|resources\/read)\z/;
583    
584 root 1.11 for my $name (keys %expected) {
585     my $value = $hdr->{$name};
586 root 1.1
587 root 1.11 if ($name eq "mcp-name" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
588 root 1.2 $value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
589 root 1.1 }
590    
591 root 1.11 unless (defined $value && defined $expected{$name} && $value eq $expected{$name}) {
592 root 1.1 return $self->_rpc_error (sub {
593     $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
594     }, $message->{id}, -32020, "Header mismatch: $name");
595     }
596     }
597     }
598    
599     weaken $self;
600    
601     $self->rpc ($message, sub {
602     my ($response) = @_;
603 root 1.12
604 root 1.1 return unless $self && !$handle->{mcp_closed};
605    
606     my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
607    
608     if ($modern && defined $response && $response->{error}) {
609     ($status, $reason) = $response->{error}{code} == -32601
610     ? (404, "Not Found") : (400, "Bad Request");
611     }
612    
613     $self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
614     },
615 root 1.12 peer => $handle->{mcp_peer},
616 root 1.21 user => defined $authenticated ? $self->{token_users}{$authenticated} : undef,
617 root 1.11 protocol_version => $hdr->{"mcp-protocol-version"} || "2025-03-26",
618 root 1.1 );
619     }
620    
621     sub _respond {
622 root 1.15 my ($self, $handle, $status, $reason, $body, $headers) = @_;
623 root 1.1
624     return if $handle->{mcp_closed};
625    
626 root 1.15 $body = "" unless defined $body;
627     my $content_type = "application/json";
628     my $extra = "";
629    
630     if ($headers) {
631     ref $headers eq "HASH" or die "HTTP response headers must be a hash\n";
632     while (my ($name, $value) = each %$headers) {
633     $name =~ /\A[!#\$%&'*+.^_`|~0-9A-Za-z-]+\z/
634     && defined $value && !ref $value && $value !~ /[\r\n\0]/
635     or die "Invalid HTTP response header\n";
636     $name !~ /\A(?:content-length|connection|transfer-encoding)\z/i
637     or die "HTTP response framing headers are managed by the server\n";
638     if (lc $name eq "content-type") {
639     $content_type = $value;
640     } else {
641     $extra .= "$name: $value\r\n";
642     }
643     }
644     }
645    
646 root 1.23 if ($status >= 400) {
647     AE::log warn => "MCP HTTP id=" . sprintf ("%x", refaddr $handle)
648     . (defined $handle->{mcp_remote} ? " remote=$handle->{mcp_remote}" : "")
649     . ": " . ($handle->{mcp_method} // "-") . " $status";
650     }
651    
652 root 1.12 my $close = $handle->{mcp_close} || $status != 200 && $status != 202;
653    
654 root 1.1 $handle->push_write (
655     "HTTP/1.1 $status $reason\r\n"
656 root 1.15 . "Content-Type: $content_type\r\n"
657     . "Content-Length: " . (length $body) . "\r\n"
658     . $extra
659 root 1.1 . (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
660     . ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
661     . ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
662     . "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
663     . "Access-Control-Max-Age: 86400\r\n" : "")
664     . ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
665 root 1.6 . ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
666 root 1.12 . ($close ? "Connection: close\r\n" : "")
667 root 1.1 . "\r\n$body"
668     );
669    
670 root 1.12 if ($close) {
671 root 1.1 weaken $self;
672     $handle->on_drain (sub { $self->_close ($_[0]) if $self });
673     } else {
674     $self->_read ($handle);
675     }
676     }
677    
678     sub _close {
679     my ($self, $handle) = @_;
680    
681     return if $handle->{mcp_closed};
682     $handle->{mcp_closed} = 1;
683    
684     my $requests = delete $handle->{mcp_peer}{requests} || {};
685     $_->cancel ("Connection closed") for grep defined, values %$requests;
686    
687     delete $self->{connections}{$handle};
688     $handle->destroy;
689     }
690    
691     sub close {
692     my ($self) = @_;
693    
694     return if $self->{_closed}++;
695     delete $self->{listener};
696     $self->_close ($_) for values %{$self->{connections} || {}};
697     $self->event (close =>);
698     }
699    
700     sub DESTROY {
701     $_[0]->close
702     }
703    
704     1