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. The built-in protocol headers
C<Mcp-Protocol-Version>, C<Mcp-Method> and, where applicable, C<Mcp-Name>
must agree with modern request metadata and parameters; a mismatch is
rejected. Custom schema-derived headers do not receive this check.

=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

=over

=item $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">.

=item $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.

=item $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.

=item $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.

=item $server->close

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

=back

=head1 EVENTS

=over

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

Called for socket errors before closing the connection.

=item 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.

=back

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