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 AUTHENTICATION

Unlike L<AnyEvent::MCP::Server::Simple/mcp_start>, this low-level object
does not load global configuration or derive credentials. Supply C<tokens>
explicitly, for example:

   my $server = AnyEvent::MCP::Server::HTTP->new (
      host   => "127.0.0.1",
      port   => 31740,
      path   => "/mcp/",
      tokens => ["a-long-random-secret", "another-long-random-secret"],
   );
   $server->listen;

Each token authorizes the same requests. For either token, a client may
POST to C</TOKEN/mcp/> without an Authorization header, or POST to
C</mcp/> with C<Authorization: Bearer TOKEN>. URL credentials are path
components, B<not> HTTP cookies. C<url> advertises the first token;
C<url (0)> returns the clean endpoint.

The accepted tokens are static, URL-safe strings. HTTP Basic and OAuth
access-token validation are not implemented here. There is no automatic
fallback to the master-secret-derived token: that belongs to C<mcp_start>
or L<AnyEvent::MCP::Config/http_settings>.

Authentication defaults to C<tokens>, and construction B<fails> unless a
nonempty array of valid tokens is provided. To deliberately delegate
authentication to a trusted embedding layer (for example, a reverse proxy
that rejects unauthorized requests before they reach MCP), specify
C<auth =E<gt> "none"> instead, B<without> C<tokens>. This is an explicit
opt-out, not a permissive default. The embedding layer then owns the
entire authentication boundary.
The C<origins> setting filters browser origins; it is not authentication.
URLs can leak through logs and histories, and HTTP alone does not encrypt
tokens. Use TLS when credentials cross an untrusted network. A local address
is a sensible default, but not a credential.

=head1 METHODS

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

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

=over

=item host => $host

The listening address, defaulting to C<127.0.0.1>.

=item port => $port

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

=item path => $path

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

=item connection_close => $boolean

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

=item max_size => $bytes

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

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

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

=item handle => { %handle }

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

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

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

=item auth => "tokens" | "none"

Select authentication mode. C<tokens> is the default and requires at least
one token; C<none> explicitly disables HTTP authentication and cannot be
combined with tokens. Other values are rejected. Browser origins are
not a replacement for authentication.

=item name => $name

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

=item url_host => $hostname

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

=item url_scheme => $scheme

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

=back

Every configured token authenticates in either the URL or the Authorization
header. Without tokens, the constructor requires C<auth =E<gt> "none">.

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

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

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

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

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

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

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

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

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

=head2 $server->close

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

=head1 EVENTS

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

Called for socket errors before closing the connection.

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

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

=cut

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

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

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

   $kv{auth} //= "tokens";
   if ($kv{auth} eq "tokens") {
      ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
         or die "HTTP server requires nonempty tokens\n";
      /\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
         for @{$kv{tokens}};
   } elsif ($kv{auth} eq "none") {
      !exists $kv{tokens}
         or die "Unauthenticated HTTP server must not configure tokens\n";
   } else {
      die "Unsupported HTTP authentication type '$kv{auth}'\n";
   }

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

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

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

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

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

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

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

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

   $with_cookie = 1 unless defined $with_cookie;

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

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

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

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

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

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

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

   $handle
}

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

   weaken $self;

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

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

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

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

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

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

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

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

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

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

   delete $handle->{mcp_origin};

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   weaken $self;

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

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

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

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

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

   return if $handle->{mcp_closed};

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

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

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

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

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

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

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

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

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

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