MCP/Server/HTTP.pm

=head1 NAME

AnyEvent::MCP::Server::HTTP - an optional MCP HTTP listener and socket handler

=head1 DESCRIPTION

A subclass of L<AnyEvent::MCP::Server> that handles HTTP POST requests.
It can open its own listener, or you can give it sockets accepted elsewhere.
If your application already parses HTTP, you can pass decoded requests to
L<AnyEvent::MCP::Server> instead of running another HTTP implementation.

Requests sharing one connection are dispatched in sequence, preserving their
HTTP response order; requests on other connections are independent. This
implementation returns JSON and drops notifications. It does not support
SSE or subscriptions.

Request bodies need C<Content-Length>: chunked transfer encoding is not
supported. The server does not assign protocol sessions. Legacy clients
use the 2025 request/response subset.

=head1 METHODS

=head2 $server = AnyEvent::MCP::Server::HTTP->new (%config)

Construction does not start a listener. In addition to Server options,
the following configuration options are supported:

=over

=item host => $host

The listening address, defaulting to C<127.0.0.1>.

=item port => $port

The listening port, defaulting to zero for an automatically assigned port.

=item path => $path

The MCP endpoint path, defaulting to C</mcp/>. Bearer authentication uses
C<$path> directly; URL tokens prefix it with C</TOKEN>.

=item connection_close => $boolean

When true, disables persistent connections, sends C<Connection: close> and
closes the socket after draining each response. Defaults to false.
This is useful when an existing listener routes sockets by their first
request and cannot route subsequent requests independently.

=item max_size => $bytes

Limits incoming headers and request bodies, defaulting to 1 MiB.

=item origins => [$origin...]

Allowed Origin header values. Defaults to C<["*"]>, permitting browser requests
from any origin. An empty array rejects requests with an Origin header, while
requests without one are accepted. Allowed origins receive CORS response headers,
and nonempty origin lists enable OPTIONS preflight for POST. Preflight does not
require authentication; the subsequent POST still does.

=item handle => { %handle }

AnyEvent::Handle constructor options, such as C<tls>, C<tls_ctx>, C<timeout>
or C<on_starttls>. The socket and the read/error/EOF handlers belong to this
class.

=item tokens => [$token, ...]

Ordered tokens accepted either as C</TOKEN> before the configured
C<path> or in an C<Authorization: Bearer TOKEN> header. The first token
is used in advertised URLs. Token strings must be URL-safe.

=item name => $name

Identifies the service. Use L<AnyEvent::MCP::Config/http_settings>
to resolve named listener configuration before constructing this transport.

=item url_host => $hostname

Overrides the advertised hostname, for example when listening on a wildcard
address. Otherwise a wildcard uses the nodename from C<uname>.

=item url_scheme => $scheme

Overrides the advertised scheme; otherwise TLS handle options select
C<https>, and plain handles select C<http>.

=back

Every configured token authenticates in either the URL or the Authorization
header. If C<tokens> is omitted, an embedding application must supply
its own authentication.

=head2 $url = $server->url ($with_token)

Returns the advertised URL with the actual listening port. C<$with_token>
defaults to true, including the first configured token. Pass false for
the clean URL to use with an Authorization bearer token.

The port must be known. Wildcard hostname resolution and reverse-proxy
routing remain the caller's responsibility.

=head2 $server->listen ($host, $port, %handle)

Starts a listener, replacing any previous listener. Omitted arguments use
the configured host and port. The actual bound port is stored in
C<< $server->{port} >>, including when requesting an ephemeral port.

C<%handle> overrides the configured C<handle> options for connections
accepted by this listener.

=head2 $handle = $server->accept ($socket, %handle)

Starts handling an already accepted socket. The server takes ownership of
C<$socket>. No listener is needed.

C<%handle> overrides the configured C<handle> options for this connection.

=head2 $server->close

Stops listening, closes accepted sockets and cancels outstanding requests.
The same object can subsequently listen or accept again.

=head1 EVENTS

=head2 on_connection_error => $callback->($server, $handle, $message)

Called for socket errors before closing the connection.

=head2 on_close => $callback->($server)

Called once after C<close> stops the listener and closes all connections.
Calling C<listen> or C<accept> again starts a new lifetime.

=cut

package AnyEvent::MCP::Server::HTTP;

use common::sense;
use parent "AnyEvent::MCP::Server";
use AnyEvent::Handle ();
use AnyEvent::Socket ();
use HTTP::Parser::XS ();
use JSON::XS ();
use Scalar::Util qw(weaken);
use POSIX ();

sub new {
   my ($class, %kv) = @_;
   !grep (exists $kv{$_}, qw(cookie bearer users))
      or die "Legacy HTTP authentication options are unsupported; use tokens\n";

   if (exists $kv{tokens}) {
      ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
         or die "HTTP server requires nonempty tokens\n";
      /\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
         for @{$kv{tokens}};
   }

   $class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
}

sub listen {
   my ($self, $host, $port, %handle) = @_;

   delete $self->{_closed};
   $host = $self->{host} unless defined $host;
   $port = $self->{port} unless defined $port;

   $self->{listen_host} = $host;
   $self->{listen_handle} = { %{$self->{handle} || {}}, %handle };

   delete $self->{listener};
   weaken $self;

   $self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
      $self->accept ($_[0], %handle) if $self;
   }, sub {
      $self->{port} = $_[2] if $self;
      ()
   };
}

sub _token_path {
   my ($self, $token) = @_;
   "/$token$self->{path}"
}

sub url {
   my ($self, $with_cookie) = @_;

   $with_cookie = 1 unless defined $with_cookie;

   my $host = $self->{url_host}
      || (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
   $host = (POSIX::uname)[1] if !length $host || $host eq "0.0.0.0" || $host eq "::";
   $host = "[$host]" if $host =~ /:/ && $host !~ /\A\[/;

   my $port = $self->{port} or die "HTTP port is not known\n";
   my $scheme = $self->{url_scheme}
      || (($self->{listen_handle} || $self->{handle} || {})->{tls} ? "https" : "http");
   my $path = $with_cookie && $self->{tokens} && @{$self->{tokens}}
      ? $self->_token_path ($self->{tokens}[0]) : $self->{path};

   "$scheme://$host:$port$path"
}

sub accept {
   my ($self, $socket, %handle) = @_;

   delete $self->{_closed};
   weaken $self;

   my $handle = AnyEvent::Handle->new (
      rbuf_max => $self->{max_size} || 1024 * 1024,
      %{$self->{handle}},
      %handle,
      fh       => $socket,
      on_read  => undef,
      on_error => sub {
         $self->event (connection_error => $_[0], $_[2]) if $self;
         $self->_close ($_[0]) if $self;
      },
      on_eof => sub { $self->_close ($_[0]) if $self },
   );

   $handle->{mcp_peer} = {};
   $self->{connections}{$handle} = $handle;
   $self->_read ($handle);

   $handle
}

sub _read {
   my ($self, $handle) = @_;

   weaken $self;

   $handle->push_read (line => "\r\n\r\n", sub {
      my ($handle, $header) = @_;
      return unless $self;

      my $parsed = HTTP::Parser::XS::parse_http_request ($header . "\r\n\r\n", \my %env);
      $handle->{mcp_close} = $self->{connection_close}
         || $env{SERVER_PROTOCOL} ne "HTTP/1.1"
         || $env{HTTP_CONNECTION} =~ /\bclose\b/i;

      $env{CONTENT_LENGTH} = 0 unless defined $env{CONTENT_LENGTH};

      return $self->_respond ($handle, 400, "Bad Request", "")
         if $parsed < 0 || exists $env{HTTP_TRANSFER_ENCODING}
            || $env{CONTENT_LENGTH} !~ /\A[0-9]+\z/;

      return $self->_respond ($handle, 413, "Content Too Large", "")
         if $env{CONTENT_LENGTH} > ($self->{max_size} || 1024 * 1024);

      if ($env{HTTP_EXPECT}) {
         return $self->_respond ($handle, 417, "Expectation Failed", "")
            unless lc $env{HTTP_EXPECT} eq "100-continue";

         $handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
      }

      $handle->push_read (chunk => $env{CONTENT_LENGTH}, sub {
         my ($handle, $body) = @_;

         $self->_request ($handle, \%env, $body) if $self;
      });
   });
}

sub _request {
   my ($self, $handle, $env, $body) = @_;

   delete $handle->{mcp_origin};

   my $token_path = $self->{tokens}
      && grep $env->{REQUEST_URI} eq $self->_token_path ($_), @{$self->{tokens}};

   return $self->_respond ($handle, 404, "Not Found", "")
      unless $env->{REQUEST_URI} eq $self->{path} || $token_path;

   if (exists $env->{HTTP_ORIGIN}) {
      my $wildcard = grep $_ eq "*", @{$self->{origins}};

      return $self->_respond ($handle, 403, "Forbidden", "")
         unless $wildcard || grep $_ eq $env->{HTTP_ORIGIN}, @{$self->{origins}};

      $handle->{mcp_origin} = $wildcard ? "*" : $env->{HTTP_ORIGIN};
   }

   if ($env->{REQUEST_METHOD} eq "OPTIONS" && @{$self->{origins}}) {
      return $self->_respond ($handle, 405, "Method Not Allowed", "")
         if exists $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD}
            && $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD} ne "POST";

      return $self->_respond ($handle, 204, "No Content", "");
   }

   return $self->_respond ($handle, 405, "Method Not Allowed", "")
      unless $env->{REQUEST_METHOD} eq "POST";

   if ($self->{tokens}) {
      my $authenticated = $token_path;
      my $authorization = $env->{HTTP_AUTHORIZATION};

      if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
         my $token = $1;
         $authenticated ||= grep $_ eq $token, @{$self->{tokens}};
      }

      return $self->_respond ($handle, 401, "Unauthorized", "")
         unless $authenticated;
   }

   return $self->_respond ($handle, 415, "Unsupported Media Type", "")
      unless $env->{CONTENT_TYPE} =~ m{\Aapplication/json(?:\s*;|\z)}i;

   my $message = eval { JSON::XS::decode_json $body };

   if ($@) {
      return $self->_rpc_error (sub {
         $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
      }, undef, -32700, "Parse error");
   }

   my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
   my $meta   = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
   my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
      || $env->{HTTP_MCP_PROTOCOL_VERSION} ge "2026";

   if ($modern && ref $message eq "HASH" && exists $message->{id}) {
      my %headers = (
         HTTP_MCP_PROTOCOL_VERSION => $meta->{"io.modelcontextprotocol/protocolVersion"},
         HTTP_MCP_METHOD           => $message->{method},
      );

      $headers{HTTP_MCP_NAME} = exists $params->{name} ? $params->{name} : $params->{uri}
         if $message->{method} =~ /\A(?:tools\/call|prompts\/get|resources\/read)\z/;

      for my $name (keys %headers) {
         my $value = $env->{$name};

         if ($name eq "HTTP_MCP_NAME" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
            $value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
         }

         unless (defined $value && defined $headers{$name} && $value eq $headers{$name}) {
            return $self->_rpc_error (sub {
               $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
            }, $message->{id}, -32020, "Header mismatch: $name");
         }
      }
   }

   weaken $self;

   $self->rpc ($message, sub {
      my ($response) = @_;
      return unless $self && !$handle->{mcp_closed};

      my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");

      if ($modern && defined $response && $response->{error}) {
         ($status, $reason) = $response->{error}{code} == -32601
            ? (404, "Not Found") : (400, "Bad Request");
      }

      $self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
   },
      peer            => $handle->{mcp_peer},
      protocol_version => $env->{HTTP_MCP_PROTOCOL_VERSION} || "2025-03-26",
   );
}

sub _respond {
   my ($self, $handle, $status, $reason, $body) = @_;

   return if $handle->{mcp_closed};

   $handle->push_write (
      "HTTP/1.1 $status $reason\r\n"
      . "Content-Type: application/json\r\n"
      . "Content-Length: " . length ($body) . "\r\n"
      . (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
         . ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
      . ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
         . "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
         . "Access-Control-Max-Age: 86400\r\n" : "")
      . ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
      . ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
      . ($handle->{mcp_close} || $status != 200 && $status != 202 ? "Connection: close\r\n" : "")
      . "\r\n$body"
   );

   if ($handle->{mcp_close} || $status != 200 && $status != 202) {
      weaken $self;
      $handle->on_drain (sub { $self->_close ($_[0]) if $self });
   } else {
      $self->_read ($handle);
   }
}

sub _close {
   my ($self, $handle) = @_;

   return if $handle->{mcp_closed};
   $handle->{mcp_closed} = 1;

   my $requests = delete $handle->{mcp_peer}{requests} || {};
   $_->cancel ("Connection closed") for grep defined, values %$requests;

   delete $self->{connections}{$handle};
   $handle->destroy;
}

sub close {
   my ($self) = @_;

   return if $self->{_closed}++;
   delete $self->{listener};
   $self->_close ($_) for values %{$self->{connections} || {}};
   $self->event (close =>);
}

sub DESTROY {
   $_[0]->close
}

1
Revision:	1.6
Committed:	Sun Oct 11 00:53:55 2026 UTC (3 weeks, 5 days ago) by root
Branch:	MAIN
Changes since 1.5:	+38 -61 lines
Log Message:	* empty log message *
#	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			=head1 METHODS
22
23			=head2 $server = AnyEvent::MCP::Server::HTTP->new (%config)
24
25			Construction does not start a listener. In addition to Server options,
26			the following configuration options are supported:
27
28	root	1.3	=over
29	root	1.1
30			=item host => $host
31
32			The listening address, defaulting to C<127.0.0.1>.
33
34			=item port => $port
35
36			The listening port, defaulting to zero for an automatically assigned port.
37
38			=item path => $path
39
40	root	1.6	The MCP endpoint path, defaulting to C</mcp/>. Bearer authentication uses
41			C<$path> directly; URL tokens prefix it with C</TOKEN>.
42	root	1.1
43			=item connection_close => $boolean
44
45			When true, disables persistent connections, sends C<Connection: close> and
46			closes the socket after draining each response. Defaults to false.
47			This is useful when an existing listener routes sockets by their first
48			request and cannot route subsequent requests independently.
49
50			=item max_size => $bytes
51
52			Limits incoming headers and request bodies, defaulting to 1 MiB.
53
54			=item origins => [$origin...]
55
56	root	1.4	Allowed Origin header values. Defaults to C<["*"]>, permitting browser requests
57			from any origin. An empty array rejects requests with an Origin header, while
58			requests without one are accepted. Allowed origins receive CORS response headers,
59			and nonempty origin lists enable OPTIONS preflight for POST. Preflight does not
60	root	1.1	require authentication; the subsequent POST still does.
61
62			=item handle => { %handle }
63
64			AnyEvent::Handle constructor options, such as C<tls>, C<tls_ctx>, C<timeout>
65			or C<on_starttls>. The socket and the read/error/EOF handlers belong to this
66			class.
67
68	root	1.6	=item tokens => [$token, ...]
69	root	1.1
70	root	1.6	Ordered tokens accepted either as C</TOKEN> before the configured
71			C<path> or in an C<Authorization: Bearer TOKEN> header. The first token
72			is used in advertised URLs. Token strings must be URL-safe.
73	root	1.1
74			=item name => $name
75
76	root	1.6	Identifies the service. Use L<AnyEvent::MCP::Config/http_settings>
77			to resolve named listener configuration before constructing this transport.
78	root	1.1
79			=item url_host => $hostname
80
81			Overrides the advertised hostname, for example when listening on a wildcard
82			address. Otherwise a wildcard uses the nodename from C<uname>.
83
84			=item url_scheme => $scheme
85
86			Overrides the advertised scheme; otherwise TLS handle options select
87			C<https>, and plain handles select C<http>.
88
89			=back
90
91	root	1.6	Every configured token authenticates in either the URL or the Authorization
92			header. If C<tokens> is omitted, an embedding application must supply
93			its own authentication.
94
95			=head2 $url = $server->url ($with_token)
96
97			Returns the advertised URL with the actual listening port. C<$with_token>
98			defaults to true, including the first configured token. Pass false for
99			the clean URL to use with an Authorization bearer token.
100	root	1.1
101			The port must be known. Wildcard hostname resolution and reverse-proxy
102			routing remain the caller's responsibility.
103
104			=head2 $server->listen ($host, $port, %handle)
105
106			Starts a listener, replacing any previous listener. Omitted arguments use
107			the configured host and port. The actual bound port is stored in
108			C<< $server->{port} >>, including when requesting an ephemeral port.
109
110			C<%handle> overrides the configured C<handle> options for connections
111			accepted by this listener.
112
113			=head2 $handle = $server->accept ($socket, %handle)
114
115			Starts handling an already accepted socket. The server takes ownership of
116			C<$socket>. No listener is needed.
117
118			C<%handle> overrides the configured C<handle> options for this connection.
119
120			=head2 $server->close
121
122			Stops listening, closes accepted sockets and cancels outstanding requests.
123			The same object can subsequently listen or accept again.
124
125			=head1 EVENTS
126
127			=head2 on_connection_error => $callback->($server, $handle, $message)
128
129			Called for socket errors before closing the connection.
130
131			=head2 on_close => $callback->($server)
132
133			Called once after C<close> stops the listener and closes all connections.
134			Calling C<listen> or C<accept> again starts a new lifetime.
135
136			=cut
137
138			package AnyEvent::MCP::Server::HTTP;
139
140			use common::sense;
141			use parent "AnyEvent::MCP::Server";
142			use AnyEvent::Handle ();
143			use AnyEvent::Socket ();
144			use HTTP::Parser::XS ();
145			use JSON::XS ();
146			use Scalar::Util qw(weaken);
147			use POSIX ();
148
149			sub new {
150			my ($class, %kv) = @_;
151	root	1.6	!grep (exists $kv{$_}, qw(cookie bearer users))
152			or die "Legacy HTTP authentication options are unsupported; use tokens\n";
153	root	1.1
154	root	1.6	if (exists $kv{tokens}) {
155			ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
156			or die "HTTP server requires nonempty tokens\n";
157			/\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
158			for @{$kv{tokens}};
159	root	1.1	}
160
161	root	1.4	$class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
162	root	1.1	}
163
164			sub listen {
165			my ($self, $host, $port, %handle) = @_;
166
167			delete $self->{_closed};
168			$host = $self->{host} unless defined $host;
169			$port = $self->{port} unless defined $port;
170
171			$self->{listen_host} = $host;
172			$self->{listen_handle} = { %{$self->{handle} \|\| {}}, %handle };
173
174			delete $self->{listener};
175			weaken $self;
176
177			$self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
178			$self->accept ($_[0], %handle) if $self;
179			}, sub {
180			$self->{port} = $_[2] if $self;
181			()
182			};
183			}
184
185	root	1.6	sub _token_path {
186			my ($self, $token) = @_;
187			"/$token$self->{path}"
188	root	1.1	}
189
190			sub url {
191			my ($self, $with_cookie) = @_;
192
193			$with_cookie = 1 unless defined $with_cookie;
194
195			my $host = $self->{url_host}
196			\|\| (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
197			$host = (POSIX::uname)[1] if !length $host \|\| $host eq "0.0.0.0" \|\| $host eq "::";
198			$host = "[$host]" if $host =~ /:/ && $host !~ /\A\[/;
199
200			my $port = $self->{port} or die "HTTP port is not known\n";
201			my $scheme = $self->{url_scheme}
202			\|\| (($self->{listen_handle} \|\| $self->{handle} \|\| {})->{tls} ? "https" : "http");
203	root	1.6	my $path = $with_cookie && $self->{tokens} && @{$self->{tokens}}
204			? $self->_token_path ($self->{tokens}[0]) : $self->{path};
205	root	1.1
206			"$scheme://$host:$port$path"
207			}
208
209			sub accept {
210			my ($self, $socket, %handle) = @_;
211
212			delete $self->{_closed};
213			weaken $self;
214
215			my $handle = AnyEvent::Handle->new (
216			rbuf_max => $self->{max_size} \|\| 1024 * 1024,
217			%{$self->{handle}},
218			%handle,
219			fh => $socket,
220			on_read => undef,
221			on_error => sub {
222			$self->event (connection_error => $_[0], $_[2]) if $self;
223			$self->_close ($_[0]) if $self;
224			},
225			on_eof => sub { $self->_close ($_[0]) if $self },
226			);
227
228			$handle->{mcp_peer} = {};
229			$self->{connections}{$handle} = $handle;
230			$self->_read ($handle);
231
232			$handle
233			}
234
235			sub _read {
236			my ($self, $handle) = @_;
237
238			weaken $self;
239
240			$handle->push_read (line => "\r\n\r\n", sub {
241			my ($handle, $header) = @_;
242			return unless $self;
243
244			my $parsed = HTTP::Parser::XS::parse_http_request ($header . "\r\n\r\n", \my %env);
245			$handle->{mcp_close} = $self->{connection_close}
246			\|\| $env{SERVER_PROTOCOL} ne "HTTP/1.1"
247			\|\| $env{HTTP_CONNECTION} =~ /\bclose\b/i;
248
249			$env{CONTENT_LENGTH} = 0 unless defined $env{CONTENT_LENGTH};
250
251			return $self->_respond ($handle, 400, "Bad Request", "")
252			if $parsed < 0 \|\| exists $env{HTTP_TRANSFER_ENCODING}
253			\|\| $env{CONTENT_LENGTH} !~ /\A[0-9]+\z/;
254
255			return $self->_respond ($handle, 413, "Content Too Large", "")
256			if $env{CONTENT_LENGTH} > ($self->{max_size} \|\| 1024 * 1024);
257
258			if ($env{HTTP_EXPECT}) {
259			return $self->_respond ($handle, 417, "Expectation Failed", "")
260			unless lc $env{HTTP_EXPECT} eq "100-continue";
261
262			$handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
263			}
264
265			$handle->push_read (chunk => $env{CONTENT_LENGTH}, sub {
266			my ($handle, $body) = @_;
267
268			$self->_request ($handle, \%env, $body) if $self;
269			});
270			});
271			}
272
273			sub _request {
274			my ($self, $handle, $env, $body) = @_;
275
276			delete $handle->{mcp_origin};
277
278	root	1.6	my $token_path = $self->{tokens}
279			&& grep $env->{REQUEST_URI} eq $self->_token_path ($_), @{$self->{tokens}};
280	root	1.1
281			return $self->_respond ($handle, 404, "Not Found", "")
282	root	1.6	unless $env->{REQUEST_URI} eq $self->{path} \|\| $token_path;
283	root	1.1
284			if (exists $env->{HTTP_ORIGIN}) {
285			my $wildcard = grep $_ eq "*", @{$self->{origins}};
286
287			return $self->_respond ($handle, 403, "Forbidden", "")
288			unless $wildcard \|\| grep $_ eq $env->{HTTP_ORIGIN}, @{$self->{origins}};
289
290			$handle->{mcp_origin} = $wildcard ? "*" : $env->{HTTP_ORIGIN};
291			}
292
293			if ($env->{REQUEST_METHOD} eq "OPTIONS" && @{$self->{origins}}) {
294			return $self->_respond ($handle, 405, "Method Not Allowed", "")
295			if exists $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD}
296			&& $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD} ne "POST";
297
298			return $self->_respond ($handle, 204, "No Content", "");
299			}
300
301			return $self->_respond ($handle, 405, "Method Not Allowed", "")
302			unless $env->{REQUEST_METHOD} eq "POST";
303
304	root	1.6	if ($self->{tokens}) {
305			my $authenticated = $token_path;
306	root	1.1	my $authorization = $env->{HTTP_AUTHORIZATION};
307
308	root	1.6	if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
309			my $token = $1;
310			$authenticated \|\|= grep $_ eq $token, @{$self->{tokens}};
311	root	1.1	}
312
313			return $self->_respond ($handle, 401, "Unauthorized", "")
314			unless $authenticated;
315			}
316
317			return $self->_respond ($handle, 415, "Unsupported Media Type", "")
318			unless $env->{CONTENT_TYPE} =~ m{\Aapplication/json(?:\s*;\|\z)}i;
319
320			my $message = eval { JSON::XS::decode_json $body };
321
322			if ($@) {
323			return $self->_rpc_error (sub {
324			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
325			}, undef, -32700, "Parse error");
326			}
327
328			my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
329			my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
330			my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
331			\|\| $env->{HTTP_MCP_PROTOCOL_VERSION} ge "2026";
332
333			if ($modern && ref $message eq "HASH" && exists $message->{id}) {
334			my %headers = (
335			HTTP_MCP_PROTOCOL_VERSION => $meta->{"io.modelcontextprotocol/protocolVersion"},
336			HTTP_MCP_METHOD => $message->{method},
337			);
338
339			$headers{HTTP_MCP_NAME} = exists $params->{name} ? $params->{name} : $params->{uri}
340			if $message->{method} =~ /\A(?:tools\/call\|prompts\/get\|resources\/read)\z/;
341
342			for my $name (keys %headers) {
343			my $value = $env->{$name};
344
345			if ($name eq "HTTP_MCP_NAME" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
346	root	1.2	$value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
347	root	1.1	}
348
349			unless (defined $value && defined $headers{$name} && $value eq $headers{$name}) {
350			return $self->_rpc_error (sub {
351			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
352			}, $message->{id}, -32020, "Header mismatch: $name");
353			}
354			}
355			}
356
357			weaken $self;
358
359			$self->rpc ($message, sub {
360			my ($response) = @_;
361			return unless $self && !$handle->{mcp_closed};
362
363			my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
364
365			if ($modern && defined $response && $response->{error}) {
366			($status, $reason) = $response->{error}{code} == -32601
367			? (404, "Not Found") : (400, "Bad Request");
368			}
369
370			$self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
371			},
372			peer => $handle->{mcp_peer},
373			protocol_version => $env->{HTTP_MCP_PROTOCOL_VERSION} \|\| "2025-03-26",
374			);
375			}
376
377			sub _respond {
378			my ($self, $handle, $status, $reason, $body) = @_;
379
380			return if $handle->{mcp_closed};
381
382			$handle->push_write (
383			"HTTP/1.1 $status $reason\r\n"
384			. "Content-Type: application/json\r\n"
385			. "Content-Length: " . length ($body) . "\r\n"
386			. (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
387			. ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
388			. ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
389			. "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
390			. "Access-Control-Max-Age: 86400\r\n" : "")
391			. ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
392	root	1.6	. ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
393	root	1.1	. ($handle->{mcp_close} \|\| $status != 200 && $status != 202 ? "Connection: close\r\n" : "")
394			. "\r\n$body"
395			);
396
397			if ($handle->{mcp_close} \|\| $status != 200 && $status != 202) {
398			weaken $self;
399			$handle->on_drain (sub { $self->_close ($_[0]) if $self });
400			} else {
401			$self->_read ($handle);
402			}
403			}
404
405			sub _close {
406			my ($self, $handle) = @_;
407
408			return if $handle->{mcp_closed};
409			$handle->{mcp_closed} = 1;
410
411			my $requests = delete $handle->{mcp_peer}{requests} \|\| {};
412			$_->cancel ("Connection closed") for grep defined, values %$requests;
413
414			delete $self->{connections}{$handle};
415			$handle->destroy;
416			}
417
418			sub close {
419			my ($self) = @_;
420
421			return if $self->{_closed}++;
422			delete $self->{listener};
423			$self->_close ($_) for values %{$self->{connections} \|\| {}};
424			$self->event (close =>);
425			}
426
427			sub DESTROY {
428			$_[0]->close
429			}
430
431			1