| 1 |
root |
1.1 |
use common::sense; |
| 2 |
|
|
use Test::More; |
| 3 |
|
|
use AnyEvent (); |
| 4 |
|
|
use AnyEvent::MCP::Client::JSONL (); |
| 5 |
|
|
|
| 6 |
root |
1.3 |
my @command = ($^X, "-Ilib", "bin/mcp-ask-user", "--stdio", "--ask", "mcp"); |
| 7 |
root |
1.1 |
my $direct_client = AnyEvent::MCP::Client::JSONL->new ( |
| 8 |
|
|
command => \@command, |
| 9 |
|
|
client_capabilities => { elicitation => { form => {} } }, |
| 10 |
|
|
); |
| 11 |
|
|
my $legacy_client = AnyEvent::MCP::Client::JSONL->new ( |
| 12 |
|
|
command => \@command, |
| 13 |
|
|
versions => ["2025-11-25"], |
| 14 |
|
|
); |
| 15 |
|
|
|
| 16 |
|
|
sub wait_for { |
| 17 |
|
|
my ($start) = @_; |
| 18 |
|
|
my $cv = AnyEvent->condvar; |
| 19 |
|
|
my $timeout = AnyEvent->timer (after => 8, cb => sub { die "ask-user test timeout\n" }); |
| 20 |
|
|
$start->(sub { $cv->send ([@_]) }); |
| 21 |
|
|
@{$cv->recv} |
| 22 |
|
|
} |
| 23 |
|
|
|
| 24 |
|
|
my $options = [ |
| 25 |
|
|
{ label => "Keep existing", description => "Preserve the current workdir" }, |
| 26 |
|
|
{ label => "Create new", description => "Start from scratch" }, |
| 27 |
|
|
]; |
| 28 |
|
|
my $args = { id => "path_choice", header => "Workdir", question => "Which workdir?", options => $options }; |
| 29 |
|
|
|
| 30 |
|
|
sub call { |
| 31 |
root |
1.4 |
my ($arguments, $extra, $caps, $legacy, $name) = @_; |
| 32 |
root |
1.1 |
$caps = { elicitation => { form => {} } } unless defined $caps; |
| 33 |
|
|
my $params = { |
| 34 |
root |
1.4 |
name => $name || "ask-user", arguments => $arguments, |
| 35 |
root |
1.1 |
%{$extra || {}}, |
| 36 |
|
|
(!$legacy ? (_meta => { |
| 37 |
|
|
"io.modelcontextprotocol/clientCapabilities" => $caps, |
| 38 |
root |
1.2 |
%{$extra->{_meta} || {}}, |
| 39 |
root |
1.1 |
}) : ()), |
| 40 |
|
|
}; |
| 41 |
|
|
my ($success, $result) = wait_for (sub { |
| 42 |
|
|
($legacy ? $legacy_client : $direct_client)->rpc ("tools/call", $params, $_[0]) |
| 43 |
|
|
}); |
| 44 |
|
|
die "ask-user transport failure: " . ($result->{message} // "") . "\n" unless $success; |
| 45 |
|
|
$result |
| 46 |
|
|
} |
| 47 |
|
|
|
| 48 |
|
|
sub resume { |
| 49 |
|
|
my ($result, $contents, $arguments, $caps) = @_; |
| 50 |
|
|
call ($arguments || $args, { |
| 51 |
|
|
requestState => $result->{requestState}, |
| 52 |
|
|
inputResponses => { question => $contents }, |
| 53 |
|
|
}, $caps) |
| 54 |
|
|
} |
| 55 |
|
|
|
| 56 |
|
|
my $first = call ($args); |
| 57 |
|
|
is $first->{resultType}, "input_required", "initial call requests human input"; |
| 58 |
|
|
like $first->{requestState}, qr/\Aae-mcp-question:[0-9a-f]{64}\z/, |
| 59 |
|
|
"continuation uses unpredictable token"; |
| 60 |
|
|
my $prompt = $first->{inputRequests}{question}; |
| 61 |
|
|
is $prompt->{method}, "elicitation/create", "native MCP elicitation, not YAD"; |
| 62 |
|
|
is $prompt->{params}{mode}, "form", "uses form elicitation"; |
| 63 |
|
|
is_deeply $prompt->{params}{requestedSchema}{properties}{choice}{enum}, |
| 64 |
|
|
["Keep existing", "Create new"], "choice values come from the supplied labels"; |
| 65 |
|
|
like $prompt->{params}{message}, qr/Preserve the current workdir/, |
| 66 |
|
|
"descriptions appear in question text"; |
| 67 |
|
|
ok $prompt->{params}{requestedSchema}{properties}{free_text}, |
| 68 |
|
|
"alternative free text field is always available"; |
| 69 |
|
|
|
| 70 |
|
|
my $answered = resume ($first, { action => "accept", |
| 71 |
|
|
content => { choice => "Keep existing" } }); |
| 72 |
|
|
is_deeply $answered->{structuredContent}, { |
| 73 |
|
|
id => "path_choice", status => "answered", answer => "Keep existing", source => "choice", |
| 74 |
|
|
}, "chosen answer is returned in structured tool result"; |
| 75 |
|
|
|
| 76 |
|
|
my $replay = resume ($first, { action => "accept", content => { choice => "Create new" } }); |
| 77 |
|
|
ok $replay->{isError} && $replay->{content}[0]{text} =~ /Invalid or expired/, |
| 78 |
|
|
"continuation token cannot be reused"; |
| 79 |
|
|
|
| 80 |
|
|
my $free = call ($args); |
| 81 |
|
|
my $custom = resume ($free, { action => "accept", |
| 82 |
|
|
content => { choice => "Keep existing", free_text => "Use current parent directory" } }); |
| 83 |
|
|
is $custom->{structuredContent}{answer}, "Use current parent directory", |
| 84 |
|
|
"free text overrides an optional choice"; |
| 85 |
|
|
is $custom->{structuredContent}{source}, "free_text", |
| 86 |
|
|
"free text is identified without inventing a choice"; |
| 87 |
|
|
|
| 88 |
|
|
my $open = { id => "free", question => "Please explain" }; |
| 89 |
|
|
my $plain = call ($open); |
| 90 |
|
|
is_deeply $plain->{inputRequests}{question}{params}{requestedSchema}{required}, |
| 91 |
|
|
["free_text"], "free-text-only question requires a written answer"; |
| 92 |
|
|
my $text = resume ($plain, { action => "accept", content => { free_text => "Explanation" } }, $open); |
| 93 |
|
|
is $text->{structuredContent}{answer}, "Explanation", "free text without choices is accepted"; |
| 94 |
|
|
|
| 95 |
|
|
my $empty = call ($args); |
| 96 |
|
|
my $noanswer = resume ($empty, { action => "accept", content => {} }); |
| 97 |
|
|
ok $noanswer->{isError} && $noanswer->{content}[0]{text} =~ /No answer/, |
| 98 |
|
|
"empty response is rejected rather than fabricating a choice"; |
| 99 |
|
|
|
| 100 |
|
|
my $declined = call ($args); |
| 101 |
|
|
my $d = resume ($declined, { action => "decline" }); |
| 102 |
|
|
is $d->{structuredContent}{status}, "declined", "decline is not mistaken for an answer"; |
| 103 |
|
|
my $cancelled = call ($args); |
| 104 |
|
|
my $c = resume ($cancelled, { action => "cancel" }); |
| 105 |
|
|
is $c->{structuredContent}{status}, "cancelled", "cancel is distinct from decline"; |
| 106 |
|
|
|
| 107 |
|
|
my $changed = call ($args); |
| 108 |
|
|
my $bad = resume ($changed, { action => "accept", content => { choice => "Keep existing" } }, |
| 109 |
|
|
{ %$args, question => "Something else" }); |
| 110 |
|
|
ok $bad->{isError}, "continuation is bound to the original call"; |
| 111 |
|
|
ok resume ($changed, { action => "decline" })->{isError}, |
| 112 |
|
|
"modified arguments consume the continuation token"; |
| 113 |
|
|
|
| 114 |
|
|
my $unavailable = call ($args, {}, {}); |
| 115 |
|
|
ok $unavailable->{isError} |
| 116 |
|
|
&& $unavailable->{content}[0]{text} =~ /unavailable/, |
| 117 |
|
|
"no advertised form capability returns a clear tool error"; |
| 118 |
|
|
my $url_only = call ($args, {}, { elicitation => { url => {} } }); |
| 119 |
|
|
ok $url_only->{isError} |
| 120 |
|
|
&& $url_only->{content}[0]{text} =~ /unavailable/, |
| 121 |
|
|
"URL-only elicitation is insufficient for form questions"; |
| 122 |
|
|
my $implicit = call ($args, {}, { elicitation => {} }); |
| 123 |
|
|
is $implicit->{resultType}, "input_required", |
| 124 |
|
|
"empty elicitation capability implies form support for compatibility"; |
| 125 |
|
|
my $implicit_done = resume ($implicit, { action => "accept", |
| 126 |
|
|
content => { choice => "Create new" } }, undef, { elicitation => {} }); |
| 127 |
|
|
is $implicit_done->{structuredContent}{answer}, "Create new", |
| 128 |
|
|
"empty elicitation capabilities work through the complete round trip"; |
| 129 |
root |
1.2 |
my $work_initial = call ($args, { _meta => { |
| 130 |
|
|
progressToken => "first-request", |
| 131 |
|
|
"io.modelcontextprotocol/clientInfo" => { name => "ChatGPT Work", version => "1" }, |
| 132 |
|
|
} }); |
| 133 |
|
|
my $work_resumed = call ($args, { |
| 134 |
|
|
requestState => $work_initial->{requestState}, |
| 135 |
|
|
inputResponses => { question => { |
| 136 |
|
|
action => "accept", content => { choice => "Keep existing" }, |
| 137 |
|
|
} }, |
| 138 |
|
|
_meta => { |
| 139 |
|
|
progressToken => "resumed-request", |
| 140 |
|
|
"io.modelcontextprotocol/clientInfo" => { name => "ChatGPT Work", version => "2" }, |
| 141 |
|
|
}, |
| 142 |
|
|
}, { elicitation => {} }); |
| 143 |
|
|
is $work_resumed->{structuredContent}{answer}, "Keep existing", |
| 144 |
|
|
"ask-user continuation ignores mutable request metadata, preserving original choice"; |
| 145 |
|
|
|
| 146 |
root |
1.1 |
my $old = call ($args, {}, {}, 1); |
| 147 |
|
|
ok $old->{isError}, "legacy clients receive a clear error rather than YAD"; |
| 148 |
|
|
my $duplicate = call ({ question => "Pick one", options => [ |
| 149 |
|
|
{ label => "Same" }, { label => "Same" }, |
| 150 |
|
|
] }); |
| 151 |
|
|
ok $duplicate->{isError}, "duplicate option labels are rejected"; |
| 152 |
|
|
|
| 153 |
root |
1.4 |
my $form_args = { |
| 154 |
|
|
message => "Configure the test", |
| 155 |
|
|
requestedSchema => { |
| 156 |
|
|
type => "object", required => ["enabled", "count", "note"], |
| 157 |
|
|
properties => { |
| 158 |
|
|
enabled => { type => "boolean", default => JSON::XS::false }, |
| 159 |
|
|
count => { type => "integer", minimum => 1, maximum => 10 }, |
| 160 |
|
|
note => { type => "string", title => "Notes" }, |
| 161 |
|
|
}, |
| 162 |
|
|
}, |
| 163 |
|
|
}; |
| 164 |
|
|
my $form_content = { enabled => JSON::XS::true, count => 3, note => "\x{03c0}\nsecond line" }; |
| 165 |
|
|
sub form_call { |
| 166 |
|
|
my ($args, $extra, $caps, $legacy) = @_; |
| 167 |
|
|
|
| 168 |
|
|
call ($args, $extra, $caps, $legacy, "ask-form") |
| 169 |
|
|
} |
| 170 |
|
|
sub form_resume { |
| 171 |
|
|
my ($challenge, $response, $args) = @_; |
| 172 |
|
|
|
| 173 |
|
|
form_call ($args || $form_args, { |
| 174 |
|
|
requestState => $challenge->{requestState}, |
| 175 |
|
|
inputResponses => { form => $response }, |
| 176 |
|
|
}) |
| 177 |
|
|
} |
| 178 |
|
|
|
| 179 |
|
|
my $form = form_call ($form_args); |
| 180 |
|
|
is $form->{resultType}, "input_required", "generic form requests input"; |
| 181 |
|
|
like $form->{requestState}, qr/\Aae-mcp-form:[0-9a-f]{64}\z/, "form continuation has its own token prefix"; |
| 182 |
|
|
is_deeply $form->{inputRequests}{form}{params}, { |
| 183 |
|
|
mode => "form", %$form_args, |
| 184 |
|
|
}, "generic schema and message reach native elicitation unchanged"; |
| 185 |
|
|
my $form_answer = form_resume ($form, { action => "accept", content => $form_content }); |
| 186 |
|
|
is_deeply $form_answer->{structuredContent}, { action => "accept", content => $form_content }, |
| 187 |
|
|
"generic result preserves field names, booleans, numbers, Unicode and multiline text"; |
| 188 |
|
|
ok form_resume ($form, { action => "decline" })->{isError}, "form token cannot be reused"; |
| 189 |
|
|
for my $action (qw(decline cancel)) { |
| 190 |
|
|
my $challenge = form_call ($form_args); |
| 191 |
|
|
is_deeply form_resume ($challenge, { action => $action })->{structuredContent}, |
| 192 |
|
|
{ action => $action }, "$action is a distinct standard form response"; |
| 193 |
|
|
} |
| 194 |
|
|
my $changed_form = form_call ($form_args); |
| 195 |
|
|
ok form_resume ($changed_form, { action => "accept", content => $form_content }, { |
| 196 |
|
|
%$form_args, requestedSchema => { type => "object", properties => {} }, |
| 197 |
|
|
})->{isError}, "form continuation is bound to the supplied schema"; |
| 198 |
|
|
ok form_resume ($changed_form, { action => "decline" })->{isError}, |
| 199 |
|
|
"changed form consumes its continuation"; |
| 200 |
|
|
my $cross_tool = form_call ($form_args); |
| 201 |
|
|
ok resume ($cross_tool, { action => "accept", content => { choice => "Keep existing" } })->{isError}, |
| 202 |
|
|
"form token cannot authorize the question tool"; |
| 203 |
|
|
|
| 204 |
|
|
for my $response ( |
| 205 |
|
|
{ action => "bogus" }, { action => "accept", content => [] }, {}, |
| 206 |
|
|
) { |
| 207 |
|
|
my $challenge = form_call ($form_args); |
| 208 |
|
|
ok form_resume ($challenge, $response)->{isError}, "malformed generic response is rejected"; |
| 209 |
|
|
} |
| 210 |
|
|
ok form_call ({ %$form_args, message => [] })->{isError}, "generic form rejects a non-text message"; |
| 211 |
|
|
ok form_call ({ message => "Invalid", requestedSchema => { type => "string" } })->{isError}, |
| 212 |
|
|
"generic form requires an object schema"; |
| 213 |
|
|
ok form_call ($form_args, {}, {})->{isError}, "generic native form requires client capability"; |
| 214 |
|
|
ok form_call ($form_args, {}, {}, 1)->{isError}, "generic native form rejects a legacy client"; |
| 215 |
|
|
|
| 216 |
root |
1.1 |
# Actually cross two stdio processes: client -> multibroker -> mcp-ask-user. |
| 217 |
|
|
# The upstream client must receive the downstream elicitation and its answer |
| 218 |
|
|
# must be routed back to the same child's continuation token. |
| 219 |
|
|
my $elicited = 0; |
| 220 |
|
|
my $client = AnyEvent::MCP::Client::JSONL->new ( |
| 221 |
root |
1.3 |
command => [$^X, "-Ilib", "bin/mcp-multibroker", "--ask", "mcp", "questions", |
| 222 |
root |
1.1 |
"stdio:" . join (" ", $^X, "-Ilib", "bin/mcp-ask-user")], |
| 223 |
|
|
env => { PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL => "stdio" }, |
| 224 |
|
|
client_capabilities => { elicitation => { form => {} } }, |
| 225 |
|
|
on_request => sub { |
| 226 |
|
|
my ($client, $req) = @_; |
| 227 |
|
|
++$elicited; |
| 228 |
|
|
is $req->{method}, "elicitation/create", |
| 229 |
|
|
"upstream receives original child's elicitation request"; |
| 230 |
root |
1.4 |
$req->reply ({ action => "accept", content => |
| 231 |
|
|
exists $req->{params}{requestedSchema}{properties}{count} |
| 232 |
|
|
? $form_content : { choice => "Create new" }, |
| 233 |
|
|
}); |
| 234 |
root |
1.1 |
}, |
| 235 |
|
|
); |
| 236 |
|
|
my $cv = AnyEvent->condvar; |
| 237 |
|
|
my $timer = AnyEvent->timer (after => 10, cb => sub { $cv->send ([0, "timed out"]) }); |
| 238 |
|
|
$client->call ("questions.ask-user", $args, sub { $cv->send ([@_]) }); |
| 239 |
|
|
my ($success, $through) = @{$cv->recv}; |
| 240 |
|
|
ok $success && $through->{structuredContent}{answer} eq "Create new" |
| 241 |
|
|
&& $elicited == 1, |
| 242 |
|
|
"native elicitation and response round-trip through the real multibroker"; |
| 243 |
|
|
|
| 244 |
|
|
# The upstream caller's capabilities, not the broker's own advertised |
| 245 |
|
|
# capabilities or any cached peer state, decide whether each call may elicit. |
| 246 |
|
|
$client->{client_capabilities} = {}; |
| 247 |
|
|
($success, $through) = wait_for (sub { |
| 248 |
|
|
$client->call ("questions.ask-user", $args, $_[0]) |
| 249 |
|
|
}); |
| 250 |
|
|
ok $success && $through->{isError} |
| 251 |
|
|
&& $through->{content}[0]{text} =~ /elicitation is unavailable/ |
| 252 |
|
|
&& $elicited == 1, |
| 253 |
|
|
"multibroker rejects unsupported per-request caller without eliciting"; |
| 254 |
|
|
|
| 255 |
|
|
$client->{client_capabilities} = { elicitation => {} }; |
| 256 |
|
|
($success, $through) = wait_for (sub { |
| 257 |
|
|
$client->call ("questions.ask-user", $args, $_[0]) |
| 258 |
|
|
}); |
| 259 |
|
|
ok $success && $through->{structuredContent}{answer} eq "Create new" |
| 260 |
|
|
&& $elicited == 2, |
| 261 |
|
|
"same upstream connection then accepts implicit form elicitation"; |
| 262 |
root |
1.2 |
# A raw multi-round-trip request through the multibroker can change _meta |
| 263 |
|
|
# between the initial call and the response (as Work-like clients may do). |
| 264 |
|
|
($success, $through) = wait_for (sub { |
| 265 |
|
|
$client->rpc ("tools/call", { |
| 266 |
|
|
name => "questions.ask-user", arguments => $args, |
| 267 |
|
|
_meta => { progressToken => "first-hop" }, |
| 268 |
|
|
}, $_[0]); |
| 269 |
|
|
}); |
| 270 |
|
|
is $through->{resultType}, "input_required", |
| 271 |
|
|
"broker delivers initial challenge for raw Work-like tool call"; |
| 272 |
|
|
my $broker_state = $through->{requestState}; |
| 273 |
|
|
($success, $through) = wait_for (sub { |
| 274 |
|
|
$client->rpc ("tools/call", { |
| 275 |
|
|
name => "questions.ask-user", arguments => $args, |
| 276 |
|
|
requestState => $broker_state, |
| 277 |
|
|
inputResponses => { question => { |
| 278 |
|
|
action => "accept", content => { choice => "Keep existing" }, |
| 279 |
|
|
} }, |
| 280 |
|
|
_meta => { progressToken => "second-hop" }, |
| 281 |
|
|
}, $_[0]); |
| 282 |
|
|
}); |
| 283 |
|
|
ok $success && $through->{structuredContent}{answer} eq "Keep existing", |
| 284 |
|
|
"multibroker forwards Work-like changed metadata without losing question continuation"; |
| 285 |
root |
1.4 |
($success, $through) = wait_for (sub { |
| 286 |
|
|
$client->call ("questions.ask-form", $form_args, $_[0]) |
| 287 |
|
|
}); |
| 288 |
|
|
ok $success, "generic form transport crosses the real multibroker"; |
| 289 |
|
|
is_deeply $through->{structuredContent}, { action => "accept", content => $form_content }, |
| 290 |
|
|
"generic form content survives the real client/broker/child round trip"; |
| 291 |
root |
1.1 |
$client->close; |
| 292 |
|
|
$direct_client->close; |
| 293 |
|
|
$legacy_client->close; |
| 294 |
|
|
|
| 295 |
|
|
done_testing; |
