ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-MCP/t/01_server.t
Revision: 1.15
Committed: Tue Oct 27 21:33:37 2026 UTC (36 hours, 43 minutes ago) by root
Content type: application/x-troff
Branch: MAIN
CVS Tags: HEAD
Changes since 1.14: +17 -9 lines
Log Message: 
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 use common::sense;
2     use Test::More;
3     use AnyEvent ();
4     use AnyEvent::Handle ();
5     use AnyEvent::MCP::Server ();
6     use AnyEvent::MCP::Server::Toolset ();
7     use AnyEvent::MCP::Server::JSONL ();
8     use AnyEvent::MCP::Server::HTTP ();
9     use JSON::XS ();
10     use Socket;
11    
12     my $toolset = AnyEvent::MCP::Server::Toolset->new;
13     my $pending;
14 root 1.15 my $on_slow;
15 root 1.1
16     $toolset->tool (echo => "echo", {}, sub { $_[0]->result ($_[1]) });
17 root 1.15 $toolset->tool (slow => "slow", {}, sub { $pending = $_[0]; $on_slow->() if $on_slow });
18 root 1.1 $toolset->tool (fail => "fail", {}, sub { die "tool failed\n" });
19    
20     my $server = AnyEvent::MCP::Server->new (toolsets => [$toolset]);
21     my $meta = {
22     "io.modelcontextprotocol/protocolVersion" => "2026-07-28",
23     "io.modelcontextprotocol/clientCapabilities" => {},
24     };
25    
26     sub message {
27     my ($id, $method, $params) = @_;
28    
29     { jsonrpc => "2.0", id => $id, method => $method, params => { %{$params || {}}, _meta => {%$meta} } }
30     }
31    
32     my $response;
33 root 1.3 for my $id (1, 0, -1, 1.5, "1", "opaque") {
34     for my $method ("ping", "unknown") {
35     my $json = JSON::XS::encode_json ({
36     jsonrpc => "2.0", id => $id, method => $method, params => {},
37     });
38     $server->json_rpc ($json, sub { $response = shift }, protocol_version => "2025-11-25");
39     is JSON::XS::encode_json ([JSON::XS::decode_json ($response)->{id}]),
40     JSON::XS::encode_json ([$id]), "wire ID type preserved for $method";
41     }
42     }
43     $server->json_rpc (
44     '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"protocolVersion":"2025-11-25","capabilities":{},"clientInfo":{"name":"probe","version":"0"}}}',
45     sub { $response = shift },
46     );
47     like $response, qr/"id":1(?:,|})/, "initialization preserves numeric probe ID";
48    
49 root 1.1 $server->rpc (message (1, "server/discover"), sub { $response = shift });
50     is $response->{result}{resultType}, "complete", "modern result type";
51     is $response->{result}{supportedVersions}[0], "2026-07-28", "discovery";
52     is $response->{result}{_meta}{"io.modelcontextprotocol/serverInfo"}{name}, "AnyEvent::MCP", "server identity";
53    
54 root 1.9 for my $value (undef, "", " \n \t \n") {
55     my $empty = AnyEvent::MCP::Server->new (instructions => $value);
56     $empty->rpc (message (101, "server/discover"), sub { $response = shift });
57     ok !exists $response->{result}{instructions},
58     "server/discover omits empty normalized instructions";
59     $empty->rpc (message (102, "initialize", {
60     protocolVersion => "2025-11-25", capabilities => {},
61     clientInfo => { name => "probe", version => "0" },
62     }), sub { $response = shift });
63     ok !exists $response->{result}{instructions},
64     "initialize omits empty normalized instructions";
65     }
66     my $guidance = AnyEvent::MCP::Server->new (instructions => " \n keep this\n ");
67     $guidance->rpc (message (103, "server/discover"), sub { $response = shift });
68     is $response->{result}{instructions}, "keep this",
69     "nonempty instructions still normalize and survive discovery";
70    
71 root 1.14 my $hint = "Full instructions: meta-instructions tool description.";
72 root 1.13 my $shared = AnyEvent::MCP::Server::Toolset->new;
73     my $auto = AnyEvent::MCP::Server->new (
74     toolsets => [$shared],
75     instructions => " Full operating rules. ",
76     short_instructions => " Find tools when useful. ",
77     custom_instructions => " Use for persistent memory. ",
78     auto_instructions => 1,
79     );
80     $auto->rpc (message (106, "server/discover"), sub { $response = shift });
81 root 1.14 is $response->{result}{instructions}, "Use for persistent memory.\n\nFind tools when useful.\n\n$hint",
82 root 1.13 "auto instructions advertise custom purpose and short guidance";
83     $auto->rpc (message (107, "initialize", {
84     protocolVersion => "2025-11-25", capabilities => {},
85     clientInfo => { name => "probe", version => "0" },
86     }), sub { $response = shift });
87 root 1.14 is $response->{result}{instructions}, "Use for persistent memory.\n\nFind tools when useful.\n\n$hint",
88 root 1.13 "legacy initialization gets short instructions too";
89     $auto->rpc (message (108, "tools/list"), sub { $response = shift });
90     my ($meta_tool) = grep $_->{name} eq "meta-instructions", @{$response->{result}{tools}};
91     like $meta_tool->{description}, qr/Use for persistent memory\..*Full operating rules\./s,
92     "instance purpose precedes full instructions in generated tool description";
93     $auto->rpc (message (109, "tools/call", { name => "meta-instructions" }), sub { $response = shift });
94     is $response->{result}{content}[0]{text}, "Use for persistent memory.\n\nFull operating rules.",
95     "generated tool returns full effective instructions";
96     ok !@{$shared->list}, "generated tool does not mutate caller toolsets";
97    
98     my $custom_only = AnyEvent::MCP::Server->new (
99     instructions => "Details", custom_instructions => "Memory", auto_instructions => 1,
100     );
101     $custom_only->rpc (message (110, "server/discover"), sub { $response = shift });
102 root 1.14 is $response->{result}{instructions}, "Memory\n\n$hint",
103     "custom purpose can replace generic short instructions";
104    
105     my $short_only = AnyEvent::MCP::Server->new (
106     instructions => "Details", short_instructions => "Discover tools", auto_instructions => 1,
107     );
108     $short_only->rpc (message (113, "server/discover"), sub { $response = shift });
109     is $response->{result}{instructions}, "Discover tools\n\n$hint",
110     "short instructions also receive the standard pointer";
111    
112     my $fallback = AnyEvent::MCP::Server->new (instructions => "Details", auto_instructions => 1);
113     $fallback->rpc (message (114, "server/discover"), sub { $response = shift });
114     is $response->{result}{instructions}, "Details",
115     "no redundant pointer when advertising full instructions as fallback";
116 root 1.13
117     my $disabled = AnyEvent::MCP::Server->new (
118     instructions => "Details", short_instructions => "Short", auto_instructions => 0,
119     );
120     $disabled->rpc (message (111, "server/discover"), sub { $response = shift });
121     is $response->{result}{instructions}, "Details", "low-level default opt-out keeps full instructions";
122     $disabled->rpc (message (112, "tools/list"), sub { $response = shift });
123     ok !(grep $_->{name} eq "meta-instructions", @{$response->{result}{tools}}),
124     "opt-out creates no meta tool";
125    
126     my $collision = AnyEvent::MCP::Server::Toolset->new;
127     $collision->tool (meta_instructions => "existing", {}, sub { $_[0]->reply ({}) });
128     eval { AnyEvent::MCP::Server->new (toolsets => [$collision], instructions => "Details", auto_instructions => 1) };
129     like $@, qr/duplicate MCP tool 'meta-instructions'/, "reserved tool name collision fails";
130    
131 root 1.10 my $aemcp_caps = { extensions => { "anyevent-mcp/multibroker" => { version => 1 } } };
132     my $legacy_peer = {};
133     $server->rpc ({
134     jsonrpc => "2.0", id => 104, method => "initialize",
135     params => { protocolVersion => "2025-11-25", capabilities => $aemcp_caps,
136     clientInfo => { name => "broker", version => "1" } },
137     }, sub { $response = shift }, peer => $legacy_peer);
138     ok $legacy_peer->{aemcp_multibroker}, "legacy initialization negotiates multibroker extension";
139     my $modern_peer = {};
140     my $modern_discover = message (105, "server/discover");
141     $modern_discover->{params}{_meta}{"io.modelcontextprotocol/clientCapabilities"} = $aemcp_caps;
142     $server->rpc ($modern_discover, sub { $response = shift }, peer => $modern_peer);
143     ok $modern_peer->{aemcp_multibroker},
144     "modern discovery negotiates multibroker extension from per-request capabilities";
145    
146 root 1.1 my $request = $server->rpc (message (2, "tools/call", { name => "echo", arguments => { a => 42 } }),
147     sub { $response = shift });
148     is $response->{result}{structuredContent}{a}, 42, "structured result";
149     is JSON::XS::decode_json ($response->{result}{content}[0]{text})->{a}, 42, "JSON text fallback";
150     ok !exists $request->{on_reply} && !exists $request->{_reply}, "release reply callbacks";
151     eval { $request->reply ({}) };
152     like $@, qr/already finished/, "duplicate reply dies";
153    
154     $server->rpc (message (3, "tools/call", { name => "fail" }), sub { $response = shift });
155     ok $response->{result}{isError}, "tool exception is a tool error";
156     is $response->{result}{content}[0]{text}, "tool failed\n", "tool exception text";
157    
158     $server->rpc (message (4, "tools/call", { name => "absent" }), sub { $response = shift });
159     is $response->{error}{code}, -32602, "unknown tool is a protocol error";
160     $server->rpc (message (5, "unknown"), sub { $response = shift });
161     is $response->{error}{code}, -32601, "unknown method";
162     $server->json_rpc ("{", sub { $response = JSON::XS::decode_json shift });
163     is $response->{error}{code}, -32700, "parse error";
164     $server->rpc ([], sub { $response = shift });
165     is $response->{error}{code}, -32600, "reject batches";
166     $server->rpc (message (6, "tools/call", { name => "echo", arguments => [] }), sub { $response = shift });
167     is $response->{error}{code}, -32602, "invalid arguments";
168    
169     my $unsupported = message (7, "ping");
170     $unsupported->{params}{_meta}{"io.modelcontextprotocol/protocolVersion"} = "2099-01-01";
171     $server->rpc ($unsupported, sub { $response = shift });
172     is $response->{error}{code}, -32022, "unsupported version";
173     is $response->{error}{data}{requested}, "2099-01-01", "requested version in error";
174    
175     my $peer = {};
176     $server->rpc ({
177     jsonrpc => "2.0", id => 8, method => "initialize",
178     params => { protocolVersion => "2025-06-18", capabilities => {}, clientInfo => { name => "test", version => "0" } },
179     }, sub { $response = shift }, peer => $peer);
180     is $response->{result}{protocolVersion}, "2025-06-18", "legacy initialization";
181     ok !exists $response->{result}{resultType}, "legacy result shape";
182     $server->rpc ({ jsonrpc => "2.0", id => 9, method => "tools/call", params => { name => "echo" } },
183     sub { $response = shift }, peer => $peer);
184     is_deeply $response->{result}{structuredContent}, {}, "omitted arguments";
185     $server->rpc (message (10, "ping"), sub { $response = shift }, peer => $peer);
186     is $response->{result}{resultType}, "complete", "modern metadata overrides legacy peer";
187 root 1.2 is $peer->{protocol_version}, "2025-06-18", "modern request does not alter legacy state";
188 root 1.1
189 root 1.11 my @cancel_responses;
190 root 1.1 $request = $server->rpc (message (11, "tools/call", { name => "slow" }),
191 root 1.11 sub { push @cancel_responses, $_[0] }, peer => $peer);
192 root 1.1 my $cancels = 0;
193     $request->{on_cancel} = sub { ++$cancels };
194     $server->rpc ({ jsonrpc => "2.0", method => "notifications/cancelled", params => { requestId => 11 } },
195     sub { ok !defined $_[0], "notification has no JSON-RPC response" }, peer => $peer);
196     ok $request->{cancelled}, "cancellation";
197 root 1.11 is_deeply \@cancel_responses, [undef],
198     "cancellation completes the transport without a JSON-RPC response";
199 root 1.1 $request->cancel;
200     is $cancels, 1, "cancel callback once";
201 root 1.11 is scalar @cancel_responses, 1, "cancelled transport completes once";
202 root 1.1 eval { $request->reply ({}) };
203     like $@, qr/already finished/, "reply after cancellation dies";
204     $pending = undef;
205    
206     my @notifications;
207     $request = AnyEvent::MCP::Server::Request->new (
208     params => { _meta => { progressToken => 0 } },
209     on_notify => sub { push @notifications, $_[2] },
210     );
211     $request->progress (1);
212     is $notifications[0]{progressToken}, 0, "zero progress token";
213     $request->reply ({});
214     $request->progress (2);
215     is scalar @notifications, 1, "late progress ignored";
216    
217     my $custom = AnyEvent::MCP::Server->new (
218     on_tools_call => sub {
219     my ($server, $req, $args) = @_;
220     is $args, $req->{args}, "custom dispatch receives same arguments";
221     $req->error ("custom error");
222     },
223     );
224     $custom->rpc (message (12, "tools/call", { name => "custom" }), sub { $response = shift });
225     is $response->{result}{content}[0]{text}, "custom error", "dispatch override";
226    
227     socketpair my $a, my $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
228     my $jsonl = AnyEvent::MCP::Server::JSONL->new (toolsets => [$toolset]);
229     $jsonl->accept ($a);
230     my $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
231     my $cv = AnyEvent->condvar;
232 root 1.12 my $timer = AnyEvent->timer (after => 30, cb => sub { die "JSONL timeout" });
233 root 1.1
234     $client->push_write (
235     JSON::XS::encode_json (message (20, "tools/call", { name => "slow" })) . "\n"
236     . JSON::XS::encode_json (message (21, "ping")) . "\n"
237     );
238     $client->push_read (line => sub {
239 root 1.3 like $_[1], qr/"id":21(?:,|})/, "JSONL preserves numeric ID";
240 root 1.1 is JSON::XS::decode_json ($_[1])->{id}, 21, "JSONL out-of-order reply";
241     $pending->reply ({});
242     $pending = undef;
243     });
244     $client->push_read (line => sub {
245     is JSON::XS::decode_json ($_[1])->{id}, 20, "delayed JSONL reply";
246     $cv->send;
247     });
248     $cv->recv;
249     undef $timer;
250     $jsonl->close;
251     $client->destroy;
252    
253     sub post {
254     my ($msg, $extra) = @_;
255    
256     my $body = JSON::XS::encode_json $msg;
257     "POST /mcp/ HTTP/1.1\r\nContent-Type: application/json\r\nContent-Length: " . length ($body)
258     . "\r\nMCP-Protocol-Version: 2026-07-28\r\nMcp-Method: $msg->{method}\r\n"
259     . ($msg->{method} eq "tools/call" ? "Mcp-Name: $msg->{params}{name}\r\n" : "")
260     . ($extra || "") . "\r\n$body"
261     }
262    
263     sub http_read {
264     my ($handle, $callback) = @_;
265    
266     $handle->push_read (line => "\r\n\r\n", sub {
267     my ($handle, $header) = @_;
268     my ($length) = $header =~ /Content-Length: ([0-9]+)/;
269    
270     $handle->push_read (chunk => $length, sub { $callback->($header, $_[1]) });
271     });
272     }
273    
274 root 1.7 my $headers = AnyEvent::MCP::Server::HTTP::_parse_request_headers (
275     "POST /mcp/ HTTP/1.1\r\nmCp-MeThOd: ping\r\n"
276     . "Mcp-Param-Region: a\r\nmcp-param-region: b\r\n"
277 root 1.8 . "X-Value: one:two\r\nEmpty:\r\n"
278     . "Method: DELETE\r\nUri: /wrong\r\nHttp_Version: 0.0"
279 root 1.7 );
280 root 1.8 is $headers->{method}, "POST", "HTTP parser reads request method";
281     is $headers->{uri}, "/mcp/", "HTTP parser reads request target";
282     is $headers->{http_version}, "1.1", "HTTP parser reads request protocol";
283     is $headers->{"mcp-method"}, "ping", "HTTP parser normalizes header case";
284     is $headers->{"mcp-param-region"}, "a,b", "HTTP parser comma-combines repeated fields";
285     is $headers->{"x-value"}, "one:two", "HTTP parser preserves colons in values";
286     is $headers->{empty}, "", "HTTP parser accepts empty field values";
287     is $headers->{method}, "POST", "header cannot override request method";
288     is $headers->{uri}, "/mcp/", "header cannot override request URI";
289     is $headers->{http_version}, "1.1", "header cannot override HTTP version";
290 root 1.7 my $ows = AnyEvent::MCP::Server::HTTP::_parse_request_headers (
291     "POST /mcp/ HTTP/1.0\r\nContent-Length: \t42 \t"
292     );
293 root 1.8 is $ows->{http_version}, "1.0", "HTTP parser accepts legacy HTTP/1.0";
294     is $ows->{"content-length"}, "42", "HTTP parser strips optional whitespace";
295 root 1.7 my $future = AnyEvent::MCP::Server::HTTP::_parse_request_headers (
296     "POST /mcp/ HTTP/1.9\r\nContent-Length: 0"
297     );
298 root 1.8 is $future->{http_version}, "1.9",
299 root 1.7 "HTTP parser accepts future HTTP/1.x minor versions";
300     my $leading_zeroes = AnyEvent::MCP::Server::HTTP::_parse_request_headers (
301     "POST /mcp/ http/01.09\r\nContent-Length: 0"
302     );
303 root 1.8 is $leading_zeroes->{http_version}, "1.09",
304 root 1.7 "HTTP parser follows AnyEvent::HTTP version recognition and normalizes major version";
305     ok !AnyEvent::MCP::Server::HTTP::_parse_request_headers (
306     "POST /mcp/ HTTP/1.1\r\nX-Value: a\x00b"
307     ), "HTTP parser rejects control bytes in field values";
308     ok !AnyEvent::MCP::Server::HTTP::_parse_request_headers (
309     "POST /mcp/ HTTP/2.0\r\nHost: example"
310     ), "HTTP parser rejects unsupported request version";
311     ok !AnyEvent::MCP::Server::HTTP::_parse_request_headers (
312     "POST /mcp/ HTTP/1.1\r\nBad Header: value"
313     ), "HTTP parser rejects malformed field names";
314     ok !AnyEvent::MCP::Server::HTTP::_parse_request_headers (
315     "POST /mcp/ HTTP/1.1\r\nMcp-Method: ping\r\n continued"
316     ), "HTTP parser rejects obsolete folded headers";
317    
318 root 1.1 socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
319 root 1.6 my $http = AnyEvent::MCP::Server::HTTP->new (auth => "none", toolsets => [$toolset]);
320 root 1.1 $http->accept ($a);
321     $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
322     $cv = AnyEvent->condvar;
323 root 1.12 $timer = AnyEvent->timer (after => 30, cb => sub { die "HTTP timeout" });
324 root 1.15 my $release;
325     $on_slow = sub {
326     $release = AnyEvent->timer (after => 0.01, cb => sub {
327     $pending->reply ({});
328     $pending = undef;
329     });
330     };
331 root 1.1
332     $client->push_write (
333 root 1.8 post (message (30, "tools/call", { name => "slow" }),
334     "Method: DELETE\r\nUri: /not-mcp/\r\nHttp_Version: 0.0\r\n")
335 root 1.1 . post (message (31, "ping"))
336     );
337     http_read ($client, sub {
338     like $_[0], qr/HTTP\/1.1 200 OK/, "HTTP status";
339 root 1.3 like $_[1], qr/"id":30(?:,|})/, "HTTP preserves numeric ID";
340 root 1.1 is JSON::XS::decode_json ($_[1])->{id}, 30, "HTTP first reply";
341     http_read ($client, sub {
342     is JSON::XS::decode_json ($_[1])->{id}, 31, "HTTP pipelined reply order";
343     $cv->send;
344     });
345     });
346     $cv->recv;
347     undef $timer;
348     undef $release;
349 root 1.15 undef $on_slow;
350 root 1.1 $http->close;
351     $client->destroy;
352    
353 root 1.7 # An unknown future 1.x minor version must still use persistent HTTP framing.
354     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
355     $http = AnyEvent::MCP::Server::HTTP->new (auth => "none", toolsets => [$toolset]);
356     $http->accept ($a);
357     $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
358     $cv = AnyEvent->condvar;
359 root 1.12 $timer = AnyEvent->timer (after => 30, cb => sub { die "HTTP/1.9 timeout" });
360 root 1.7 my $future_requests = post (message (32, "ping")) . post (message (33, "ping"));
361     $future_requests =~ s{HTTP/1\.1}{HTTP/1.9}g;
362     $client->push_write ($future_requests);
363     http_read ($client, sub {
364     like $_[0], qr{HTTP/1.1 200 OK}, "HTTP/1.9 request accepted";
365     is JSON::XS::decode_json ($_[1])->{id}, 32, "first future-version response";
366     http_read ($client, sub {
367     is JSON::XS::decode_json ($_[1])->{id}, 33,
368     "future HTTP/1.x minor versions preserve persistent connections";
369     $cv->send;
370     });
371     });
372     $cv->recv;
373     undef $timer;
374     $http->close;
375     $client->destroy;
376    
377 root 1.6 $http = AnyEvent::MCP::Server::HTTP->new (auth => "none", toolsets => [$toolset], origins => []);
378 root 1.1 for my $case (
379     ["Origin: https://invalid.example\r\n", 403, undef],
380     ["Mcp-Method: different\r\n", 400, -32020],
381 root 1.7 ["Content-Length: 0\r\n", 400, undef],
382     ["Content-Length: 999\r\n", 400, undef],
383     ["Transfer-Encoding: chunked\r\n", 400, undef],
384     ["Not A Header\r\n", 400, undef],
385 root 1.1 ) {
386     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
387     $http->accept ($a);
388     $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
389     $cv = AnyEvent->condvar;
390 root 1.12 $timer = AnyEvent->timer (after => 30, cb => sub { die "HTTP rejection timeout" });
391 root 1.1
392     $client->push_write (post (message (40, "ping"), $case->[0]));
393     http_read ($client, sub {
394     like $_[0], qr/HTTP\/1.1 $case->[1]/, "HTTP rejection";
395     is JSON::XS::decode_json ($_[1])->{error}{code}, $case->[2], "HTTP protocol error"
396     if defined $case->[2];
397     $cv->send;
398     });
399     $cv->recv;
400     undef $timer;
401     $http->close;
402     $client->destroy;
403     }
404    
405 root 1.3 for my $case (
406 root 1.4 [undef, "https://browser.example", "POST", 200, "*", 1],
407     [undef, "https://browser.example", "OPTIONS", 204, "*", 0],
408 root 1.3 [["*"], "https://browser.example", "POST", 200, "*", 1],
409     [["https://browser.example"], "https://browser.example", "POST", 200, "https://browser.example", 1],
410     [["https://browser.example"], "https://other.example", "POST", 403, undef, 1],
411     [["*"], "https://browser.example", "OPTIONS", 204, "*", 0],
412     [[], "https://browser.example", "OPTIONS", 403, undef, 0],
413     [[], undef, "OPTIONS", 405, undef, 0],
414     [["*"], "https://browser.example", "POST", 401, "*", 0],
415     ) {
416     my ($origins, $origin, $method, $status, $allowed, $cookie) = @$case;
417    
418     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
419     $http = AnyEvent::MCP::Server::HTTP->new (
420 root 1.5 toolsets => [$toolset], (defined $origins ? (origins => $origins) : ()), tokens => ["token"],
421 root 1.3 );
422     $http->accept ($a);
423     $client = AnyEvent::Handle->new (fh => $b, on_error => sub { die $_[2] });
424     $cv = AnyEvent->condvar;
425 root 1.12 $timer = AnyEvent->timer (after => 30, cb => sub { die "CORS timeout" });
426 root 1.3
427     my $request = $method eq "POST"
428     ? post (message (50, "ping"), defined $origin ? "Origin: $origin\r\n" : "")
429     : "OPTIONS /mcp/ HTTP/1.1\r\n"
430     . (defined $origin ? "Origin: $origin\r\n" : "")
431     . "Access-Control-Request-Method: POST\r\n"
432     . "Access-Control-Request-Headers: content-type,mcp-method\r\n\r\n";
433     $request =~ s{POST /mcp/}{POST /token/mcp/} if $cookie;
434    
435     $client->push_write ($request);
436     http_read ($client, sub {
437     my ($header) = @_;
438    
439     like $header, qr/HTTP\/1.1 $status /, "CORS $method status";
440     if (defined $allowed) {
441     like $header, qr/^Access-Control-Allow-Origin: \Q$allowed\E\r?$/m, "allowed origin";
442     like $header, qr/^Vary: Origin\r?$/m, "vary by allowed origin" if $allowed ne "*";
443     } else {
444     unlike $header, qr/Access-Control-Allow-Origin:/, "no allowed origin";
445     }
446     if ($status == 204) {
447     like $header, qr/Access-Control-Allow-Methods: POST, OPTIONS/, "preflight methods";
448     like $header, qr/Access-Control-Allow-Headers: .*mcp-method,mcp-name/, "modern preflight headers";
449     like $header, qr/Access-Control-Max-Age: 86400/, "preflight cache";
450     }
451     $cv->send;
452     });
453     $cv->recv;
454     undef $timer;
455     $http->close;
456     $client->destroy;
457     }
458    
459     socketpair $a, $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC or die $!;
460     my $dispatched = 0;
461 root 1.6 $http = AnyEvent::MCP::Server::HTTP->new (auth => "none",
462 root 1.3 toolsets => [$toolset], connection_close => 1, on_request => sub { ++$dispatched },
463     );
464     $http->accept ($a);
465     undef $a;
466     $cv = AnyEvent->condvar;
467     my $received = 0;
468     $client = AnyEvent::Handle->new (
469     fh => $b,
470     on_error => sub { die $_[2] },
471     on_read => sub { fail "unexpected second HTTP response"; $cv->send },
472     on_eof => sub {
473     ok $received, "response drained before EOF";
474     is $_[0]{rbuf}, "", "no pipelined second response";
475     is $dispatched, 1, "connection_close prevents dispatch of the next request";
476     $cv->send;
477     },
478     );
479 root 1.12 $timer = AnyEvent->timer (after => 30, cb => sub { $cv->croak ("connection_close timeout") });
480 root 1.15 $on_slow = sub {
481     $release = AnyEvent->timer (after => 0.01, cb => sub {
482     $pending->reply ({ content => [{ type => "text", text => "x" x 131072 }] });
483     $pending = undef;
484     });
485     };
486 root 1.3 $client->push_write (
487     post (message (60, "tools/call", { name => "slow" }))
488     . post (message (61, "ping"))
489     );
490     http_read ($client, sub {
491     my ($header, $body) = @_;
492    
493     like $header, qr/^Connection: close\r?$/m, "connection_close header for HTTP/1.1";
494     my $response = JSON::XS::decode_json $body;
495     is $response->{id}, 60, "delayed response delivered";
496     is length $response->{result}{content}[0]{text}, 131072, "complete response body before close";
497     $received = 1;
498     });
499     $cv->recv;
500     undef $timer;
501     undef $release;
502 root 1.15 undef $on_slow;
503 root 1.3 $http->close;
504     $client->destroy;
505    
506 root 1.1 done_testing;