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::Server::Permissions ();
use AnyEvent::MCP::Config ();
use File::Temp ();
use IPC::Open3 ();
use Symbol ();
use JSON::XS ();
use MIME::Base64 ();
use Socket;

print "1..35\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 => 30, 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} = "[::1]";
ok $server->url eq "https://[::1]:31740/mcp/", "prebracketed IPv6 URL host is not bracketed twice";
$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";

{
   local @ARGV = ("--auto-deny=*,write", "--auto-allow=read_lines,read",
      "--auto-deny=*,*,*");
   my %options = mcp_getoptions ({ name => "auto-test" });
   is_deeply $options{auto_rules}, [
      ["deny", "*,write"], ["allow", "read_lines,read"], ["deny", "*,*,*"],
   ], "CLI collects repeatable allow/deny rules in original order";

   my $perm = AnyEvent::MCP::Server::Permissions->new (
      rules => [{ decision => "deny", action => "^" }],
   );
   my $timer;
   mcp_http %options, auth => "none", port => 0, permissions => $perm,
      on_start => sub {
         my ($server) = @_;
         $timer = AnyEvent->timer (after => 0.01, cb => sub { $server->close });
      };
   my $call = { action => "read", sandbox_grants => [], reason => "test" };
   is $perm->check ($call, "read-lines")->{decision}, "allow",
      "Simple starter installs ordered allow rule";
   is $perm->check ({ %$call, action => "write" }, "read-lines")->{decision}, "deny",
      "earlier auto-deny takes precedence over later allow";
   is $perm->check ($call, "exec")->{decision}, "deny",
      "later wildcard deny catches unmatched tools";

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