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_extension => $callback->($server, $handle, $hello)

Accept raw extension connections on the HTTP listener. A first byte of C<[>
selects a bounded, newline-terminated JSON hello whose first two fields are
the protocol name and an accepted listener token. Authenticate before invoking
this callback, which validates the protocol-specific fields and takes ownership
of the handle, preserving buffered input. Throw an exception to reject it.
HTTP connections continue through the normal parser. This dispatch examines
decrypted bytes when TLS is configured, but the built-in reverse connector
currently supports only plain C<http://> endpoints.

=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;
   if ($self->{on_extension}) {
      $handle->rtimeout (15);
      $handle->push_read (chunk => 1, sub {
         my ($handle, $first) = @_;
         return unless $self;
         $handle->{rbuf} = $first . $handle->{rbuf};

         if ($first eq "[") {
            require AnyEvent::MCP::Extension;
            AnyEvent::MCP::Extension::accept ($handle, $self->{tokens} || [], sub {
               my ($handle, $hello) = @_;
               return $handle->destroy unless $self;
               delete $self->{connections}{$handle};
               $self->{on_extension}->($self, $handle, $hello);
            }, sub { $self->_close ($_[0]) if $self });
         } else {
            $handle->rtimeout (0);
            $self->_read ($handle);
         }
      });
   } else {
      $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.14
Committed:	Thu Oct 15 05:48:13 2026 UTC (2 weeks, 1 day ago) by root
Branch:	MAIN
Changes since 1.13:	+34 -1 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	root	1.14	=item on_extension => $callback->($server, $handle, $hello)
183
184			Accept raw extension connections on the HTTP listener. A first byte of C<[>
185			selects a bounded, newline-terminated JSON hello whose first two fields are
186			the protocol name and an accepted listener token. Authenticate before invoking
187			this callback, which validates the protocol-specific fields and takes ownership
188			of the handle, preserving buffered input. Throw an exception to reject it.
189			HTTP connections continue through the normal parser. This dispatch examines
190			decrypted bytes when TLS is configured, but the built-in reverse connector
191			currently supports only plain C<http://> endpoints.
192
193	root	1.13	=item on_connection_error => $callback->($server, $handle, $message)
194	root	1.1
195			Called for socket errors before closing the connection.
196
197	root	1.13	=item on_close => $callback->($server)
198	root	1.1
199			Called once after C<close> stops the listener and closes all connections.
200			Calling C<listen> or C<accept> again starts a new lifetime.
201
202	root	1.13	=back
203
204	root	1.1	=cut
205
206			package AnyEvent::MCP::Server::HTTP;
207
208			use common::sense;
209			use parent "AnyEvent::MCP::Server";
210			use AnyEvent::Handle ();
211			use AnyEvent::Socket ();
212			use JSON::XS ();
213			use Scalar::Util qw(weaken);
214			use POSIX ();
215
216			sub new {
217			my ($class, %kv) = @_;
218	root	1.12
219	root	1.6	!grep (exists $kv{$_}, qw(cookie bearer users))
220			or die "Legacy HTTP authentication options are unsupported; use tokens\n";
221	root	1.1
222	root	1.8	$kv{auth} //= "tokens";
223			if ($kv{auth} eq "tokens") {
224	root	1.6	ref $kv{tokens} eq "ARRAY" && @{$kv{tokens}}
225			or die "HTTP server requires nonempty tokens\n";
226			/\A[A-Za-z0-9_.~-]+\z/ or die "Invalid HTTP server token\n"
227			for @{$kv{tokens}};
228	root	1.8	} elsif ($kv{auth} eq "none") {
229			!exists $kv{tokens}
230			or die "Unauthenticated HTTP server must not configure tokens\n";
231			} else {
232			die "Unsupported HTTP authentication type '$kv{auth}'\n";
233	root	1.1	}
234
235	root	1.4	$class->SUPER::new (host => "127.0.0.1", port => 0, path => "/mcp/", origins => ["*"], %kv)
236	root	1.1	}
237
238			sub listen {
239			my ($self, $host, $port, %handle) = @_;
240
241			delete $self->{_closed};
242			$host = $self->{host} unless defined $host;
243			$port = $self->{port} unless defined $port;
244
245			$self->{listen_host} = $host;
246			$self->{listen_handle} = { %{$self->{handle} \|\| {}}, %handle };
247
248			delete $self->{listener};
249			weaken $self;
250
251			$self->{listener} = AnyEvent::Socket::tcp_server $host, $port, sub {
252			$self->accept ($_[0], %handle) if $self;
253			}, sub {
254			$self->{port} = $_[2] if $self;
255			()
256			};
257			}
258
259	root	1.6	sub _token_path {
260			my ($self, $token) = @_;
261	root	1.12
262	root	1.6	"/$token$self->{path}"
263	root	1.1	}
264
265			sub url {
266	root	1.12	my ($self, $with_token) = @_;
267	root	1.1
268	root	1.12	$with_token = 1 unless defined $with_token;
269	root	1.1
270			my $host = $self->{url_host}
271			\|\| (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
272			$host = (POSIX::uname)[1] if !length $host \|\| $host eq "0.0.0.0" \|\| $host eq "::";
273	root	1.9	$host =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts
274	root	1.1
275			my $port = $self->{port} or die "HTTP port is not known\n";
276			my $scheme = $self->{url_scheme}
277			\|\| (($self->{listen_handle} \|\| $self->{handle} \|\| {})->{tls} ? "https" : "http");
278	root	1.12	my $path = $with_token && $self->{tokens} && @{$self->{tokens}}
279	root	1.6	? $self->_token_path ($self->{tokens}[0]) : $self->{path};
280	root	1.1
281	root	1.9	"$scheme://" . AnyEvent::Socket::format_hostport ($host, $port) . $path
282	root	1.1	}
283
284			sub accept {
285			my ($self, $socket, %handle) = @_;
286
287			delete $self->{_closed};
288			weaken $self;
289
290			my $handle = AnyEvent::Handle->new (
291			rbuf_max => $self->{max_size} \|\| 1024 * 1024,
292			%{$self->{handle}},
293			%handle,
294			fh => $socket,
295			on_read => undef,
296			on_error => sub {
297			$self->event (connection_error => $_[0], $_[2]) if $self;
298			$self->_close ($_[0]) if $self;
299			},
300			on_eof => sub { $self->_close ($_[0]) if $self },
301			);
302
303			$handle->{mcp_peer} = {};
304			$self->{connections}{$handle} = $handle;
305	root	1.14	if ($self->{on_extension}) {
306			$handle->rtimeout (15);
307			$handle->push_read (chunk => 1, sub {
308			my ($handle, $first) = @_;
309			return unless $self;
310			$handle->{rbuf} = $first . $handle->{rbuf};
311
312			if ($first eq "[") {
313			require AnyEvent::MCP::Extension;
314			AnyEvent::MCP::Extension::accept ($handle, $self->{tokens} \|\| [], sub {
315			my ($handle, $hello) = @_;
316			return $handle->destroy unless $self;
317			delete $self->{connections}{$handle};
318			$self->{on_extension}->($self, $handle, $hello);
319			}, sub { $self->_close ($_[0]) if $self });
320			} else {
321			$handle->rtimeout (0);
322			$self->_read ($handle);
323			}
324			});
325			} else {
326			$self->_read ($handle);
327			}
328	root	1.1
329			$handle
330			}
331
332	root	1.12	# parse a request line and HTTP fields, using the same comma-combining
333	root	1.10	# approach as AnyEvent::HTTP::_parse_hdr. The caller already bounds headers.
334			sub _parse_request_headers {
335			local $_ = $_[0] . "\r\n";
336			/\A([!#$%&'*+.^_\x60\|~0-9A-Za-z-]+) [ ]+
337			([^\x00-\x20]+) [ ]+ HTTP\/0*([0-9.]+)\r\n/gcix
338			or return;
339			my ($method, $uri, $version) = ($1, $2, $3);
340			return unless $version =~ /\A1\.[0-9]+\z/;
341			my %hdr;
342
343			$hdr{lc $1} .= ",$2"
344			while /\G
345			([!\#$%&'*+.^_\x60\|~0-9A-Za-z-]+):
346			[\t ]*
347			([^\x00-\x08\x0a-\x1f\x7f]*)
348			\r\n
349			/gcx;
350
351			/\G\z/gc or return;
352
353	root	1.12	# discard the prefix used for comma-combining repeated field values.
354	root	1.10	substr $_, 0, 1, "" for values %hdr;
355			s/[\t ]+\z// for values %hdr;
356
357	root	1.12	# request-line fields override any colliding HTTP header names.
358	root	1.11	+{ %hdr, method => $method, uri => $uri, http_version => $version }
359	root	1.10	}
360
361	root	1.1	sub _read {
362			my ($self, $handle) = @_;
363
364			weaken $self;
365
366			$handle->push_read (line => "\r\n\r\n", sub {
367			my ($handle, $header) = @_;
368	root	1.12
369	root	1.1	return unless $self;
370
371	root	1.11	my $hdr = _parse_request_headers ($header);
372	root	1.1	$handle->{mcp_close} = $self->{connection_close}
373	root	1.11	\|\| !$hdr \|\| $hdr->{http_version} =~ m{\A1\.0+\z}
374			\|\| $hdr->{connection} =~ /\bclose\b/i;
375	root	1.1
376	root	1.11	return $self->_respond ($handle, 400, "Bad Request", "") unless $hdr;
377	root	1.1
378	root	1.11	$hdr->{"content-length"} = 0 unless defined $hdr->{"content-length"};
379	root	1.1	return $self->_respond ($handle, 400, "Bad Request", "")
380	root	1.11	if exists $hdr->{"transfer-encoding"}
381			\|\| $hdr->{"content-length"} !~ /\A[0-9]+\z/;
382	root	1.1
383			return $self->_respond ($handle, 413, "Content Too Large", "")
384	root	1.11	if $hdr->{"content-length"} > ($self->{max_size} \|\| 1024 * 1024);
385	root	1.1
386	root	1.11	if ($hdr->{expect}) {
387	root	1.1	return $self->_respond ($handle, 417, "Expectation Failed", "")
388	root	1.11	unless lc $hdr->{expect} eq "100-continue";
389	root	1.1
390			$handle->push_write ("HTTP/1.1 100 Continue\r\n\r\n");
391			}
392
393	root	1.11	$handle->push_read (chunk => $hdr->{"content-length"}, sub {
394	root	1.1	my ($handle, $body) = @_;
395
396	root	1.11	$self->_request ($handle, $hdr, $body) if $self;
397	root	1.1	});
398			});
399			}
400
401			sub _request {
402	root	1.11	my ($self, $handle, $hdr, $body) = @_;
403	root	1.1
404			delete $handle->{mcp_origin};
405
406	root	1.6	my $token_path = $self->{tokens}
407	root	1.11	&& grep $hdr->{uri} eq $self->_token_path ($_), @{$self->{tokens}};
408	root	1.1
409			return $self->_respond ($handle, 404, "Not Found", "")
410	root	1.11	unless $hdr->{uri} eq $self->{path} \|\| $token_path;
411	root	1.1
412	root	1.11	if (exists $hdr->{origin}) {
413	root	1.1	my $wildcard = grep $_ eq "*", @{$self->{origins}};
414
415			return $self->_respond ($handle, 403, "Forbidden", "")
416	root	1.11	unless $wildcard \|\| grep $_ eq $hdr->{origin}, @{$self->{origins}};
417	root	1.1
418	root	1.11	$handle->{mcp_origin} = $wildcard ? "*" : $hdr->{origin};
419	root	1.1	}
420
421	root	1.11	if ($hdr->{method} eq "OPTIONS" && @{$self->{origins}}) {
422	root	1.1	return $self->_respond ($handle, 405, "Method Not Allowed", "")
423	root	1.11	if exists $hdr->{"access-control-request-method"}
424			&& $hdr->{"access-control-request-method"} ne "POST";
425	root	1.1
426			return $self->_respond ($handle, 204, "No Content", "");
427			}
428
429			return $self->_respond ($handle, 405, "Method Not Allowed", "")
430	root	1.11	unless $hdr->{method} eq "POST";
431	root	1.1
432	root	1.6	if ($self->{tokens}) {
433			my $authenticated = $token_path;
434	root	1.11	my $authorization = $hdr->{authorization};
435	root	1.1
436	root	1.6	if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
437			my $token = $1;
438			$authenticated \|\|= grep $_ eq $token, @{$self->{tokens}};
439	root	1.1	}
440
441			return $self->_respond ($handle, 401, "Unauthorized", "")
442			unless $authenticated;
443			}
444
445			return $self->_respond ($handle, 415, "Unsupported Media Type", "")
446	root	1.11	unless $hdr->{"content-type"} =~ m{\Aapplication/json(?:\s*;\|\z)}i;
447	root	1.1
448			my $message = eval { JSON::XS::decode_json $body };
449
450			if ($@) {
451			return $self->_rpc_error (sub {
452			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
453			}, undef, -32700, "Parse error");
454			}
455
456			my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
457			my $meta = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
458			my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
459	root	1.11	\|\| $hdr->{"mcp-protocol-version"} ge "2026";
460	root	1.1
461			if ($modern && ref $message eq "HASH" && exists $message->{id}) {
462	root	1.11	my %expected = (
463			"mcp-protocol-version" => $meta->{"io.modelcontextprotocol/protocolVersion"},
464			"mcp-method" => $message->{method},
465	root	1.1	);
466
467	root	1.11	$expected{"mcp-name"} = exists $params->{name} ? $params->{name} : $params->{uri}
468	root	1.1	if $message->{method} =~ /\A(?:tools\/call\|prompts\/get\|resources\/read)\z/;
469
470	root	1.11	for my $name (keys %expected) {
471			my $value = $hdr->{$name};
472	root	1.1
473	root	1.11	if ($name eq "mcp-name" && $value =~ /\A=\?base64\?([A-Za-z0-9+\/=]*)\?=\z/) {
474	root	1.2	$value = eval { AnyEvent::MCP::utf8dec (MIME::Base64::decode_base64 ($1)) };
475	root	1.1	}
476
477	root	1.11	unless (defined $value && defined $expected{$name} && $value eq $expected{$name}) {
478	root	1.1	return $self->_rpc_error (sub {
479			$self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
480			}, $message->{id}, -32020, "Header mismatch: $name");
481			}
482			}
483			}
484
485			weaken $self;
486
487			$self->rpc ($message, sub {
488			my ($response) = @_;
489	root	1.12
490	root	1.1	return unless $self && !$handle->{mcp_closed};
491
492			my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");
493
494			if ($modern && defined $response && $response->{error}) {
495			($status, $reason) = $response->{error}{code} == -32601
496			? (404, "Not Found") : (400, "Bad Request");
497			}
498
499			$self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
500			},
501	root	1.12	peer => $handle->{mcp_peer},
502	root	1.11	protocol_version => $hdr->{"mcp-protocol-version"} \|\| "2025-03-26",
503	root	1.1	);
504			}
505
506			sub _respond {
507			my ($self, $handle, $status, $reason, $body) = @_;
508
509			return if $handle->{mcp_closed};
510
511	root	1.12	my $close = $handle->{mcp_close} \|\| $status != 200 && $status != 202;
512
513	root	1.1	$handle->push_write (
514			"HTTP/1.1 $status $reason\r\n"
515			. "Content-Type: application/json\r\n"
516			. "Content-Length: " . length ($body) . "\r\n"
517			. (defined $handle->{mcp_origin} ? "Access-Control-Allow-Origin: $handle->{mcp_origin}\r\n"
518			. ($handle->{mcp_origin} ne "*" ? "Vary: Origin\r\n" : "") : "")
519			. ($status == 204 ? "Access-Control-Allow-Methods: POST, OPTIONS\r\n"
520			. "Access-Control-Allow-Headers: content-type,authorization,mcp-protocol-version,mcp-method,mcp-name\r\n"
521			. "Access-Control-Max-Age: 86400\r\n" : "")
522			. ($status == 405 ? "Allow: POST" . (@{$self->{origins}} ? ", OPTIONS" : "") . "\r\n" : "")
523	root	1.6	. ($status == 401 && $self->{tokens} ? "WWW-Authenticate: Bearer\r\n" : "")
524	root	1.12	. ($close ? "Connection: close\r\n" : "")
525	root	1.1	. "\r\n$body"
526			);
527
528	root	1.12	if ($close) {
529	root	1.1	weaken $self;
530			$handle->on_drain (sub { $self->_close ($_[0]) if $self });
531			} else {
532			$self->_read ($handle);
533			}
534			}
535
536			sub _close {
537			my ($self, $handle) = @_;
538
539			return if $handle->{mcp_closed};
540			$handle->{mcp_closed} = 1;
541
542			my $requests = delete $handle->{mcp_peer}{requests} \|\| {};
543			$_->cancel ("Connection closed") for grep defined, values %$requests;
544
545			delete $self->{connections}{$handle};
546			$handle->destroy;
547			}
548
549			sub close {
550			my ($self) = @_;
551
552			return if $self->{_closed}++;
553			delete $self->{listener};
554			$self->_close ($_) for values %{$self->{connections} \|\| {}};
555			$self->event (close =>);
556			}
557
558			sub DESTROY {
559			$_[0]->close
560			}
561
562			1