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 Encode ();
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 = Encode::encode_utf8 $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 { Encode::decode ("UTF-8", MIME::Base64::decode_base64 ($1), Encode::FB_CROAK) };
         }

         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.1
Committed:	Thu Oct 8 05:27:00 2026 UTC (3 weeks, 1 day ago) by root
Branch:	MAIN
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 Encode ();
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			my $cookie = Encode::encode_utf8 $self->{cookie};
213			$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			$value = eval { Encode::decode ("UTF-8", MIME::Base64::decode_base64 ($1), Encode::FB_CROAK) };
379			}
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