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.

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

If C<tokens> is omitted, this transport performs B<no authentication>.
Only do so when a trusted embedding layer authenticates every MCP request.
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.

=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. If C<tokens> is omitted, an embedding application must supply
its own authentication.

=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 HTTP::Parser::XS ();
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";

   if (exists $kv{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}};
   }

   $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 = "[$host]" if $host =~ /:/ && $host !~ /\A\[/;

   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://$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
}

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

   weaken $self;

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

      my $parsed = HTTP::Parser::XS::parse_http_request ($header . "\r\n\r\n", \my %env);
      $handle->{mcp_close} = $self->{connection_close}
         || $env{SERVER_PROTOCOL} ne "HTTP/1.1"
         || $env{HTTP_CONNECTION} =~ /\bclose\b/i;

      $env{CONTENT_LENGTH} = 0 unless defined $env{CONTENT_LENGTH};

      return $self->_respond ($handle, 400, "Bad Request", "")
         if $parsed < 0 || exists $env{HTTP_TRANSFER_ENCODING}
            || $env{CONTENT_LENGTH} !~ /\A[0-9]+\z/;

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

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

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

      $handle->push_read (chunk => $env{CONTENT_LENGTH}, sub {
         my ($handle, $body) = @_;

         $self->_request ($handle, \%env, $body) if $self;
      });
   });
}

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

   delete $handle->{mcp_origin};

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

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

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

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

      $handle->{mcp_origin} = $wildcard ? "*" : $env->{HTTP_ORIGIN};
   }

   if ($env->{REQUEST_METHOD} eq "OPTIONS" && @{$self->{origins}}) {
      return $self->_respond ($handle, 405, "Method Not Allowed", "")
         if exists $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD}
            && $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD} ne "POST";

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

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

   if ($self->{tokens}) {
      my $authenticated = $token_path;
      my $authorization = $env->{HTTP_AUTHORIZATION};

      if ($authorization =~ /\ABearer ([^\s]+)\z/i) {
         my $token = $1;
         $authenticated ||= grep $_ eq $token, @{$self->{tokens}};
      }

      return $self->_respond ($handle, 401, "Unauthorized", "")
         unless $authenticated;
   }

   return $self->_respond ($handle, 415, "Unsupported Media Type", "")
      unless $env->{CONTENT_TYPE} =~ m{\Aapplication/json(?:\s*;|\z)}i;

   my $message = eval { JSON::XS::decode_json $body };

   if ($@) {
      return $self->_rpc_error (sub {
         $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
      }, undef, -32700, "Parse error");
   }

   my $params = ref $message eq "HASH" && ref $message->{params} eq "HASH" ? $message->{params} : {};
   my $meta   = ref $params->{_meta} eq "HASH" ? $params->{_meta} : {};
   my $modern = exists $meta->{"io.modelcontextprotocol/protocolVersion"}
      || $env->{HTTP_MCP_PROTOCOL_VERSION} ge "2026";

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

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

      for my $name (keys %headers) {
         my $value = $env->{$name};

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

         unless (defined $value && defined $headers{$name} && $value eq $headers{$name}) {
            return $self->_rpc_error (sub {
               $self->_respond ($handle, 400, "Bad Request", JSON::XS::encode_json $_[0]);
            }, $message->{id}, -32020, "Header mismatch: $name");
         }
      }
   }

   weaken $self;

   $self->rpc ($message, sub {
      my ($response) = @_;
      return unless $self && !$handle->{mcp_closed};

      my ($status, $reason) = defined $response ? (200, "OK") : (202, "Accepted");

      if ($modern && defined $response && $response->{error}) {
         ($status, $reason) = $response->{error}{code} == -32601
            ? (404, "Not Found") : (400, "Bad Request");
      }

      $self->_respond ($handle, $status, $reason, defined $response ? JSON::XS::encode_json $response : "");
   },
      peer            => $handle->{mcp_peer},
      protocol_version => $env->{HTTP_MCP_PROTOCOL_VERSION} || "2025-03-26",
   );
}

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

   return if $handle->{mcp_closed};

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

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

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

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

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

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

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

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

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

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