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_token) = @_;

   $with_token = 1 unless defined $with_token;

   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_token && $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 %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;

   # request-line fields override any colliding HTTP header names.
   +{ %hdr, method => $method, uri => $uri, http_version => $version }
}

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

   weaken $self;

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

      return unless $self;

      my $hdr = _parse_request_headers ($header);
      $handle->{mcp_close} = $self->{connection_close}
         || !$hdr || $hdr->{http_version} =~ m{\A1\.0+\z}
         || $hdr->{connection} =~ /\bclose\b/i;

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

      $hdr->{"content-length"} = 0 unless defined $hdr->{"content-length"};
      return $self->_respond ($handle, 400, "Bad Request", "")
         if exists $hdr->{"transfer-encoding"}
            || $hdr->{"content-length"} !~ /\A[0-9]+\z/;

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

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

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

      $handle->push_read (chunk => $hdr->{"content-length"}, sub {
         my ($handle, $body) = @_;

         $self->_request ($handle, $hdr, $body) if $self;
      });
   });
}

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

   delete $handle->{mcp_origin};

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

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

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

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

      $handle->{mcp_origin} = $wildcard ? "*" : $hdr->{origin};
   }

   if ($hdr->{method} eq "OPTIONS" && @{$self->{origins}}) {
      return $self->_respond ($handle, 405, "Method Not Allowed", "")
         if exists $hdr->{"access-control-request-method"}
            && $hdr->{"access-control-request-method"} ne "POST";

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

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

   if ($self->{tokens}) {
      my $authenticated = $token_path;
      my $authorization = $hdr->{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 $hdr->{"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"}
      || $hdr->{"mcp-protocol-version"} ge "2026";

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

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

      for my $name (keys %expected) {
         my $value = $hdr->{$name};

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

         unless (defined $value && defined $expected{$name} && $value eq $expected{$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 => $hdr->{"mcp-protocol-version"} || "2025-03-26",
   );
}

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

   return if $handle->{mcp_closed};

   my $close = $handle->{mcp_close} || $status != 200 && $status != 202;

   $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" : "")
      . ($close ? "Connection: close\r\n" : "")
      . "\r\n$body"
   );

   if ($close) {
      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.12
Committed:	Tue Oct 13 10:17:31 2026 UTC (2 weeks, 3 days ago) by root
Branch:	MAIN
Changes since 1.11:	+15 -9 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.12
198	root	1.6	!grep (exists $kv{$_}, qw(cookie bearer users))
199			or die "Legacy HTTP authentication options are unsupported; use tokens\n";
200	root	1.1
201	root	1.8	$kv{auth} //= "tokens";
202			if ($kv{auth} eq "tokens") {
203	root	1.6	ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
204			or die "HTTP server requires nonempty tokens\n";
205			/\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
206			for @{$kv{tokens}};
207	root	1.8	} elsif ($kv{auth} eq "none") {
208			!exists $kv{tokens}
209			or die "Unauthenticated HTTP server must not configure tokens\n";
210			} else {
211			die "Unsupported HTTP authentication type '$kv{auth}'\n";
212	root	1.1	}
213
214	root	1.4	$class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
215	root	1.1	}
216
217			sub listen {
218			my ($self, $host, $port, %handle) = @_;
219
220			delete $self->{_closed};
221			$host = $self->{host} unless defined $host;
222			$port = $self->{port} unless defined $port;
223
224			$self->{listen_host} = $host;
225			$self->{listen_handle} = { %{$self->{handle} \|\| {}}, %handle };
226
227			delete $self->{listener};
228			weaken $self;
229
230			$self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
231			$self->accept ($_[0], %handle) if $self;
232			}, sub {
233			$self->{port} = $_[2] if $self;
234			()
235			};
236			}
237
238	root	1.6	sub _token_path {
239			my ($self, $token) = @_;
240	root	1.12
241	root	1.6	"/$token$self->{path}"
242	root	1.1	}
243
244			sub url {
245	root	1.12	my ($self, $with_token) = @_;
246	root	1.1
247	root	1.12	$with_token = 1 unless defined $with_token;
248	root	1.1
249			my $host = $self->{url_host}
250			\|\| (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
251			$host = (POSIX::uname)[1] if !length $host \|\| $host eq "0.0.0.0" \|\| $host eq "::";
252	root	1.9	$host =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts
253	root	1.1
254			my $port = $self->{port} or die "HTTP port is not known\n";
255			my $scheme = $self->{url_scheme}
256			\|\| (($self->{listen_handle} \|\| $self->{handle} \|\| {})->{tls} ? "https" : "http");
257	root	1.12	my $path = $with_token && $self->{tokens} && @{$self->{tokens}}
258	root	1.6	? $self->_token_path ($self->{tokens}[0]) : $self->{path};
259	root	1.1
260	root	1.9	"$scheme://" . AnyEvent::Socket::format_hostport ($host, $port) . $path
261	root	1.1	}
262
263			sub accept {
264			my ($self, $socket, %handle) = @_;
265
266			delete $self->{_closed};
267			weaken $self;
268
269			my $handle = AnyEvent::Handle->new (
270			rbuf_max => $self->{max_size} \|\| 1024 * 1024,
271			%{$self->{handle}},
272			%handle,
273			fh => $socket,
274			on_read => undef,
275			on_error => sub {
276			$self->event (connection_error => $_[0], $_[2]) if $self;
277			$self->_close ($_[0]) if $self;
278			},
279			on_eof => sub { $self->_close ($_[0]) if $self },
280			);
281
282			$handle->{mcp_peer} = {};
283			$self->{connections}{$handle} = $handle;
284			$self->_read ($handle);
285
286			$handle
287			}
288
289	root	1.12	# parse a request line and HTTP fields, using the same comma-combining
290	root	1.10	# approach as AnyEvent::HTTP::_parse_hdr. The caller already bounds headers.
291			sub _parse_request_headers {
292			local $_ = $_[0] . "\r\n";
293			/\A([!#$%&'*+.^_\x60\|~0-9A-Za-z-]+) [ ]+
294			([^\x00-\x20]+) [ ]+ HTTP\/0*([0-9.]+)\r\n/gcix
295			or return;
296			my ($method, $uri, $version) = ($1, $2, $3);
297			return unless $version =~ /\A1\.[0-9]+\z/;
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	root	1.12	# discard the prefix used for comma-combining repeated field values.
311	root	1.10	substr $_, 0, 1, "" for values %hdr;
312			s/[\t ]+\z// for values %hdr;
313
314	root	1.12	# request-line fields override any colliding HTTP header names.
315	root	1.11	+{ %hdr, method => $method, uri => $uri, http_version => $version }
316	root	1.10	}
317
318	root	1.1	sub _read {
319			my ($self, $handle) = @_;
320
321			weaken $self;
322
323			$handle->push_read (line => "\r\n\r\n", sub {
324			my ($handle, $header) = @_;
325	root	1.12
326	root	1.1	return unless $self;
327
328	root	1.11	my $hdr = _parse_request_headers ($header);
329	root	1.1	$handle->{mcp_close} = $self->{connection_close}
330	root	1.11	\|\| !$hdr \|\| $hdr->{http_version} =~ m{\A1\.0+\z}
331			\|\| $hdr->{connection} =~ /\bclose\b/i;
332	root	1.1
333	root	1.11	return $self->_respond ($handle, 400, "Bad Request", "") unless $hdr;
334	root	1.1
335	root	1.11	$hdr->{"content-length"} = 0 unless defined $hdr->{"content-length"};
336	root	1.1	return $self->_respond ($handle, 400, "Bad Request", "")
337	root	1.11	if exists $hdr->{"transfer-encoding"}
338			\|\| $hdr->{"content-length"} !~ /\A[0-9]+\z/;
339	root	1.1
340			return $self->_respond ($handle, 413, "Content Too Large", "")
341	root	1.11	if $hdr->{"content-length"} > ($self->{max_size} \|\| 1024 * 1024);
342	root	1.1
343	root	1.11	if ($hdr->{expect}) {
344	root	1.1	return $self->_respond ($handle, 417, "Expectation Failed", "")
345	root	1.11	unless lc $hdr->{expect} eq "100-continue";
346	root	1.1
347			$handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
348			}
349
350	root	1.11	$handle->push_read (chunk => $hdr->{"content-length"}, sub {
351	root	1.1	my ($handle, $body) = @_;
352
353	root	1.11	$self->_request ($handle, $hdr, $body) if $self;
354	root	1.1	});
355			});
356			}
357
358			sub _request {
359	root	1.11	my ($self, $handle, $hdr, $body) = @_;
360	root	1.1
361			delete $handle->{mcp_origin};
362
363	root	1.6	my $token_path = $self->{tokens}
364	root	1.11	&& grep $hdr->{uri} eq $self->_token_path ($_), @{$self->{tokens}};
365	root	1.1
366			return $self->_respond ($handle, 404, "Not Found", "")
367	root	1.11	unless $hdr->{uri} eq $self->{path} \|\| $token_path;
368	root	1.1
369	root	1.11	if (exists $hdr->{origin}) {
370	root	1.1	my $wildcard = grep $_ eq "*", @{$self->{origins}};
371
372			return $self->_respond ($handle, 403, "Forbidden", "")
373	root	1.11	unless $wildcard \|\| grep $_ eq $hdr->{origin}, @{$self->{origins}};
374	root	1.1
375	root	1.11	$handle->{mcp_origin} = $wildcard ? "*" : $hdr->{origin};
376	root	1.1	}
377
378	root	1.11	if ($hdr->{method} eq "OPTIONS" && @{$self->{origins}}) {
379	root	1.1	return $self->_respond ($handle, 405, "Method Not Allowed", "")
380	root	1.11	if exists $hdr->{"access-control-request-method"}
381			&& $hdr->{"access-control-request-method"} ne "POST";
382	root	1.1
383			return $self->_respond ($handle, 204, "No Content", "");
384			}
385
386			return $self->_respond ($handle, 405, "Method Not Allowed", "")
387	root	1.11	unless $hdr->{method} eq "POST";
388	root	1.1
389	root	1.6	if ($self->{tokens}) {
390			my $authenticated = $token_path;
391	root	1.11	my $authorization = $hdr->{authorization};
392	root	1.1
393	root	1.6	if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
394			my $token = $1;
395			$authenticated \|\|= grep $_ eq $token, @{$self->{tokens}};
396	root	1.1	}
397
398			return $self->_respond ($handle, 401, "Unauthorized", "")
399			unless $authenticated;
400			}
401
402			return $self->_respond ($handle, 415, "Unsupported Media Type", "")
403	root	1.11	unless $hdr->{"content-type"} =~ m{\Aapplication/json(?:\s*;\|\z)}i;
404	root	1.1
405			my $message = eval { JSON::XS::decode_json $body };
406
407			if ($@) {
408			return $self->_rpc_error (sub {
409			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
410			}, undef, -32700, "Parse error");
411			}
412
413			my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
414			my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
415			my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
416	root	1.11	\|\| $hdr->{"mcp-protocol-version"} ge "2026";
417	root	1.1
418			if ($modern && ref $message eq "HASH" && exists $message->{id}) {
419	root	1.11	my %expected = (
420			"mcp-protocol-version" => $meta->{"io.modelcontextprotocol/protocolVersion"},
421			"mcp-method" => $message->{method},
422	root	1.1	);
423
424	root	1.11	$expected{"mcp-name"} = exists $params->{name} ? $params->{name} : $params->{uri}
425	root	1.1	if $message->{method} =~ /\A(?:tools\/call\|prompts\/get\|resources\/read)\z/;
426
427	root	1.11	for my $name (keys %expected) {
428			my $value = $hdr->{$name};
429	root	1.1
430	root	1.11	if ($name eq "mcp-name" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
431	root	1.2	$value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
432	root	1.1	}
433
434	root	1.11	unless (defined $value && defined $expected{$name} && $value eq $expected{$name}) {
435	root	1.1	return $self->_rpc_error (sub {
436			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
437			}, $message->{id}, -32020, "Header mismatch: $name");
438			}
439			}
440			}
441
442			weaken $self;
443
444			$self->rpc ($message, sub {
445			my ($response) = @_;
446	root	1.12
447	root	1.1	return unless $self && !$handle->{mcp_closed};
448
449			my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
450
451			if ($modern && defined $response && $response->{error}) {
452			($status, $reason) = $response->{error}{code} == -32601
453			? (404, "Not Found") : (400, "Bad Request");
454			}
455
456			$self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
457			},
458	root	1.12	peer => $handle->{mcp_peer},
459	root	1.11	protocol_version => $hdr->{"mcp-protocol-version"} \|\| "2025-03-26",
460	root	1.1	);
461			}
462
463			sub _respond {
464			my ($self, $handle, $status, $reason, $body) = @_;
465
466			return if $handle->{mcp_closed};
467
468	root	1.12	my $close = $handle->{mcp_close} \|\| $status != 200 && $status != 202;
469
470	root	1.1	$handle->push_write (
471			"HTTP/1.1 $status $reason\r\n"
472			. "Content-Type: application/json\r\n"
473			. "Content-Length: " . length ($body) . "\r\n"
474			. (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
475			. ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
476			. ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
477			. "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
478			. "Access-Control-Max-Age: 86400\r\n" : "")
479			. ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
480	root	1.6	. ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
481	root	1.12	. ($close ? "Connection: close\r\n" : "")
482	root	1.1	. "\r\n$body"
483			);
484
485	root	1.12	if ($close) {
486	root	1.1	weaken $self;
487			$handle->on_drain (sub { $self->_close ($_[0]) if $self });
488			} else {
489			$self->_read ($handle);
490			}
491			}
492
493			sub _close {
494			my ($self, $handle) = @_;
495
496			return if $handle->{mcp_closed};
497			$handle->{mcp_closed} = 1;
498
499			my $requests = delete $handle->{mcp_peer}{requests} \|\| {};
500			$_->cancel ("Connection closed") for grep defined, values %$requests;
501
502			delete $self->{connections}{$handle};
503			$handle->destroy;
504			}
505
506			sub close {
507			my ($self) = @_;
508
509			return if $self->{_closed}++;
510			delete $self->{listener};
511			$self->_close ($_) for values %{$self->{connections} \|\| {}};
512			$self->event (close =>);
513			}
514
515			sub DESTROY {
516			$_[0]->close
517			}
518
519			1