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 and Basic authentication
use C<$path> directly; URL cookies prefix it with C</COOKIE>.

=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 cookie => $token

Authenticates requests using C</TOKEN> followed by the configured C<path>.
Cookie credentials are URL path components, not HTTP cookies.

=item bearer => $token

Authenticates requests using an C<Authorization: Bearer TOKEN> header.

=item users => { $username => $password, ... }

Basic authentication users and passwords. An empty hash permits no Basic users.

C<users> can alternatively be an array of allowed usernames, or a
comma-separated configuration string. Their Basic passwords are derived
from the global secret and C<name>, which is required for this form.
C<anyevent-mcp password NAME USER> prints the matching password.

=item name => $name

Identifies the service when deriving Basic passwords from a user list.
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

Any configured authentication method can authenticate the request. Omitting
C<cookie>, C<bearer> and C<users> leaves authentication to the embedding
application. Explicitly undefined options disable that method. Cookie URLs
are also accepted when using bearer or Basic authentication.

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

Returns the advertised URL with the actual listening port. C<$with_cookie>
defaults to true, including the URL cookie when configured. Pass false for
the clean URL to use with a bearer token or Basic authentication.

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 MIME::Base64 ();
use Scalar::Util qw(weaken);
use POSIX ();

sub new {
   my ($class, %kv) = @_;

   if (defined $kv{users} && ref $kv{users} ne "HASH") {
      die "Derived Basic users require a server name\n" unless defined $kv{name};
      require AnyEvent::MCP::Config;
      my $config = AnyEvent::MCP::Config->global;
      my @users = ref $kv{users} eq "ARRAY" ? @{$kv{users}} : split /\s*,\s*/, $kv{users};
      $kv{users} = { map { $_ => $config->credential ("basic", $kv{name}, $_) } @users };
   }

   $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 _cookie_path {
   my ($self) = @_;

   my $cookie = AnyEvent::MCP::utf8enc $self->{cookie};
   $cookie =~ s/([^A-Za-z0-9_.~-])/sprintf "%%%02X", ord $1/ge;

   "/$cookie$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 && defined $self->{cookie} ? $self->_cookie_path : $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 $cookie_path = defined $self->{cookie}
      && $env->{REQUEST_URI} eq $self->_cookie_path;

   return $self->_respond ($handle, 404, "Not Found", "")
      unless $env->{REQUEST_URI} eq $self->{path} || $cookie_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 (defined $self->{cookie} || defined $self->{bearer} || defined $self->{users}) {
      my $authenticated = $cookie_path;
      my $authorization = $env->{HTTP_AUTHORIZATION};

      if (defined $self->{bearer} && $authorization =~ /\ABearer ([^\s]+)\z/i) {
         $authenticated ||= $1 eq $self->{bearer};
      }

      if ($self->{users} && $authorization =~ /\ABasic ([A-Za-z0-9+\/=]+)\z/i) {
         my ($username, $password) = split /:/, MIME::Base64::decode_base64 ($1), 2;
         $authenticated ||= defined $password && exists $self->{users}{$username}
            && $password eq $self->{users}{$username};
      }

      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 && defined $self->{bearer} ? "WWW-Authenticate: Bearer\r\n" : "")
      . ($status == 401 && $self->{users} ? "WWW-Authenticate: Basic realm=\"MCP\"\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.5
Committed:	Sat Oct 10 10:48:51 2026 UTC (3 weeks, 6 days ago) by root
Branch:	MAIN
Changes since 1.4:	+3 -13 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			The MCP endpoint path, defaulting to C</mcp/>. Bearer and Basic authentication
41			use C<$path> directly; URL cookies prefix it with C</COOKIE>.
42
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			=item cookie => $token
69
70			Authenticates requests using C</TOKEN> followed by the configured C<path>.
71			Cookie credentials are URL path components, not HTTP cookies.
72
73			=item bearer => $token
74
75			Authenticates requests using an C<Authorization: Bearer TOKEN> header.
76
77			=item users => { $username => $password, ... }
78
79			Basic authentication users and passwords. An empty hash permits no Basic users.
80
81			C<users> can alternatively be an array of allowed usernames, or a
82			comma-separated configuration string. Their Basic passwords are derived
83			from the global secret and C<name>, which is required for this form.
84			C<anyevent-mcp password NAME USER> prints the matching password.
85
86			=item name => $name
87
88	root	1.5	Identifies the service when deriving Basic passwords from a user list.
89			Use L<AnyEvent::MCP::Config/http_settings> to resolve named listener
90			configuration before constructing this transport.
91	root	1.1
92			=item url_host => $hostname
93
94			Overrides the advertised hostname, for example when listening on a wildcard
95			address. Otherwise a wildcard uses the nodename from C<uname>.
96
97			=item url_scheme => $scheme
98
99			Overrides the advertised scheme; otherwise TLS handle options select
100			C<https>, and plain handles select C<http>.
101
102			=back
103
104			Any configured authentication method can authenticate the request. Omitting
105			C<cookie>, C<bearer> and C<users> leaves authentication to the embedding
106			application. Explicitly undefined options disable that method. Cookie URLs
107			are also accepted when using bearer or Basic authentication.
108
109			=head2 $url = $server->url ($with_cookie)
110
111			Returns the advertised URL with the actual listening port. C<$with_cookie>
112			defaults to true, including the URL cookie when configured. Pass false for
113			the clean URL to use with a bearer token or Basic authentication.
114
115			The port must be known. Wildcard hostname resolution and reverse-proxy
116			routing remain the caller's responsibility.
117
118			=head2 $server->listen ($host, $port, %handle)
119
120			Starts a listener, replacing any previous listener. Omitted arguments use
121			the configured host and port. The actual bound port is stored in
122			C<< $server->{port} >>, including when requesting an ephemeral port.
123
124			C<%handle> overrides the configured C<handle> options for connections
125			accepted by this listener.
126
127			=head2 $handle = $server->accept ($socket, %handle)
128
129			Starts handling an already accepted socket. The server takes ownership of
130			C<$socket>. No listener is needed.
131
132			C<%handle> overrides the configured C<handle> options for this connection.
133
134			=head2 $server->close
135
136			Stops listening, closes accepted sockets and cancels outstanding requests.
137			The same object can subsequently listen or accept again.
138
139			=head1 EVENTS
140
141			=head2 on_connection_error => $callback->($server, $handle, $message)
142
143			Called for socket errors before closing the connection.
144
145			=head2 on_close => $callback->($server)
146
147			Called once after C<close> stops the listener and closes all connections.
148			Calling C<listen> or C<accept> again starts a new lifetime.
149
150			=cut
151
152			package AnyEvent::MCP::Server::HTTP;
153
154			use common::sense;
155			use parent "AnyEvent::MCP::Server";
156			use AnyEvent::Handle ();
157			use AnyEvent::Socket ();
158			use HTTP::Parser::XS ();
159			use JSON::XS ();
160			use MIME::Base64 ();
161			use Scalar::Util qw(weaken);
162			use POSIX ();
163
164			sub new {
165			my ($class, %kv) = @_;
166
167			if (defined $kv{users} && ref $kv{users} ne "HASH") {
168			die "Derived Basic users require a server name\n" unless defined $kv{name};
169			require AnyEvent::MCP::Config;
170			my $config = AnyEvent::MCP::Config->global;
171			my @users = ref $kv{users} eq "ARRAY" ? @{$kv{users}} : split /\s,\s/, $kv{users};
172			$kv{users} = { map { $_ => $config->credential ("basic", $kv{name}, $_) } @users };
173			}
174
175	root	1.4	$class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
176	root	1.1	}
177
178			sub listen {
179			my ($self, $host, $port, %handle) = @_;
180
181			delete $self->{_closed};
182			$host = $self->{host} unless defined $host;
183			$port = $self->{port} unless defined $port;
184
185			$self->{listen_host} = $host;
186			$self->{listen_handle} = { %{$self->{handle} \|\| {}}, %handle };
187
188			delete $self->{listener};
189			weaken $self;
190
191			$self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
192			$self->accept ($_[0], %handle) if $self;
193			}, sub {
194			$self->{port} = $_[2] if $self;
195			()
196			};
197			}
198
199			sub _cookie_path {
200			my ($self) = @_;
201
202	root	1.2	my $cookie = AnyEvent::MCP::utf8enc $self->{cookie};
203	root	1.1	$cookie =~ s/([^A-Za-z0-9_.~-])/sprintf "%%%02X", ord $1/ge;
204
205			"/$cookie$self->{path}"
206			}
207
208			sub url {
209			my ($self, $with_cookie) = @_;
210
211			$with_cookie = 1 unless defined $with_cookie;
212
213			my $host = $self->{url_host}
214			\|\| (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
215			$host = (POSIX::uname)[1] if !length $host \|\| $host eq "0.0.0.0" \|\| $host eq "::";
216			$host = "[$host]" if $host =~ /:/ && $host !~ /\A\[/;
217
218			my $port = $self->{port} or die "HTTP port is not known\n";
219			my $scheme = $self->{url_scheme}
220			\|\| (($self->{listen_handle} \|\| $self->{handle} \|\| {})->{tls} ? "https" : "http");
221			my $path = $with_cookie && defined $self->{cookie} ? $self->_cookie_path : $self->{path};
222
223			"$scheme://$host:$port$path"
224			}
225
226			sub accept {
227			my ($self, $socket, %handle) = @_;
228
229			delete $self->{_closed};
230			weaken $self;
231
232			my $handle = AnyEvent::Handle->new (
233			rbuf_max => $self->{max_size} \|\| 1024 * 1024,
234			%{$self->{handle}},
235			%handle,
236			fh => $socket,
237			on_read => undef,
238			on_error => sub {
239			$self->event (connection_error => $_[0], $_[2]) if $self;
240			$self->_close ($_[0]) if $self;
241			},
242			on_eof => sub { $self->_close ($_[0]) if $self },
243			);
244
245			$handle->{mcp_peer} = {};
246			$self->{connections}{$handle} = $handle;
247			$self->_read ($handle);
248
249			$handle
250			}
251
252			sub _read {
253			my ($self, $handle) = @_;
254
255			weaken $self;
256
257			$handle->push_read (line => "\r\n\r\n", sub {
258			my ($handle, $header) = @_;
259			return unless $self;
260
261			my $parsed = HTTP::Parser::XS::parse_http_request ($header . "\r\n\r\n", \my %env);
262			$handle->{mcp_close} = $self->{connection_close}
263			\|\| $env{SERVER_PROTOCOL} ne "HTTP/1.1"
264			\|\| $env{HTTP_CONNECTION} =~ /\bclose\b/i;
265
266			$env{CONTENT_LENGTH} = 0 unless defined $env{CONTENT_LENGTH};
267
268			return $self->_respond ($handle, 400, "Bad Request", "")
269			if $parsed < 0 \|\| exists $env{HTTP_TRANSFER_ENCODING}
270			\|\| $env{CONTENT_LENGTH} !~ /\A[0-9]+\z/;
271
272			return $self->_respond ($handle, 413, "Content Too Large", "")
273			if $env{CONTENT_LENGTH} > ($self->{max_size} \|\| 1024 * 1024);
274
275			if ($env{HTTP_EXPECT}) {
276			return $self->_respond ($handle, 417, "Expectation Failed", "")
277			unless lc $env{HTTP_EXPECT} eq "100-continue";
278
279			$handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
280			}
281
282			$handle->push_read (chunk => $env{CONTENT_LENGTH}, sub {
283			my ($handle, $body) = @_;
284
285			$self->_request ($handle, \%env, $body) if $self;
286			});
287			});
288			}
289
290			sub _request {
291			my ($self, $handle, $env, $body) = @_;
292
293			delete $handle->{mcp_origin};
294
295			my $cookie_path = defined $self->{cookie}
296			&& $env->{REQUEST_URI} eq $self->_cookie_path;
297
298			return $self->_respond ($handle, 404, "Not Found", "")
299			unless $env->{REQUEST_URI} eq $self->{path} \|\| $cookie_path;
300
301			if (exists $env->{HTTP_ORIGIN}) {
302			my $wildcard = grep $_ eq "*", @{$self->{origins}};
303
304			return $self->_respond ($handle, 403, "Forbidden", "")
305			unless $wildcard \|\| grep $_ eq $env->{HTTP_ORIGIN}, @{$self->{origins}};
306
307			$handle->{mcp_origin} = $wildcard ? "*" : $env->{HTTP_ORIGIN};
308			}
309
310			if ($env->{REQUEST_METHOD} eq "OPTIONS" && @{$self->{origins}}) {
311			return $self->_respond ($handle, 405, "Method Not Allowed", "")
312			if exists $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD}
313			&& $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD} ne "POST";
314
315			return $self->_respond ($handle, 204, "No Content", "");
316			}
317
318			return $self->_respond ($handle, 405, "Method Not Allowed", "")
319			unless $env->{REQUEST_METHOD} eq "POST";
320
321			if (defined $self->{cookie} \|\| defined $self->{bearer} \|\| defined $self->{users}) {
322			my $authenticated = $cookie_path;
323			my $authorization = $env->{HTTP_AUTHORIZATION};
324
325			if (defined $self->{bearer} && $authorization =~ /\ABearer ([^\s]+)\z/i) {
326			$authenticated \|\|= $1 eq $self->{bearer};
327			}
328
329			if ($self->{users} && $authorization =~ /\ABasic ([A-Za-z0-9+\/=]+)\z/i) {
330			my ($username, $password) = split /:/, MIME::Base64::decode_base64 ($1), 2;
331			$authenticated \|\|= defined $password && exists $self->{users}{$username}
332			&& $password eq $self->{users}{$username};
333			}
334
335			return $self->_respond ($handle, 401, "Unauthorized", "")
336			unless $authenticated;
337			}
338
339			return $self->_respond ($handle, 415, "Unsupported Media Type", "")
340			unless $env->{CONTENT_TYPE} =~ m{\Aapplication/json(?:\s*;\|\z)}i;
341
342			my $message = eval { JSON::XS::decode_json $body };
343
344			if ($@) {
345			return $self->_rpc_error (sub {
346			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
347			}, undef, -32700, "Parse error");
348			}
349
350			my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
351			my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
352			my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
353			\|\| $env->{HTTP_MCP_PROTOCOL_VERSION} ge "2026";
354
355			if ($modern && ref $message eq "HASH" && exists $message->{id}) {
356			my %headers = (
357			HTTP_MCP_PROTOCOL_VERSION => $meta->{"io.modelcontextprotocol/protocolVersion"},
358			HTTP_MCP_METHOD => $message->{method},
359			);
360
361			$headers{HTTP_MCP_NAME} = exists $params->{name} ? $params->{name} : $params->{uri}
362			if $message->{method} =~ /\A(?:tools\/call\|prompts\/get\|resources\/read)\z/;
363
364			for my $name (keys %headers) {
365			my $value = $env->{$name};
366
367			if ($name eq "HTTP_MCP_NAME" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
368	root	1.2	$value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
369	root	1.1	}
370
371			unless (defined $value && defined $headers{$name} && $value eq $headers{$name}) {
372			return $self->_rpc_error (sub {
373			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
374			}, $message->{id}, -32020, "Header mismatch: $name");
375			}
376			}
377			}
378
379			weaken $self;
380
381			$self->rpc ($message, sub {
382			my ($response) = @_;
383			return unless $self && !$handle->{mcp_closed};
384
385			my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
386
387			if ($modern && defined $response && $response->{error}) {
388			($status, $reason) = $response->{error}{code} == -32601
389			? (404, "Not Found") : (400, "Bad Request");
390			}
391
392			$self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
393			},
394			peer => $handle->{mcp_peer},
395			protocol_version => $env->{HTTP_MCP_PROTOCOL_VERSION} \|\| "2025-03-26",
396			);
397			}
398
399			sub _respond {
400			my ($self, $handle, $status, $reason, $body) = @_;
401
402			return if $handle->{mcp_closed};
403
404			$handle->push_write (
405			"HTTP/1.1 $status $reason\r\n"
406			. "Content-Type: application/json\r\n"
407			. "Content-Length: " . length ($body) . "\r\n"
408			. (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
409			. ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
410			. ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
411			. "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
412			. "Access-Control-Max-Age: 86400\r\n" : "")
413			. ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
414			. ($status == 401 && defined $self->{bearer} ? "WWW-Authenticate: Bearer\r\n" : "")
415			. ($status == 401 && $self->{users} ? "WWW-Authenticate: Basic realm=\"MCP\"\r\n" : "")
416			. ($handle->{mcp_close} \|\| $status != 200 && $status != 202 ? "Connection: close\r\n" : "")
417			. "\r\n$body"
418			);
419
420			if ($handle->{mcp_close} \|\| $status != 200 && $status != 202) {
421			weaken $self;
422			$handle->on_drain (sub { $self->_close ($_[0]) if $self });
423			} else {
424			$self->_read ($handle);
425			}
426			}
427
428			sub _close {
429			my ($self, $handle) = @_;
430
431			return if $handle->{mcp_closed};
432			$handle->{mcp_closed} = 1;
433
434			my $requests = delete $handle->{mcp_peer}{requests} \|\| {};
435			$_->cancel ("Connection closed") for grep defined, values %$requests;
436
437			delete $self->{connections}{$handle};
438			$handle->destroy;
439			}
440
441			sub close {
442			my ($self) = @_;
443
444			return if $self->{_closed}++;
445			delete $self->{listener};
446			$self->_close ($_) for values %{$self->{connections} \|\| {}};
447			$self->event (close =>);
448			}
449
450			sub DESTROY {
451			$_[0]->close
452			}
453
454			1