AnyEvent-MCP/t/03_simple.t

use common::sense;
use AnyEvent ();
use AnyEvent::Handle ();
use AnyEvent::MCP::Server::Simple;
use AnyEvent::MCP::Server::HTTP ();
use AnyEvent::MCP::Config ();
use File::Temp ();
use IPC::Open3 ();
use Symbol ();
use JSON::XS ();
use MIME::Base64 ();
use Socket;

print "1..29\n";

my $test;
sub ok($$) {
   my ($condition, $name) = @_;

   print (($condition ? "ok " : "not ok "), ++$test, " - $name\n");
}

sub post {
   my ($server, $path, $authorization) = @_;

   socketpair my $a, my $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
   $server->accept ($a);
   my $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
   my $cv = AnyEvent->condvar;
   my $timer = AnyEvent->timer (after => 3, cb => sub { die "HTTP timeout\n" });
   my $body = '{"jsonrpc":"2.0","id":1,"method":"ping"}';
   $client->push_write (
      "POST $path HTTP/1.1\r\nContent-Type: application/json\r\n"
      . "Content-Length: " . length ($body) . "\r\n"
      . (defined $authorization ? "Authorization: $authorization\r\n" : "")
      . "\r\n$body"
   );

   my ($header, $response);
   $client->push_read (line => "\r\n\r\n", sub {
      my ($handle, $text) = @_;
      $header = $text;
      my ($length) = $header =~ /Content-Length: ([0-9]+)/;
      $handle->push_read (chunk => $length, sub {
         $response = $_[1];
         $cv->send;
      });
   });
   $cv->recv;
   $client->destroy;
   $server->close;

   ($header, $response)
}

my $server = AnyEvent::MCP::Server::HTTP->new (
   port => 31740, path => "/", tokens => ["secret", "alternate"],
);
ok $server->url eq "http://127.0.0.1:31740/secret/", "cookie URL";
ok $server->url (0) eq "http://127.0.0.1:31740/", "clean URL";

my ($header, $body) = post ($server, "/secret/");
ok $header =~ m{HTTP/1.1 200}, "cookie authenticates";
ok JSON::XS::decode_json ($body)->{id} == 1, "authenticated RPC reply";
($header, $body) = post ($server, "/", "Bearer secret");
ok $header =~ m{HTTP/1.1 200}, "same token authenticates bearer";
($header, $body) = post ($server, "/", "bEaReR secret");
ok $header =~ m{HTTP/1.1 200}, "authentication scheme is case insensitive";
($header, $body) = post ($server, "/");
ok $header =~ m{HTTP/1.1 401}, "missing credential rejected";
ok $header =~ /WWW-Authenticate: Bearer/, "bearer challenge";
($header, $body) = post ($server, "/", "Bearer wrong");
ok $header =~ m{HTTP/1.1 401}, "wrong bearer rejected";
($header, $body) = post ($server, "/wrong/");
ok $header =~ m{HTTP/1.1 404}, "wrong cookie path rejected";

$server = AnyEvent::MCP::Server::HTTP->new (tokens => ["first", "second"]);
($header, $body) = post ($server, "/second/mcp/");
ok $header =~ m{HTTP/1.1 200}, "second token works in URL";
($header, $body) = post ($server, "/mcp/", "Bearer first");
ok $header =~ m{HTTP/1.1 200}, "first token works as bearer";
($header, $body) = post ($server, "/mcp/", "Basic YTpi");
ok $header =~ m{HTTP/1.1 401} && $header !~ /WWW-Authenticate: Basic/, "Basic authentication is not supported";

$server = AnyEvent::MCP::Server::HTTP->new (tokens => ["standalone"]);
($header, $body) = post ($server, "/mcp/");
ok $header =~ m{HTTP/1.1 401}, "embedded server with tokens rejects unauthenticated requests";
$server = AnyEvent::MCP::Server::HTTP->new (auth => "none", 
   host => "::1", port => 31740, handle => { tls => "accept" },
);
ok $server->url eq "https://[::1]:31740/mcp/", "IPv6 and TLS URL";
$server->{url_host} = "example.net";
$server->{url_scheme} = "http";
ok $server->url eq "http://example.net:31740/mcp/", "advertised URL overrides";
delete $server->{url_host};
$server->{host} = "0.0.0.0";
ok $server->url eq "http://" . (POSIX::uname)[1] . ":31740/mcp/", "wildcard nodename";
$server->{port} = 0;
eval { $server->url };
ok $@ =~ /port is not known/, "unknown port has no URL";

my $dir = File::Temp::tempdir (CLEANUP => 1);
local $ENV{XDG_CONFIG_HOME} = $dir;
local $ENV{PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL};
my $printed = "";
{
   local *STDOUT;
   open STDOUT, ">", \$printed or die $!;
   my $timer;
   mcp_start name => "example", on_start => sub {
      $server = $_[0];
      $timer = AnyEvent->timer (after => 0.01, cb => sub { $server->close });
   };
}
ok $server->isa ("AnyEvent::MCP::Server::HTTP"), "normal startup uses HTTP";
ok $server->{port} && $printed eq "", "HTTP startup leaves stdout empty";
my $config = AnyEvent::MCP::Config->global;
ok $server->{tokens}[0] eq $config->credential ("token", "example"),
   "startup token matches derived utility";
ok $server->{server_info}{name} eq "example", "startup server identity";
$server->close;

my $err = Symbol::gensym;
my $pid = IPC::Open3::open3 (my $in, my $out, $err, $^X, "-Ilib", "-e", '
   use AnyEvent::MCP::Server::Simple;
   $ENV{XDG_CONFIG_HOME} = $ARGV[0];
   $ENV{PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL} = "stdio";
   mcp_start;
', "$dir/stdio");
print {$in} "{\"jsonrpc\":\"2.0\",\"id\":42,\"method\":\"ping\"}\n";
$in->flush;
close $in;
local $/;
my $output = <$out>;
my $errors = <$err>;
waitpid $pid, 0;
ok !$? && !$errors, "multibroker startup succeeds";
ok eval { JSON::XS::decode_json ($output)->{id} == 42 }, "stdio output contains only RPC";
ok !-e "$dir/stdio", "stdio does not access global configuration";

$err = Symbol::gensym;
$pid = IPC::Open3::open3 ($in, $out, $err, $^X, "-Ilib", "-e", '
   use AnyEvent::MCP::Server::Simple;
   my $timer;
   mcp_tool delayed => "delayed", {}, sub {
      my ($req) = @_;
      $timer = AnyEvent->timer (after => 0.03, cb => sub {
         $req->reply ({ content => [{ type => "text", text => "x" x 200000 }] });
      });
   };
   mcp_stdio;
   print STDERR "stopped\\n";
');
print {$in} JSON::XS::encode_json ({
   jsonrpc => "2.0", id => 1, method => "initialize", params => {
      protocolVersion => "2025-11-25", clientInfo => {}, capabilities => {},
   },
}), "\n";
print {$in} JSON::XS::encode_json ({
   jsonrpc => "2.0", id => 2, method => "tools/call", params => { name => "delayed" },
}), "\n";
close $in;
$output = <$out>;
$errors = <$err>;
waitpid $pid, 0;
ok !$? && $errors eq "stopped\n", "mcp_stdio returns after input EOF";
my @messages = map JSON::XS::decode_json ($_), split /\n/, $output;
ok @messages == 2 && $messages[1]{id} == 2
   && length $messages[1]{result}{content}[0]{text} == 200000,
   "EOF waits for an asynchronous reply and drains large output";

my ($started, $closed, $timer);
mcp_http auth => "none", port => 0, on_start => sub {
   my ($server) = @_;
   ++$started;
   $timer = AnyEvent->timer (after => 0.01, cb => sub { $server->close });
}, on_close => sub { ++$closed };
ok $started == 1 && $closed == 1, "mcp_http blocks through startup and returns on close";

eval { mcp_http auth => "none", port => 0, on_start => sub { die "startup failed\n" } };
ok $@ =~ /startup failed/, "startup hook exception closes the server and propagates";
Revision:	1.5
Committed:	Sun Oct 11 01:46:31 2026 UTC (3 weeks ago) by root
Content type:	application/x-troff
Branch:	MAIN
Changes since 1.4:	+4 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	use common::sense;
2			use AnyEvent ();
3			use AnyEvent::Handle ();
4			use AnyEvent::MCP::Server::Simple;
5			use AnyEvent::MCP::Server::HTTP ();
6			use AnyEvent::MCP::Config ();
7			use File::Temp ();
8			use IPC::Open3 ();
9			use Symbol ();
10			use JSON::XS ();
11			use MIME::Base64 ();
12			use Socket;
13
14	root	1.2	print "1..29\n";
15	root	1.1
16			my $test;
17			sub ok($$) {
18			my ($condition, $name) = @_;
19
20			print (($condition ? "ok " : "not ok "), ++$test, " - $name\n");
21			}
22
23			sub post {
24			my ($server, $path, $authorization) = @_;
25
26			socketpair my $a, my $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
27			$server->accept ($a);
28			my $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
29			my $cv = AnyEvent->condvar;
30			my $timer = AnyEvent->timer (after => 3, cb => sub { die "HTTP timeout\n" });
31			my $body = '{"jsonrpc":"2.0","id":1,"method":"ping"}';
32			$client->push_write (
33			"POST $path HTTP/1.1\r\nContent-Type: application/json\r\n"
34			. "Content-Length: " . length ($body) . "\r\n"
35			. (defined $authorization ? "Authorization: $authorization\r\n" : "")
36			. "\r\n$body"
37			);
38
39			my ($header, $response);
40			$client->push_read (line => "\r\n\r\n", sub {
41			my ($handle, $text) = @_;
42			$header = $text;
43			my ($length) = $header =~ /Content-Length: ([0-9]+)/;
44			$handle->push_read (chunk => $length, sub {
45			$response = $_[1];
46			$cv->send;
47			});
48			});
49			$cv->recv;
50			$client->destroy;
51			$server->close;
52
53			($header, $response)
54			}
55
56			my $server = AnyEvent::MCP::Server::HTTP->new (
57	root	1.4	port => 31740, path => "/", tokens => ["secret", "alternate"],
58	root	1.1	);
59			ok $server->url eq "http://127.0.0.1:31740/secret/", "cookie URL";
60			ok $server->url (0) eq "http://127.0.0.1:31740/", "clean URL";
61
62			my ($header, $body) = post ($server, "/secret/");
63			ok $header =~ m{HTTP/1.1 200}, "cookie authenticates";
64			ok JSON::XS::decode_json ($body)->{id} == 1, "authenticated RPC reply";
65			($header, $body) = post ($server, "/", "Bearer secret");
66			ok $header =~ m{HTTP/1.1 200}, "same token authenticates bearer";
67			($header, $body) = post ($server, "/", "bEaReR secret");
68			ok $header =~ m{HTTP/1.1 200}, "authentication scheme is case insensitive";
69			($header, $body) = post ($server, "/");
70			ok $header =~ m{HTTP/1.1 401}, "missing credential rejected";
71			ok $header =~ /WWW-Authenticate: Bearer/, "bearer challenge";
72			($header, $body) = post ($server, "/", "Bearer wrong");
73			ok $header =~ m{HTTP/1.1 401}, "wrong bearer rejected";
74			($header, $body) = post ($server, "/wrong/");
75			ok $header =~ m{HTTP/1.1 404}, "wrong cookie path rejected";
76
77	root	1.4	$server = AnyEvent::MCP::Server::HTTP->new (tokens => ["first", "second"]);
78			($header, $body) = post ($server, "/second/mcp/");
79			ok $header =~ m{HTTP/1.1 200}, "second token works in URL";
80			($header, $body) = post ($server, "/mcp/", "Bearer first");
81			ok $header =~ m{HTTP/1.1 200}, "first token works as bearer";
82			($header, $body) = post ($server, "/mcp/", "Basic YTpi");
83			ok $header =~ m{HTTP/1.1 401} && $header !~ /WWW-Authenticate: Basic/, "Basic authentication is not supported";
84	root	1.1
85	root	1.4	$server = AnyEvent::MCP::Server::HTTP->new (tokens => ["standalone"]);
86	root	1.1	($header, $body) = post ($server, "/mcp/");
87	root	1.4	ok $header =~ m{HTTP/1.1 401}, "embedded server with tokens rejects unauthenticated requests";
88	root	1.5	$server = AnyEvent::MCP::Server::HTTP->new (auth => "none",
89	root	1.1	host => "::1", port => 31740, handle => { tls => "accept" },
90			);
91			ok $server->url eq "https://[::1]:31740/mcp/", "IPv6 and TLS URL";
92			$server->{url_host} = "example.net";
93			$server->{url_scheme} = "http";
94			ok $server->url eq "http://example.net:31740/mcp/", "advertised URL overrides";
95			delete $server->{url_host};
96			$server->{host} = "0.0.0.0";
97			ok $server->url eq "http://" . (POSIX::uname)[1] . ":31740/mcp/", "wildcard nodename";
98			$server->{port} = 0;
99			eval { $server->url };
100			ok $@ =~ /port is not known/, "unknown port has no URL";
101
102			my $dir = File::Temp::tempdir (CLEANUP => 1);
103			local $ENV{XDG_CONFIG_HOME} = $dir;
104			local $ENV{PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL};
105			my $printed = "";
106			{
107			local *STDOUT;
108			open STDOUT, ">", \$printed or die $!;
109	root	1.2	my $timer;
110			mcp_start name => "example", on_start => sub {
111			$server = $_[0];
112			$timer = AnyEvent->timer (after => 0.01, cb => sub { $server->close });
113			};
114	root	1.1	}
115			ok $server->isa ("AnyEvent::MCP::Server::HTTP"), "normal startup uses HTTP";
116	root	1.3	ok $server->{port} && $printed eq "", "HTTP startup leaves stdout empty";
117	root	1.1	my $config = AnyEvent::MCP::Config->global;
118	root	1.5	ok $server->{tokens}[0] eq $config->credential ("token", "example"),
119	root	1.4	"startup token matches derived utility";
120	root	1.1	ok $server->{server_info}{name} eq "example", "startup server identity";
121			$server->close;
122
123			my $err = Symbol::gensym;
124			my $pid = IPC::Open3::open3 (my $in, my $out, $err, $^X, "-Ilib", "-e", '
125			use AnyEvent::MCP::Server::Simple;
126			$ENV{XDG_CONFIG_HOME} = $ARGV[0];
127			$ENV{PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL} = "stdio";
128	root	1.2	mcp_start;
129	root	1.1	', "$dir/stdio");
130			print {$in} "{\"jsonrpc\":\"2.0\",\"id\":42,\"method\":\"ping\"}\n";
131			$in->flush;
132	root	1.2	close $in;
133	root	1.1	local $/;
134			my $output = <$out>;
135			my $errors = <$err>;
136			waitpid $pid, 0;
137			ok !$? && !$errors, "multibroker startup succeeds";
138			ok eval { JSON::XS::decode_json ($output)->{id} == 42 }, "stdio output contains only RPC";
139			ok !-e "$dir/stdio", "stdio does not access global configuration";
140	root	1.2
141			$err = Symbol::gensym;
142			$pid = IPC::Open3::open3 ($in, $out, $err, $^X, "-Ilib", "-e", '
143			use AnyEvent::MCP::Server::Simple;
144			my $timer;
145			mcp_tool delayed => "delayed", {}, sub {
146			my ($req) = @_;
147			$timer = AnyEvent->timer (after => 0.03, cb => sub {
148			$req->reply ({ content => [{ type => "text", text => "x" x 200000 }] });
149			});
150			};
151			mcp_stdio;
152			print STDERR "stopped\\n";
153			');
154			print {$in} JSON::XS::encode_json ({
155			jsonrpc => "2.0", id => 1, method => "initialize", params => {
156			protocolVersion => "2025-11-25", clientInfo => {}, capabilities => {},
157			},
158			}), "\n";
159			print {$in} JSON::XS::encode_json ({
160			jsonrpc => "2.0", id => 2, method => "tools/call", params => { name => "delayed" },
161			}), "\n";
162			close $in;
163			$output = <$out>;
164			$errors = <$err>;
165			waitpid $pid, 0;
166			ok !$? && $errors eq "stopped\n", "mcp_stdio returns after input EOF";
167			my @messages = map JSON::XS::decode_json ($_), split /\n/, $output;
168			ok @messages == 2 && $messages[1]{id} == 2
169			&& length $messages[1]{result}{content}[0]{text} == 200000,
170			"EOF waits for an asynchronous reply and drains large output";
171
172			my ($started, $closed, $timer);
173	root	1.5	mcp_http auth => "none", port => 0, on_start => sub {
174	root	1.2	my ($server) = @_;
175			++$started;
176			$timer = AnyEvent->timer (after => 0.01, cb => sub { $server->close });
177			}, on_close => sub { ++$closed };
178			ok $started == 1 && $closed == 1, "mcp_http blocks through startup and returns on close";
179
180	root	1.5	eval { mcp_http auth => "none", port => 0, on_start => sub { die "startup failed\n" } };
181	root	1.2	ok $@ =~ /startup failed/, "startup hook exception closes the server and propagates";