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> implementing ordinary HTTP POST
request/response. It can listen itself, or accept sockets from an existing
listener. Applications with their own HTTP parser can use Server directly.

This initial implementation uses JSON responses and drops notifications;
SSE and subscriptions are not implemented. Requests on one connection are
dispatched in sequence, preserving HTTP response order. Other connections
are independent.

Request bodies require Content-Length; chunked requests are not implemented
yet. 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 4

=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 an empty array: requests with an
Origin header are rejected, while requests without one are accepted.
C<["*"]> permits any origin. Allowed origins receive CORS response headers,
and configured origins 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

Loads C<host>, C<port>, C<path>, C<url_host>, C<url_scheme>, C<cookie>,
C<bearer> and C<users> defaults from C<[server NAME]>. Explicit constructor
arguments override them. Without C<name> no global configuration is read.

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