ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-MCP/t/04_client.t
Revision: 1.10
Committed: Fri Oct 16 08:15:32 2026 UTC (45 hours, 58 minutes ago) by root
Content type: application/x-troff
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +19 -1 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 use common::sense;
2 root 1.2 # These tests and their subprocesses connect to private loopback listeners.
3     BEGIN { delete $ENV{http_proxy} }
4 root 1.1 use AnyEvent ();
5     use AnyEvent::Handle ();
6     use AnyEvent::Socket ();
7     use AnyEvent::MCP::Client::HTTP ();
8     use AnyEvent::MCP::Client::JSONL ();
9     use AnyEvent::MCP::Server::HTTP ();
10     use AnyEvent::MCP::Server::JSONL ();
11     use AnyEvent::MCP::Server::Toolset ();
12     use AnyEvent::MCP::Config ();
13     use JSON::XS ();
14     use File::Temp ();
15     use Socket;
16     use Scalar::Util qw(weaken);
17    
18 root 1.10 print "1..62\n";
19 root 1.1
20     my $test;
21     sub ok($$) {
22     my ($condition, $name) = @_;
23     print (($condition ? "ok " : "not ok "), ++$test, " - $name\n");
24     }
25    
26     sub wait_for {
27     my ($start) = @_;
28     my $cv = AnyEvent->condvar;
29 root 1.9 my $timer = AnyEvent->timer (after => 30, cb => sub { die "Client test timeout\n" });
30 root 1.1 $start->(sub { $cv->send ([@_]) });
31     @{$cv->recv}
32     }
33    
34     my $dir = File::Temp::tempdir (CLEANUP => 1);
35     local $ENV{XDG_CONFIG_HOME} = "$dir/config";
36     my $toolset = AnyEvent::MCP::Server::Toolset->new;
37     my $pending;
38     $toolset->tool (echo => "echo", {}, sub { $_[0]->result ($_[1]) });
39     $toolset->tool (slow => "slow", {}, sub { $pending = $_[0] });
40     $toolset->tool (fail => "fail", {}, sub { $_[0]->error ("tool failure") });
41    
42     my $server = AnyEvent::MCP::Server::HTTP->new (
43 root 1.6 toolsets => [$toolset], tokens => ["secret"],
44 root 1.1 );
45     $server->listen;
46     my $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url (0), bearer => "secret");
47     ok !-e "$dir/config", "unnamed server and client read no config";
48    
49     my ($success, $result) = wait_for (sub { $client->call (echo => { text => "hello" }, $_[0]) });
50     ok $success && $result->{structuredContent}{text} eq "hello", "modern HTTP tool call";
51     ok $client->{protocol_version} eq "2026-07-28", "modern discovery";
52     ok $client->{server_info}{name} eq "AnyEvent::MCP", "server identity";
53     ok ref $client->{server_capabilities}{tools} eq "HASH", "server capabilities";
54     ($success, $result) = wait_for (sub { $client->tools ($_[0]) });
55     ok $success && @$result == 3, "list tools";
56     ($success, $result) = wait_for (sub { $client->call (fail => {}, $_[0]) });
57     ok $success && $result->{isError}, "tool failure remains successful RPC";
58     ($success, $result) = wait_for (sub { $client->rpc ("unknown", {}, $_[0]) });
59     ok !$success && $result->{code} == -32601, "HTTP protocol error preserved";
60     ($success, $result) = wait_for (sub { $client->notify ("notifications/initialized", {}, $_[0]) });
61     ok $success, "HTTP notification";
62     $client->close;
63    
64     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
65     ($success, $result) = wait_for (sub { $client->call (echo => {}, $_[0]) });
66     ok $success, "URL cookie without header auth";
67     $client->close;
68     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url (0), bearer => "wrong");
69     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
70     ok !$success && $result->{transport} && $result->{message} =~ /401/, "wrong bearer fails";
71     $client->close;
72     $server->close;
73    
74 root 1.6 $server = AnyEvent::MCP::Server::HTTP->new (toolsets => [$toolset], tokens => ["alpha", "beta"]);
75 root 1.1 $server->listen;
76 root 1.6 $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url (0), bearer => "beta");
77 root 1.1 ($success, $result) = wait_for (sub { $client->call (echo => {}, $_[0]) });
78 root 1.6 ok $success, "second token accepted in Authorization header";
79 root 1.1 $client->close;
80     $server->close;
81     eval { AnyEvent::MCP::Client::HTTP->new (url => "http://localhost/", bearer => "token", username => "alice", password => "pw") };
82 root 1.6 ok $@ =~ /Basic authentication is unsupported/, "Basic credentials rejected even with bearer";
83 root 1.1 eval { AnyEvent::MCP::Client::HTTP->new (url => "http://localhost/", username => "alice") };
84 root 1.6 ok $@ =~ /Basic authentication is unsupported/, "Basic client credentials rejected";
85 root 1.1
86 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", toolsets => [$toolset], versions => ["2025-06-18"]);
87 root 1.1 $server->listen;
88     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
89     ($success, $result) = wait_for (sub { $client->call (echo => { value => 42 }, $_[0]) });
90     ok $success && $result->{structuredContent}{value} == 42, "legacy fallback tool call";
91     ok $client->{protocol_version} eq "2025-06-18", "negotiated legacy version";
92     ok $client->{server_info}{name} eq "AnyEvent::MCP", "legacy wire identity preserved";
93     $client->close;
94     $server->close;
95    
96 root 1.3 # Old dispatchers can return an internal error for an unknown discovery method.
97     my $discoveries = 0;
98 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none",
99 root 1.3 toolsets => [$toolset],
100     on_request => sub {
101     if ($_[1]{method} eq "server/discover") {
102     ++$discoveries;
103     die "Undefined discovery handler\n"
104     }
105     },
106     );
107     $server->listen;
108     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
109     ($success, $result) = wait_for (sub { $client->call (echo => { value => 42 }, $_[0]) });
110     ok $success && $result->{structuredContent}{value} == 42, "discovery internal error falls back to initialization";
111     ok $discoveries == 1 && $client->{protocol_version} eq "2025-11-25", "fallback negotiates legacy once";
112     $client->close;
113     $server->close;
114    
115 root 1.1 my $calls = 0;
116     my @input;
117 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", on_tools_call => sub {
118 root 1.1 my ($server, $req, $args) = @_;
119     ++$calls;
120     if (exists $req->{params}{inputResponses}) {
121     ok $req->{params}{requestState} eq "opaque", "request state echoed";
122     ok $req->{params}{inputResponses}{question}{content}{answer} == 42, "input answer echoed";
123     ok $args->{original} eq "keep", "original tool arguments preserved";
124     $req->result ({ answer => 42 });
125     } else {
126     $req->reply ({
127     resultType => "input_required", requestState => "opaque",
128     inputRequests => { question => {
129     method => "elicitation/create", params => { message => "question" },
130     } },
131     });
132     }
133     });
134     $server->listen;
135     $client = AnyEvent::MCP::Client::HTTP->new (
136     url => $server->url, client_capabilities => { elicitation => { form => {} } },
137     on_request => sub {
138     my ($client, $req) = @_;
139     push @input, $req;
140     $req->reply ({ action => "accept", content => { answer => 42 } });
141     },
142     );
143     ($success, $result) = wait_for (sub { $client->call (question => { original => "keep" }, $_[0]) });
144     ok $success && $result->{structuredContent}{answer} == 42, "modern input continuation";
145     ok $calls == 2 && @input == 1 && $input[0]{finished}, "input handled once";
146     ($success, $result) = wait_for (sub {
147     $client->rpc ("tools/call", { name => "question", arguments => {} }, $_[0]);
148     });
149     ok $success && $result->{resultType} eq "input_required" && @input == 1, "raw RPC preserves challenge";
150     $client->close;
151     $server->close;
152     @input = ();
153    
154     my $page = 0;
155 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", on_tools_list => sub {
156 root 1.1 $_[1]->reply ({ tools => [{ name => ++$page }], ($page == 1 ? (nextCursor => "second") : ()) });
157     });
158     $server->listen;
159     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
160     ($success, $result) = wait_for (sub { $client->tools ($_[0]) });
161     ok $success && @$result == 2 && $result->[1]{name} == 2, "tool pagination";
162     $server->{on_tools_list} = sub { $_[1]->reply ({ tools => [], nextCursor => "repeat" }) };
163     ($success, $result) = wait_for (sub { $client->tools ($_[0]) });
164     ok !$success && $result->{message} =~ /Repeated/, "pagination loop rejected";
165     $client->close;
166     $server->close;
167    
168     socketpair my $a, my $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
169     $server = AnyEvent::MCP::Server::JSONL->new (toolsets => [$toolset]);
170     $server->accept ($a);
171     $client = AnyEvent::MCP::Client::JSONL->new;
172     $client->attach ($b);
173     my @order;
174     ($success, $result) = wait_for (sub {
175     my $done = $_[0];
176     $client->call (slow => {}, sub { push @order, "slow"; $done->(@_) });
177     $client->rpc ("ping", {}, sub { push @order, "ping"; $pending->reply ({}); undef $pending });
178     });
179     ok $success && join (",", @order) eq "ping,slow", "JSONL replies can be out of order";
180    
181     my ($id, $cancelled, $completions);
182     $id = $client->call (slow => {}, sub { ++$completions; $cancelled = $_[1] });
183     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
184     $client->cancel ($id);
185     ok $completions == 1 && $cancelled->{cancelled}, "local cancellation once";
186     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
187     ok $pending->{cancelled}, "wire cancellation reaches server";
188     undef $pending;
189     $client->cancel ($id);
190     ok $completions == 1, "repeated cancellation ignored";
191    
192     $id = $client->call (slow => {}, sub { ++$completions; $cancelled = $_[1] });
193     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
194     $client->close;
195     ok $completions == 2 && $cancelled->{transport}, "close fails outstanding call";
196     $server->close;
197     undef $pending;
198    
199     $client = AnyEvent::MCP::Client::JSONL->new (
200     command => [$^X, "-Ilib", "-e", '
201     use AnyEvent::MCP::Server::Simple;
202     mcp_tool echo => "echo", {}, sub { $_[0]->result ($_[1]) };
203 root 1.4 mcp_start;
204 root 1.1 '],
205     env => { PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL => "stdio" },
206     );
207     ($success, $result) = wait_for (sub { $client->call (echo => { subprocess => 1 }, $_[0]) });
208     ok $success && $result->{structuredContent}{subprocess}, "direct subprocess command";
209     my $pid = $client->{pid};
210     $client->close;
211     ok !$client->{pid}, "close detaches child";
212     ($success, $result) = wait_for (sub { $client->call (echo => { restarted => 1 }, $_[0]) });
213     ok $success && $result->{structuredContent}{restarted} && $client->{pid} != $pid, "new call restarts child";
214     $client->close;
215    
216     # A real streaming response: progress arrives before the final event.
217     my ($sse_handle, $release, $listener, $port, $ended, $progress);
218     $listener = AnyEvent::Socket::tcp_server "127.0.0.1", 0, sub {
219     $sse_handle = AnyEvent::Handle->new (fh => $_[0], on_error => sub { die $_[2] });
220     $sse_handle->push_read (line => "\r\n\r\n", sub {
221     my ($handle, $header) = @_;
222     my ($length) = $header =~ /Content-Length: ([0-9]+)/i;
223     $handle->push_read (chunk => $length, sub {
224     my $msg = JSON::XS::decode_json $_[1];
225     my $first = "data: " . JSON::XS::encode_json ({
226     jsonrpc => "2.0", method => "notifications/progress", params => { progress => 1 },
227     }) . "\r\n\r\n";
228     my $last = "data: " . JSON::XS::encode_json ({
229     jsonrpc => "2.0", id => $msg->{id}, result => { resultType => "complete", streamed => 1 },
230     }) . "\r\n\r\n";
231     $handle->push_write (
232     "HTTP/1.1 200 OK\r\nContent-Type: text/event-stream\r\nConnection: close\r\n"
233     . "Content-Length: " . (length ($first) + length ($last)) . "\r\n\r\n"
234     . substr ($first, 0, 8)
235     );
236     $release = AnyEvent->timer (after => 0.02, cb => sub {
237     $handle->push_write (substr ($first, 8));
238     $release = AnyEvent->timer (after => 0.02, cb => sub {
239     $ended = 1;
240     $handle->push_write ($last);
241     });
242     });
243     });
244     });
245     }, sub { $port = $_[2]; () };
246     $client = AnyEvent::MCP::Client::HTTP->new (
247     url => "http://127.0.0.1:$port/", on_notification => sub {
248     $progress = $_[1] eq "notifications/progress" && !$ended;
249     },
250     );
251     $client->{connected} = 1;
252     $client->{protocol_version} = "2026-07-28";
253     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
254     ok $progress, "fragmented SSE progress delivered while streaming";
255     ok $success && $result->{streamed}, "SSE matching final response";
256     $client->close;
257     $sse_handle->destroy;
258     undef $release;
259     undef $listener;
260    
261     my $config = AnyEvent::MCP::Config->global;
262     $config->{section}{"client example"} = { url => "http://example.invalid/", bearer => "configured", timeout => 7 };
263     $client = AnyEvent::MCP::Client::HTTP->new (name => "example", timeout => 9);
264     ok $client->{url} eq "http://example.invalid/" && $client->{bearer} eq "configured", "named client defaults";
265     ok $client->{timeout} == 9, "explicit client option wins";
266     $client->close;
267     $client = AnyEvent::MCP::Client::HTTP->new (name => "example", bearer => undef);
268     ok !defined $client->{bearer}, "explicit undef disables named auth";
269     $client->close;
270    
271 root 1.8 $config->{section}{"instance example"} = { path => "/named/", tokens => "configured,secondary" };
272 root 1.5 $server = AnyEvent::MCP::Server::HTTP->new ($config->http_settings ("example"), port => 31740);
273 root 1.6 ok $server->{path} eq "/named/" && $server->{tokens}[0] eq "configured", "resolved named server settings";
274     ok @{$server->{tokens}} == 2 && $server->{tokens}[1] eq "secondary", "ordered configured tokens";
275     ok $server->url eq "http://127.0.0.1:31740/configured/named/", "first token is the advertised URL token";
276 root 1.1 $server->close;
277    
278     my $req = AnyEvent::MCP::Client::Request->new (client => $client, on_reply => sub {});
279     $req->reply ({});
280     eval { $req->reply ({}) };
281     ok $@ =~ /already finished/, "duplicate input reply dies";
282     my $dismissed = 0;
283     $req = AnyEvent::MCP::Client::Request->new (client => $client, on_cancel => sub { ++$dismissed }, on_reply => sub {});
284     $req->cancel;
285     $req->cancel;
286     ok $req->{cancelled} && $dismissed == 1, "cancel dismisses input once";
287    
288     # Pending operations must not keep the client alive through its own callbacks.
289     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
290     $server = AnyEvent::MCP::Server::JSONL->new (toolsets => [$toolset]);
291     $server->accept ($a);
292     $client = AnyEvent::MCP::Client::JSONL->new;
293     $client->attach ($b);
294     my $released;
295     $client->call (slow => {}, sub { $released = $_[1] });
296     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
297     my $weak = $client;
298     weaken $weak;
299     undef $client;
300     ok !defined $weak && $released->{transport}, "dropping pending client releases it and fails callback";
301     $server->close;
302     undef $pending;
303    
304 root 1.10 # A close callback must still know which operations were interrupted, even
305     # though ordinary request callbacks have already been failed.
306     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
307     $server = AnyEvent::MCP::Server::JSONL->new (toolsets => [$toolset]);
308     $server->accept ($a);
309     $client = AnyEvent::MCP::Client::JSONL->new;
310     $client->attach ($b);
311     my $interrupted;
312     $client->call (slow => {}, sub { $interrupted = $_[1] });
313     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
314     my $close_error;
315     $client->{on_close} = sub { $close_error = $_[1] };
316     $client->close ("simulated broken stream");
317     ok $close_error->{pending} == 1 && $interrupted->{transport},
318     "close reports the interrupted operation count after failing callbacks";
319     $server->close;
320     undef $pending;
321    
322 root 1.1 socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
323     $server = AnyEvent::MCP::Server::JSONL->new (toolsets => [$toolset]);
324     $server->accept ($a);
325     $client = AnyEvent::MCP::Client::JSONL->new (request_timeout => 0.02);
326     $client->attach ($b);
327     ($success, $result) = wait_for (sub { $client->call (slow => {}, $_[0]) });
328     ok !$success && $result->{cancelled} && $result->{message} =~ /timed out/, "overall request deadline";
329     $client->close;
330     $server->close;
331     undef $pending;
332    
333     # Keep an asynchronous input prompt open, then cancel its originating call.
334     my $prompt;
335 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", on_tools_call => sub {
336 root 1.1 $_[1]->reply ({
337     resultType => "input_required", requestState => "opaque",
338     inputRequests => { q => { method => "elicitation/create", params => {} } },
339     });
340     });
341     $server->listen;
342     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
343     ($success, $result) = wait_for (sub { $client->call (question => {}, $_[0]) });
344     ok !$success && $result->{message} =~ /without a client handler/, "no implicit input approval";
345     my $prompt_ready;
346     my $dismiss = 0;
347     $client->{on_request} = sub {
348     $prompt = $_[1];
349     $prompt->{on_cancel} = sub { ++$dismiss };
350     $prompt_ready->();
351     };
352     ($success, $result) = wait_for (sub {
353     $prompt_ready = $_[0];
354     $id = $client->call (question => {}, sub { $cancelled = $_[1] });
355     });
356     $client->cancel ($id);
357     ok $prompt->{cancelled} && $dismiss == 1 && $cancelled->{cancelled}, "cancelling call dismisses asynchronous prompt";
358     $client->close;
359     $server->close;
360     undef $prompt;
361    
362     # Modern tool-name headers must encode non-ASCII names.
363     my $unicode = "echo-" . chr 0x3bb;
364 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", on_tools_call => sub {
365 root 1.1 $_[1]->result ({ name => $_[1]{tool} });
366     });
367     $server->listen;
368     $client = AnyEvent::MCP::Client::HTTP->new (url => $server->url);
369     ($success, $result) = wait_for (sub { $client->call ($unicode, {}, $_[0]) });
370     ok $success && $result->{structuredContent}{name} eq $unicode, "Unicode Mcp-Name header";
371     $client->close;
372     $server->close;
373    
374     # Two asynchronous answers can arrive in any order; continuation happens once.
375     my $rounds = 0;
376 root 1.7 $server = AnyEvent::MCP::Server::HTTP->new (auth => "none", on_tools_call => sub {
377 root 1.1 my ($server, $req) = @_;
378     ++$rounds;
379     if ($req->{params}{inputResponses}) {
380     $req->result ({ inputs => $req->{params}{inputResponses} });
381     } else {
382     $req->reply ({
383     resultType => "input_required", inputRequests => {
384     a => { method => "elicitation/create", params => {} },
385     b => { method => "elicitation/create", params => {} },
386     },
387     });
388     }
389     });
390     $server->listen;
391     my %prompts;
392     $client = AnyEvent::MCP::Client::HTTP->new (
393     url => $server->url, on_request => sub {
394     $prompts{$_[1]{id}} = $_[1];
395     if (keys %prompts == 2) {
396     $prompts{b}->reply ({ action => "decline" });
397     $prompts{a}->reply ({ action => "accept" });
398     }
399     },
400     );
401     ($success, $result) = wait_for (sub { $client->call (question => {}, $_[0]) });
402     ok $success && $rounds == 2, "multiple input answers produce one continuation";
403     ok $result->{structuredContent}{inputs}{a}{action} eq "accept"
404     && $result->{structuredContent}{inputs}{b}{action} eq "decline", "input keys and decisions preserved";
405     $client->close;
406     $server->close;
407     %prompts = ();
408    
409 root 1.6 # Named token settings authenticate either by bearer header or URL path.
410     $server = AnyEvent::MCP::Server::HTTP->new ($config->http_settings ("example"));
411 root 1.1 $server->listen;
412     $client = AnyEvent::MCP::Client::HTTP->new (
413 root 1.6 url => $server->url (0), bearer => "secondary",
414 root 1.1 );
415     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
416 root 1.6 ok $success, "second configured token authenticates";
417 root 1.1 $client->close;
418     $client = AnyEvent::MCP::Client::HTTP->new (
419 root 1.6 url => $server->url (0), bearer => "unlisted",
420 root 1.1 );
421     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
422 root 1.6 ok !$success && $result->{message} =~ /401/, "unlisted token rejected";
423 root 1.1 $client->close;
424     $server->close;
425    
426     my $exit_cv = AnyEvent->condvar;
427 root 1.9 my $reap_poll = AnyEvent->timer (after => 0, interval => 0.02, cb => sub {
428     $exit_cv->send (1) unless kill 0 => $pid;
429     });
430     my $reap_timeout = AnyEvent->timer (after => 30, cb => sub { $exit_cv->send (0) });
431     ok $exit_cv->recv && waitpid ($pid, 1) == -1, "subprocess child was reaped";
432     undef $reap_poll;
433     undef $reap_timeout;
434 root 1.1 eval { AnyEvent::MCP::Client::HTTP->new (url => "http://localhost/", bearer => "bad\nheader") };
435     ok $@ =~ /Invalid bearer/, "credential header injection rejected";
436    
437     # A legacy session ID belongs to initialization and must accompany later POSTs.
438     my (@http_handles, $initializations, $session_header);
439     $listener = AnyEvent::Socket::tcp_server "127.0.0.1", 0, sub {
440     my $handle = AnyEvent::Handle->new (
441     fh => $_[0], on_error => sub { $_[0]->destroy }, on_eof => sub { $_[0]->destroy },
442     );
443     push @http_handles, $handle;
444     $handle->push_read (line => "\r\n\r\n", sub {
445     my ($handle, $header) = @_;
446     my ($length) = $header =~ /Content-Length: ([0-9]+)/i;
447     $handle->push_read (chunk => $length, sub {
448     my $msg = JSON::XS::decode_json $_[1];
449     my ($status, $extra, $body) = ("202 Accepted", "", "");
450     if ($msg->{method} eq "initialize") {
451     ++$initializations;
452     $status = "200 OK";
453     $extra = "Mcp-Session-Id: test-session\r\n";
454     $body = JSON::XS::encode_json ({
455     jsonrpc => "2.0", id => $msg->{id}, result => {
456     protocolVersion => "2025-06-18", capabilities => {},
457     serverInfo => { name => "legacy", version => "0" },
458     },
459     });
460     } elsif ($msg->{method} eq "ping") {
461     $session_header = $header =~ /Mcp-Session-Id: test-session/i;
462     $status = "404 Not Found";
463     }
464     $handle->push_write (
465     "HTTP/1.1 $status\r\nContent-Type: application/json\r\n"
466     . $extra . "Content-Length: " . length ($body) . "\r\nConnection: close\r\n\r\n$body"
467     );
468     });
469     });
470     }, sub { $port = $_[2]; () };
471     $client = AnyEvent::MCP::Client::HTTP->new (
472     url => "http://127.0.0.1:$port/", versions => ["2025-06-18"],
473     );
474     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
475     ok !$success && $result->{message} =~ /session expired/ && !$client->{connected}, "session expiry invalidates client";
476     ok $session_header && $initializations == 1, "session header retained without retry";
477     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
478     ok !$success && $initializations == 2, "later operation creates a fresh session";
479     $client->close;
480     $_->destroy for @http_handles;
481     @http_handles = ();
482     undef $listener;
483    
484     my $sent = 0;
485     $listener = AnyEvent::Socket::tcp_server "127.0.0.1", 0, sub {
486     my $handle = AnyEvent::Handle->new (
487     fh => $_[0], on_error => sub { $_[0]->destroy }, on_eof => sub { $_[0]->destroy },
488     );
489     push @http_handles, $handle;
490     $handle->push_read (line => "\r\n\r\n", sub {
491     ++$sent;
492     $_[0]->destroy;
493     });
494     }, sub { $port = $_[2]; () };
495     $client = AnyEvent::MCP::Client::HTTP->new (url => "http://127.0.0.1:$port/");
496     $client->{connected} = 1;
497     $client->{protocol_version} = "2026-07-28";
498     ($success, $result) = wait_for (sub { $client->call (change => {}, $_[0]) });
499     ok !$success && $result->{transport} && $sent == 1, "broken HTTP tool call is not replayed";
500     $client->close;
501     $_->destroy for @http_handles;
502     @http_handles = ();
503     undef $listener;
504    
505     my ($redirect_target, $redirect_port, $redirected);
506     $redirect_target = AnyEvent::Socket::tcp_server "127.0.0.1", 0, sub {
507     ++$redirected;
508     close $_[0];
509     }, sub { $redirect_port = $_[2]; () };
510     $listener = AnyEvent::Socket::tcp_server "127.0.0.1", 0, sub {
511     my $handle = AnyEvent::Handle->new (
512     fh => $_[0], on_error => sub { $_[0]->destroy }, on_eof => sub { $_[0]->destroy },
513     );
514     push @http_handles, $handle;
515     $handle->push_read (line => "\r\n\r\n", sub {
516     $_[0]->push_write (
517     "HTTP/1.1 302 Found\r\nContent-Length: 0\r\nConnection: close\r\n"
518     . "Location: http://127.0.0.1:$redirect_port/\r\n\r\n"
519     );
520     });
521     }, sub { $port = $_[2]; () };
522     $client = AnyEvent::MCP::Client::HTTP->new (url => "http://127.0.0.1:$port/", bearer => "secret");
523     $client->{connected} = 1;
524     $client->{protocol_version} = "2026-07-28";
525     ($success, $result) = wait_for (sub { $client->rpc ("ping", {}, $_[0]) });
526     ok !$success && !$redirected && $result->{message} =~ /302/, "redirect does not forward credentials";
527     $client->close;
528     $_->destroy for @http_handles;
529     undef $listener;
530     undef $redirect_target;