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.

C<Mcp-Param-*> headers from C<x-mcp-header> tool schema annotations are not
currently validated against the body; see C<PLAN.md> for the HTTP
duplicate-field normalization ambiguity.

=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 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 =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts

   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://" . AnyEvent::Socket::format_hostport ($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
}

# Parse a request line and HTTP fields, using the same comma-combining
# approach as AnyEvent::HTTP::_parse_hdr. The caller already bounds headers.
sub _parse_request_headers {
   local $_ = $_[0] . "\r\n";
   /\A([!#$%&'*+.^_\x60|~0-9A-Za-z-]+) [ ]+
      ([^\x00-\x20]+) [ ]+ HTTP\/0*([0-9.]+)\r\n/gcix
      or return;
   my ($method, $uri, $version) = ($1, $2, $3);
   return unless $version =~ /\A1\.[0-9]+\z/;
   my %env = (REQUEST_METHOD => $method, REQUEST_URI => $uri,
      SERVER_PROTOCOL => "HTTP/$version");
   my %hdr;

   $hdr{lc $1} .= ",$2"
      while /\G
            ([!\#$%&'*+.^_\x60|~0-9A-Za-z-]+):
            [\t ]*
            ([^\x00-\x08\x0a-\x1f\x7f]*)
            \r\n
         /gcx;

   /\G\z/gc or return;

   # Discard the prefix used for comma-combining repeated field values.
   substr $_, 0, 1, "" for values %hdr;
   s/[\t ]+\z// for values %hdr;

   for my $name (keys %hdr) {
      my $key = uc $name;
      $key =~ tr/-/_/;
      $key = "HTTP_$key" unless $key eq "CONTENT_LENGTH" || $key eq "CONTENT_TYPE";
      $env{$key} = $hdr{$name};
   }

   \%env
}

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

   weaken $self;

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

      my $env = _parse_request_headers ($header);
      $handle->{mcp_close} = $self->{connection_close}
         || !$env || $env->{SERVER_PROTOCOL} =~ m{\AHTTP/1\.0+\z}
         || $env->{HTTP_CONNECTION} =~ /\bclose\b/i;

      return $self->_respond ($handle, 400, "Bad Request", "") unless $env;

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