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 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.3
Committed:	Fri Oct 9 09:36:49 2026 UTC (3 weeks, 1 day ago) by root
Branch:	MAIN
Changes since 1.2:	+14 -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			Allowed Origin header values. Defaults to an empty array: requests with an
57			Origin header are rejected, while requests without one are accepted.
58			C<["*"]> permits any origin. Allowed origins receive CORS response headers,
59			and configured origins enable OPTIONS preflight for POST. Preflight does not
60			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			Loads C<host>, C<port>, C<path>, C<url_host>, C<url_scheme>, C<cookie>,
89			C<bearer> and C<users> defaults from C<[server NAME]>. Explicit constructor
90			arguments override them. Without C<name> no global configuration is read.
91
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{name}) {
168			require AnyEvent::MCP::Config;
169			my $settings = AnyEvent::MCP::Config->global->{section}{"server $kv{name}"} \|\| {};
170			%kv = (
171			(map { exists $settings->{$_} ? ($_ => $settings->{$_}) : () }
172			qw(host port path url_host url_scheme cookie bearer users)),
173			%kv,
174			);
175			}
176
177			if (defined $kv{users} && ref $kv{users} ne "HASH") {
178			die "Derived Basic users require a server name\n" unless defined $kv{name};
179			require AnyEvent::MCP::Config;
180			my $config = AnyEvent::MCP::Config->global;
181			my @users = ref $kv{users} eq "ARRAY" ? @{$kv{users}} : split /\s,\s/, $kv{users};
182			$kv{users} = { map { $_ => $config->credential ("basic", $kv{name}, $_) } @users };
183			}
184
185			$class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => [], %kv)
186			}
187
188			sub listen {
189			my ($self, $host, $port, %handle) = @_;
190
191			delete $self->{_closed};
192			$host = $self->{host} unless defined $host;
193			$port = $self->{port} unless defined $port;
194
195			$self->{listen_host} = $host;
196			$self->{listen_handle} = { %{$self->{handle} \|\| {}}, %handle };
197
198			delete $self->{listener};
199			weaken $self;
200
201			$self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
202			$self->accept ($_[0], %handle) if $self;
203			}, sub {
204			$self->{port} = $_[2] if $self;
205			()
206			};
207			}
208
209			sub _cookie_path {
210			my ($self) = @_;
211
212	root	1.2	my $cookie = AnyEvent::MCP::utf8enc $self->{cookie};
213	root	1.1	$cookie =~ s/([^A-Za-z0-9_.~-])/sprintf "%%%02X", ord $1/ge;
214
215			"/$cookie$self->{path}"
216			}
217
218			sub url {
219			my ($self, $with_cookie) = @_;
220
221			$with_cookie = 1 unless defined $with_cookie;
222
223			my $host = $self->{url_host}
224			\|\| (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
225			$host = (POSIX::uname)[1] if !length $host \|\| $host eq "0.0.0.0" \|\| $host eq "::";
226			$host = "[$host]" if $host =~ /:/ && $host !~ /\A\[/;
227
228			my $port = $self->{port} or die "HTTP port is not known\n";
229			my $scheme = $self->{url_scheme}
230			\|\| (($self->{listen_handle} \|\| $self->{handle} \|\| {})->{tls} ? "https" : "http");
231			my $path = $with_cookie && defined $self->{cookie} ? $self->_cookie_path : $self->{path};
232
233			"$scheme://$host:$port$path"
234			}
235
236			sub accept {
237			my ($self, $socket, %handle) = @_;
238
239			delete $self->{_closed};
240			weaken $self;
241
242			my $handle = AnyEvent::Handle->new (
243			rbuf_max => $self->{max_size} \|\| 1024 * 1024,
244			%{$self->{handle}},
245			%handle,
246			fh => $socket,
247			on_read => undef,
248			on_error => sub {
249			$self->event (connection_error => $_[0], $_[2]) if $self;
250			$self->_close ($_[0]) if $self;
251			},
252			on_eof => sub { $self->_close ($_[0]) if $self },
253			);
254
255			$handle->{mcp_peer} = {};
256			$self->{connections}{$handle} = $handle;
257			$self->_read ($handle);
258
259			$handle
260			}
261
262			sub _read {
263			my ($self, $handle) = @_;
264
265			weaken $self;
266
267			$handle->push_read (line => "\r\n\r\n", sub {
268			my ($handle, $header) = @_;
269			return unless $self;
270
271			my $parsed = HTTP::Parser::XS::parse_http_request ($header . "\r\n\r\n", \my %env);
272			$handle->{mcp_close} = $self->{connection_close}
273			\|\| $env{SERVER_PROTOCOL} ne "HTTP/1.1"
274			\|\| $env{HTTP_CONNECTION} =~ /\bclose\b/i;
275
276			$env{CONTENT_LENGTH} = 0 unless defined $env{CONTENT_LENGTH};
277
278			return $self->_respond ($handle, 400, "Bad Request", "")
279			if $parsed < 0 \|\| exists $env{HTTP_TRANSFER_ENCODING}
280			\|\| $env{CONTENT_LENGTH} !~ /\A[0-9]+\z/;
281
282			return $self->_respond ($handle, 413, "Content Too Large", "")
283			if $env{CONTENT_LENGTH} > ($self->{max_size} \|\| 1024 * 1024);
284
285			if ($env{HTTP_EXPECT}) {
286			return $self->_respond ($handle, 417, "Expectation Failed", "")
287			unless lc $env{HTTP_EXPECT} eq "100-continue";
288
289			$handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
290			}
291
292			$handle->push_read (chunk => $env{CONTENT_LENGTH}, sub {
293			my ($handle, $body) = @_;
294
295			$self->_request ($handle, \%env, $body) if $self;
296			});
297			});
298			}
299
300			sub _request {
301			my ($self, $handle, $env, $body) = @_;
302
303			delete $handle->{mcp_origin};
304
305			my $cookie_path = defined $self->{cookie}
306			&& $env->{REQUEST_URI} eq $self->_cookie_path;
307
308			return $self->_respond ($handle, 404, "Not Found", "")
309			unless $env->{REQUEST_URI} eq $self->{path} \|\| $cookie_path;
310
311			if (exists $env->{HTTP_ORIGIN}) {
312			my $wildcard = grep $_ eq "*", @{$self->{origins}};
313
314			return $self->_respond ($handle, 403, "Forbidden", "")
315			unless $wildcard \|\| grep $_ eq $env->{HTTP_ORIGIN}, @{$self->{origins}};
316
317			$handle->{mcp_origin} = $wildcard ? "*" : $env->{HTTP_ORIGIN};
318			}
319
320			if ($env->{REQUEST_METHOD} eq "OPTIONS" && @{$self->{origins}}) {
321			return $self->_respond ($handle, 405, "Method Not Allowed", "")
322			if exists $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD}
323			&& $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD} ne "POST";
324
325			return $self->_respond ($handle, 204, "No Content", "");
326			}
327
328			return $self->_respond ($handle, 405, "Method Not Allowed", "")
329			unless $env->{REQUEST_METHOD} eq "POST";
330
331			if (defined $self->{cookie} \|\| defined $self->{bearer} \|\| defined $self->{users}) {
332			my $authenticated = $cookie_path;
333			my $authorization = $env->{HTTP_AUTHORIZATION};
334
335			if (defined $self->{bearer} && $authorization =~ /\ABearer ([^\s]+)\z/i) {
336			$authenticated \|\|= $1 eq $self->{bearer};
337			}
338
339			if ($self->{users} && $authorization =~ /\ABasic ([A-Za-z0-9+\/=]+)\z/i) {
340			my ($username, $password) = split /:/, MIME::Base64::decode_base64 ($1), 2;
341			$authenticated \|\|= defined $password && exists $self->{users}{$username}
342			&& $password eq $self->{users}{$username};
343			}
344
345			return $self->_respond ($handle, 401, "Unauthorized", "")
346			unless $authenticated;
347			}
348
349			return $self->_respond ($handle, 415, "Unsupported Media Type", "")
350			unless $env->{CONTENT_TYPE} =~ m{\Aapplication/json(?:\s*;\|\z)}i;
351
352			my $message = eval { JSON::XS::decode_json $body };
353
354			if ($@) {
355			return $self->_rpc_error (sub {
356			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
357			}, undef, -32700, "Parse error");
358			}
359
360			my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
361			my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
362			my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
363			\|\| $env->{HTTP_MCP_PROTOCOL_VERSION} ge "2026";
364
365			if ($modern && ref $message eq "HASH" && exists $message->{id}) {
366			my %headers = (
367			HTTP_MCP_PROTOCOL_VERSION => $meta->{"io.modelcontextprotocol/protocolVersion"},
368			HTTP_MCP_METHOD => $message->{method},
369			);
370
371			$headers{HTTP_MCP_NAME} = exists $params->{name} ? $params->{name} : $params->{uri}
372			if $message->{method} =~ /\A(?:tools\/call\|prompts\/get\|resources\/read)\z/;
373
374			for my $name (keys %headers) {
375			my $value = $env->{$name};
376
377			if ($name eq "HTTP_MCP_NAME" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
378	root	1.2	$value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
379	root	1.1	}
380
381			unless (defined $value && defined $headers{$name} && $value eq $headers{$name}) {
382			return $self->_rpc_error (sub {
383			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
384			}, $message->{id}, -32020, "Header mismatch: $name");
385			}
386			}
387			}
388
389			weaken $self;
390
391			$self->rpc ($message, sub {
392			my ($response) = @_;
393			return unless $self && !$handle->{mcp_closed};
394
395			my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
396
397			if ($modern && defined $response && $response->{error}) {
398			($status, $reason) = $response->{error}{code} == -32601
399			? (404, "Not Found") : (400, "Bad Request");
400			}
401
402			$self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
403			},
404			peer => $handle->{mcp_peer},
405			protocol_version => $env->{HTTP_MCP_PROTOCOL_VERSION} \|\| "2025-03-26",
406			);
407			}
408
409			sub _respond {
410			my ($self, $handle, $status, $reason, $body) = @_;
411
412			return if $handle->{mcp_closed};
413
414			$handle->push_write (
415			"HTTP/1.1 $status $reason\r\n"
416			. "Content-Type: application/json\r\n"
417			. "Content-Length: " . length ($body) . "\r\n"
418			. (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
419			. ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
420			. ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
421			. "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
422			. "Access-Control-Max-Age: 86400\r\n" : "")
423			. ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
424			. ($status == 401 && defined $self->{bearer} ? "WWW-Authenticate: Bearer\r\n" : "")
425			. ($status == 401 && $self->{users} ? "WWW-Authenticate: Basic realm=\"MCP\"\r\n" : "")
426			. ($handle->{mcp_close} \|\| $status != 200 && $status != 202 ? "Connection: close\r\n" : "")
427			. "\r\n$body"
428			);
429
430			if ($handle->{mcp_close} \|\| $status != 200 && $status != 202) {
431			weaken $self;
432			$handle->on_drain (sub { $self->_close ($_[0]) if $self });
433			} else {
434			$self->_read ($handle);
435			}
436			}
437
438			sub _close {
439			my ($self, $handle) = @_;
440
441			return if $handle->{mcp_closed};
442			$handle->{mcp_closed} = 1;
443
444			my $requests = delete $handle->{mcp_peer}{requests} \|\| {};
445			$_->cancel ("Connection closed") for grep defined, values %$requests;
446
447			delete $self->{connections}{$handle};
448			$handle->destroy;
449			}
450
451			sub close {
452			my ($self) = @_;
453
454			return if $self->{_closed}++;
455			delete $self->{listener};
456			$self->_close ($_) for values %{$self->{connections} \|\| {}};
457			$self->event (close =>);
458			}
459
460			sub DESTROY {
461			$_[0]->close
462			}
463
464			1