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

File Contents

# Content
1 =head1 NAME
2
3 AnyEvent::MCP::Server::HTTP - an optional MCP HTTP listener and socket handler
4
5 =head1 DESCRIPTION
6
7 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
21 C<Mcp-Param-*> headers from C<x-mcp-header> tool schema annotations are not
22 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
27 =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 =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 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
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 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 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 =head1 METHODS
90
91 =over
92
93 =item $server = AnyEvent::MCP::Server::HTTP->new (%config)
94
95 Construction does not start a listener. In addition to Server options,
96 the following configuration options are supported:
97
98 =over
99
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 The MCP endpoint path, defaulting to C</mcp/>. Bearer authentication uses
111 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
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 Limits incoming headers and request bodies, defaulting to 8 MiB.
125
126 =item origins => [$origin...]
127
128 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 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 =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 =item tokens => [$token, ...]
154
155 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 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
166 =item name => $name
167
168 Identifies the service. Use L<AnyEvent::MCP::Config/http_settings>
169 to resolve named listener configuration before constructing this transport.
170
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 Overrides the advertised scheme; otherwise TLS credentials or handle options
179 select C<https>, and plain handles select C<http>.
180
181 =back
182
183 Every configured token authenticates in either the URL or the Authorization
184 header. Without tokens, the constructor requires C<auth =E<gt> "none">.
185
186 =item $url = $server->url ($with_token)
187
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
192 The port must be known. Wildcard hostname resolution and reverse-proxy
193 routing remain the caller's responsibility.
194
195 =item $server->listen ($host, $port, %handle)
196
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 =item $handle = $server->accept ($socket, %handle)
205
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 =item $server->close
212
213 Stops listening, closes accepted sockets and cancels outstanding requests.
214 The same object can subsequently listen or accept again.
215
216 =back
217
218 =head1 EVENTS
219
220 =over
221
222 =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 =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 =item on_connection_error => $callback->($server, $handle, $message)
255
256 Called for socket errors before closing the connection.
257
258 =item on_close => $callback->($server)
259
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 =back
264
265 =cut
266
267 package AnyEvent::MCP::Server::HTTP;
268
269 use common::sense;
270 use parent "AnyEvent::MCP::Server";
271 use AnyEvent::Log ();
272 use AnyEvent::Handle ();
273 use AnyEvent::Socket ();
274 use JSON::XS ();
275 use Scalar::Util qw(refaddr weaken);
276 use POSIX ();
277
278 sub new {
279 my ($class, %kv) = @_;
280
281 !grep (exists $kv{$_}, qw(cookie bearer users))
282 or die "Legacy HTTP authentication options are unsupported; use tokens\n";
283
284 $kv{auth} //= "tokens";
285 if ($kv{auth} eq "tokens") {
286 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 } 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 }
296
297 $class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
298 }
299
300 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 sub listen {
315 my ($self, $host, $port, %handle) = @_;
316
317 $self->_tls_context;
318 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 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 }, sub {
334 $self->{port} = $_[2] if $self;
335 ()
336 };
337 }
338
339 sub _token_path {
340 my ($self, $token) = @_;
341
342 "/$token$self->{path}"
343 }
344
345 sub url {
346 my ($self, $with_token) = @_;
347
348 $with_token = 1 unless defined $with_token;
349
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 $host =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts
354
355 my $port = $self->{port} or die "HTTP port is not known\n";
356 my $scheme = $self->{url_scheme}
357 || (defined $self->{tls_cert} || defined $self->{tls_key}
358 || ($self->{listen_handle} || $self->{handle} || {})->{tls} ? "https" : "http");
359 my $path = $with_token && $self->{tokens} && @{$self->{tokens}}
360 ? $self->_token_path ($self->{tokens}[0]) : $self->{path};
361
362 "$scheme://" . AnyEvent::Socket::format_hostport ($host, $port) . $path
363 }
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 rbuf_max => $self->{max_size} || 8 * 1024 * 1024,
373 %{$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 $handle->push_read (tls_autostart => $self->_tls_context, "accept")
387 if (defined $self->{tls_cert} || defined $self->{tls_key}) && !$handle->{tls};
388
389 if ($self->{on_extension}) {
390 $handle->rtimeout (15);
391 $handle->on_read (sub {
392 my ($handle) = @_;
393
394 $handle->on_read (undef);
395 return unless $self;
396
397 if (substr ($handle->{rbuf}, 0, 1) eq "[") {
398 require AnyEvent::MCP::Extension;
399 AnyEvent::MCP::Extension::accept ($handle, $self->{connect_tokens} || $self->{tokens} || [], sub {
400 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 $self->_read ($handle, 1);
408 }
409 });
410 } else {
411 $self->_read ($handle);
412 }
413
414 $handle
415 }
416
417 # parse a request line and HTTP fields, using the same comma-combining
418 # 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 # discard the prefix used for comma-combining repeated field values.
439 substr $_, 0, 1, "" for values %hdr;
440 s/[\t ]+\z// for values %hdr;
441
442 # request-line fields override any colliding HTTP header names.
443 +{ %hdr, method => $method, uri => $uri, http_version => $version }
444 }
445
446 sub _read {
447 my ($self, $handle, $immediate) = @_;
448
449 weaken $self;
450
451 if ($immediate) {
452 $handle->push_read (line => "\r\n\r\n", sub {
453 my ($handle, $header) = @_;
454
455 return unless $self;
456
457 my $hdr = _parse_request_headers ($header);
458 $handle->{mcp_method} = $hdr ? substr ($hdr->{method}, 0, 32) : "-";
459 $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
477 $handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
478 }
479
480 $handle->push_read (chunk => $hdr->{"content-length"}, sub {
481 my ($handle, $body) = @_;
482
483 $self->_request ($handle, $hdr, $body) if $self;
484 });
485 });
486 } else {
487 $handle->on_read (sub {
488 my ($handle) = @_;
489 $handle->on_read (undef);
490 $self->_read ($handle, 1) if $self;
491 });
492 }
493 }
494
495 sub _request {
496 my ($self, $handle, $hdr, $body) = @_;
497
498 delete $handle->{mcp_origin};
499
500 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 # some MCP clients strip a trailing slash from the configured URL.
513 my $uri = $hdr->{uri};
514 $uri .= "/" if $self->{path} =~ m{/$} && $uri !~ m{/$};
515 my ($path_token) = $self->{tokens}
516 ? grep $uri eq $self->_token_path ($_), @{$self->{tokens}} : ();
517 my $token_path = defined $path_token;
518
519 return $self->_respond ($handle, 404, "Not Found", "")
520 unless $uri eq $self->{path} || $token_path;
521
522 if (exists $hdr->{origin}) {
523 my $wildcard = grep $_ eq "*", @{$self->{origins}};
524
525 return $self->_respond ($handle, 403, "Forbidden", "")
526 unless $wildcard || grep $_ eq $hdr->{origin}, @{$self->{origins}};
527
528 $handle->{mcp_origin} = $wildcard ? "*" : $hdr->{origin};
529 }
530
531 if ($hdr->{method} eq "OPTIONS" && @{$self->{origins}}) {
532 return $self->_respond ($handle, 405, "Method Not Allowed", "")
533 if exists $hdr->{"access-control-request-method"}
534 && $hdr->{"access-control-request-method"} ne "POST";
535
536 return $self->_respond ($handle, 204, "No Content", "");
537 }
538
539 return $self->_respond ($handle, 405, "Method Not Allowed", "")
540 unless $hdr->{method} eq "POST";
541
542 my $authenticated = $path_token;
543 if ($self->{tokens}) {
544 my $authorization = $hdr->{authorization};
545
546 if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
547 my $token = $1;
548 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 }
554
555 return $self->_respond ($handle, 401, "Unauthorized", "")
556 unless defined $authenticated;
557 }
558
559 return $self->_respond ($handle, 415, "Unsupported Media Type", "")
560 unless $hdr->{"content-type"} =~ m{\Aapplication/json(?:\s*;|\z)}i;
561
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 || $hdr->{"mcp-protocol-version"} ge "2026";
574
575 if ($modern && ref $message eq "HASH" && exists $message->{id}) {
576 my %expected = (
577 "mcp-protocol-version" => $meta->{"io.modelcontextprotocol/protocolVersion"},
578 "mcp-method" => $message->{method},
579 );
580
581 $expected{"mcp-name"} = exists $params->{name} ? $params->{name} : $params->{uri}
582 if $message->{method} =~ /\A(?:tools\/call|prompts\/get|resources\/read)\z/;
583
584 for my $name (keys %expected) {
585 my $value = $hdr->{$name};
586
587 if ($name eq "mcp-name" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
588 $value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
589 }
590
591 unless (defined $value && defined $expected{$name} && $value eq $expected{$name}) {
592 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
604 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 peer => $handle->{mcp_peer},
616 user => defined $authenticated ? $self->{token_users}{$authenticated} : undef,
617 protocol_version => $hdr->{"mcp-protocol-version"} || "2025-03-26",
618 );
619 }
620
621 sub _respond {
622 my ($self, $handle, $status, $reason, $body, $headers) = @_;
623
624 return if $handle->{mcp_closed};
625
626 $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 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 my $close = $handle->{mcp_close} || $status != 200 && $status != 202;
653
654 $handle->push_write (
655 "HTTP/1.1 $status $reason\r\n"
656 . "Content-Type: $content_type\r\n"
657 . "Content-Length: " . (length $body) . "\r\n"
658 . $extra
659 . (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 . ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
666 . ($close ? "Connection: close\r\n" : "")
667 . "\r\n$body"
668 );
669
670 if ($close) {
671 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