MCP/Server/HTTP.pm

=head1 NAME

AnyEvent::MCP::Server::HTTP - an optional MCP HTTP listener and socket handler

=head1 DESCRIPTION

A subclass of L<AnyEvent::MCP::Server> that handles HTTP POST requests.
It can open its own listener, or you can give it sockets accepted elsewhere.
If your application already parses HTTP, you can pass decoded requests to
L<AnyEvent::MCP::Server> instead of running another HTTP implementation.

Requests sharing one connection are dispatched in sequence, preserving their
HTTP response order; requests on other connections are independent. This
implementation returns JSON and drops notifications. It does not support
SSE or subscriptions.

Request bodies need C<Content-Length>: chunked transfer encoding is not
supported. The server does not assign protocol sessions. Legacy clients
use the 2025 request/response subset.

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

=head1 AUTHENTICATION

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

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

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

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

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

=head1 METHODS

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

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

=over

=item host => $host

The listening address, defaulting to C<127.0.0.1>.

=item port => $port

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

=item path => $path

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

=item connection_close => $boolean

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

=item max_size => $bytes

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

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

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

=item handle => { %handle }

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

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

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

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

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

=item name => $name

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

=item url_host => $hostname

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

=item url_scheme => $scheme

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

=back

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

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

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

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

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

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

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

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

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

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

=head2 $server->close

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

=head1 EVENTS

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

Called for socket errors before closing the connection.

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

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

=cut

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

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

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

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

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

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

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

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

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

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

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

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

   $with_cookie = 1 unless defined $with_cookie;

   my $host = $self->{url_host}
      || (defined $self->{listen_host} ? $self->{listen_host} : $self->{host});
   $host = (POSIX::uname)[1] if !length $host || $host eq "0.0.0.0" || $host eq "::";
   $host =~ s/\A\[(.*)\]\z/$1/; # allow already bracketed IPv6 URL hosts

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

   "$scheme://" . AnyEvent::Socket::format_hostport ($host, $port) . $path
}

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

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

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

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

   $handle
}

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

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

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

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

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

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

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

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

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

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

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