./PaxHeaders/MCP-0.15 0000644 0000000 0000000 00000000132 15232633632 011221 x ustar 00 30 mtime=1785411482.338997154
30 atime=1785411482.273952722
30 ctime=1785411482.338997154
MCP-0.15/ 0000755 0001750 0000144 00000000000 15232633632 010637 5 ustar 00sri users MCP-0.15/PaxHeaders/t 0000644 0000000 0000000 00000000132 15232633632 011327 x ustar 00 30 mtime=1785411482.277712985
30 atime=1785411482.273774655
30 ctime=1785411482.277712985
MCP-0.15/t/ 0000755 0001750 0000144 00000000000 15232633632 011102 5 ustar 00sri users MCP-0.15/t/PaxHeaders/schema.t 0000644 0000000 0000000 00000000132 15232632765 013037 x ustar 00 30 mtime=1785411061.350291972
30 atime=1785411061.352388426
30 ctime=1785411482.274806297
MCP-0.15/t/schema.t 0000644 0001750 0000144 00000006333 15232632765 012542 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use MCP::Tool;
use Mojo::JSON qw(false true);
subtest 'Default dialect is JSON Schema 2020-12' => sub {
my $tool
= MCP::Tool->new(
input_schema => {type => 'object', properties => {pair => {type => 'array', prefixItems => [{type => 'integer'}]}}}
);
is $tool->validate_input({pair => [23, 'whatever']}), 0, 'prefixItems satisfied';
is $tool->validate_input({pair => ['nope']}), 1, 'prefixItems violated';
my $dependent = MCP::Tool->new(input_schema => {type => 'object', dependentRequired => {a => ['b']}});
is $dependent->validate_input({a => 1, b => 2}), 0, 'dependentRequired satisfied';
is $dependent->validate_input({a => 1}), 1, 'dependentRequired violated';
};
subtest 'Explicit dialect' => sub {
my $tool = MCP::Tool->new(
input_schema => {
'$schema' => 'http://json-schema.org/draft-07/schema#',
type => 'object',
properties => {pair => {type => 'array', prefixItems => [{type => 'integer'}]}}
}
);
is $tool->validate_input({pair => ['nope']}), 0, 'prefixItems is not a draft-07 keyword';
};
subtest 'Unsupported dialect' => sub {
my $tool = MCP::Tool->new(input_schema => {'$schema' => 'https://json-schema.org/draft/2077-01/schema'});
eval { $tool->validate_input({}) };
like $@, qr/Unsupported JSON Schema dialect/, 'unsupported dialect';
};
subtest 'References' => sub {
my $local = MCP::Tool->new(input_schema =>
{type => 'object', properties => {msg => {'$ref' => '#/$defs/text'}}, '$defs' => {text => {type => 'string'}}});
is $local->validate_input({msg => 'hello'}), 0, 'local reference resolved';
is $local->validate_input({msg => 23}), 1, 'local reference enforced';
my $remote = MCP::Tool->new(
input_schema => {type => 'object', properties => {msg => {'$ref' => 'https://example.com/schema.json'}}});
is $remote->validate_input({msg => 'hello'}), 1, 'network reference is not dereferenced';
};
subtest 'Composition depth' => sub {
my $tool = MCP::Tool->new(
max_schema_depth => 3,
input_schema => {allOf => [{allOf => [{allOf => [{allOf => [{type => 'object'}]}]}]}]}
);
is $tool->validate_input({}), 1, 'schema nested too deeply';
};
subtest 'Output validation' => sub {
my $tool = MCP::Tool->new(
output_schema => {type => 'object', properties => {count => {type => 'integer'}}, required => ['count']});
is $tool->validate_output({count => 23}), 0, 'structured content is valid';
is $tool->validate_output({count => 'x'}), 1, 'structured content is invalid';
my $result = $tool->structured_result({count => 23});
is $result->{isError}, false, 'not an error';
is_deeply $result->{structuredContent}, {count => 23}, 'structured content';
my $invalid = $tool->structured_result({count => 'x'});
is $invalid->{isError}, true, 'is an error';
is $invalid->{structuredContent}, undef, 'no structured content';
is $invalid->{content}[0]{text}, 'Structured content does not match the output schema', 'error message';
my $schemaless = MCP::Tool->new;
is $schemaless->validate_output({whatever => 1}), 0, 'no output schema';
};
done_testing;
MCP-0.15/t/PaxHeaders/apps 0000644 0000000 0000000 00000000131 15232633632 012271 x ustar 00 30 mtime=1785411482.277025849
29 atime=1785411482.27534496
30 ctime=1785411482.277025849
MCP-0.15/t/apps/ 0000755 0001750 0000144 00000000000 15232633632 012045 5 ustar 00sri users MCP-0.15/t/apps/PaxHeaders/mojolicious.png 0000644 0000000 0000000 00000000130 15176660006 015411 x ustar 00 29 mtime=1778081798.72737192
30 atime=1785368487.492017075
29 ctime=1785411482.27534496
MCP-0.15/t/apps/mojolicious.png 0000644 0001750 0000144 00000007772 15176660006 015126 0 ustar 00sri users PNG
IHDR & iTXtXML:com.adobe.xmp
J iCCPsRGB IEC61966-2.1 (u+DQ?Ə"YP/aƨ e$1ʯ̛y3j~{dl(k_VY+EdaeMlsQ#s;|s\pj,B*mр2;7 PA#- US Pī.VsZU4fP Tu Xt7D8*|,i ='ypU'q #%,/-̪?q^R KLKlo$(a?= ݲH;2`DfzL&zLFjj| ?K;73gy p.gU\Akۅ589/h-8];=lRqA%T.{-V.`{:|};g;* pHYs IDATx{]E?s{$ c$CqCZ_e]Vb%ZKQQ6a+) ƀD$&CD0}}r73s<:ߪ[t_o 1bĈ#F1bĈ#F13d 37 ]` LT1bԅvTuSz&Vե+U?CΰKNz)hUUw6 b^.˺a2鶷,M]:RSGB2nWՓ z3SUI9G
6Sg)zO`k.{ãv7=
<[}bsuSBܗ@Wj~u:m"Y;tHU LȤܾ= gg& GVon`c^| <4Nڀ/N^Q&v!,` }H:xT2S $%rg/c'ʄ TBB("> Uu*p'pΝ;c T
S) fDG}>z{SDbya";' mr :{E > t w֛T-o"HȰ<
\d'DOc@g)Ƿ۾-"T ODnԝ=p*P9efT[DQ p<;=N ~XD^4 Uw\&xdHID L%Rk& I" 2yʔAD^jx?ɭ
`QMHD"> |*B|
אz=`90?"9<yiL eMDvD.Tu)d /QNݿ͉ +"lw?wXDVj+|YɈȚ0Qwao=|yڹ76 %NCGttC.;STSr-<7m\}+UKve$VQ\fg Tl ޕKGSƺ3PK
9Xigɦ /I@vt Go7,,9n$T$pwOOO2{# ] ?Hm*9A2Z 7(^אx\W(bWwp6ZwPw VEw p7$-γNy?p~7df0Kb6B܊! FI ĘZ}9@0OD܂>եR=X TgIs;Qq\@:&X-e+l-,k >cTӚ p#[Dd5pM$}&?^gc !9Ed k".T Z."Dd G"
su
"Hxٺ;, d3PJK9YSjAȵI$-evҒ V$ؼ`Oa㟫q6aPDm^@HQqp]9h]\8MDZؔfs?h)#P3Ө ` Z$8@>[]~} fE$3o]sSX~7$9S{T"Y>C.ӟr
1{|Y5[5cYO:nǩS'16}fRs FY2 '`(=\ ̍Z4|!F 2z𧽌,ൾ^6/" n4TU"I_HD}q߷+Ds;,-xQ_n.D/ɞVՓ5 0T*!@ٯ02jEvmxm#uW^ =&h%YkI:WcuAtIxߡDδ3ӹwVkNjuKՁoE7{#u6ʘUT GrQ}pP%%
َ-S'q x]H Ǫ O 'Uݪ ^/"nx 9TpΌ䏇{Wh2!JsYnZ="H͈kH)"*"C
@njt/eIW$UaP$?E$]P@{=о!Ęa|C6`M_S#z p;e4vjcNL8ip ͳ Tr%-[H~`/Q[$|fO?[bztdHyYͼx~5D,MDZݟ/0
*ZVmEP9D$z_Dzٚ hl줄̟aIzXڤ2C\cj^D @wl<&~UU]iu߯#3 / n&+
5q% G>m̸*
w[Kx-
.[VtP+Mmu8x c%ׁtt!@.vjO
u(k669U]NDKD`3$DlA\sᗘ N ^7E^U]%JU^{3U \_9Q]~LŘ{0@;>a 31V`;𠈌duMZ,u B2S& 2|e| F̌$k?ޮ
-sW{{$@UW`L6S"=.NR[ȴ<(KUbIW' @) 6k:hE W|z j^U?M5( $A]---w{߃ HmP,R%R!-:␄r' {i \)"G]9 c:cc9Y} سk-[yHKEJ!χiȆ17pߧ6Lq|pzĘΊJaN 7o1`/ uO' PŘ#a,46 fbĈ#F1bĈ#F; qA IENDB` MCP-0.15/t/apps/PaxHeaders/empty.wav 0000644 0000000 0000000 00000000132 15176660006 014226 x ustar 00 30 mtime=1778081798.727265839
30 atime=1785368487.496017074
30 ctime=1785411482.275922346
MCP-0.15/t/apps/empty.wav 0000644 0001750 0000144 00000000116 15176660006 013722 0 ustar 00sri users RIFFF WAVEfmt D LIST INFOISFT
Lavf62.3.100 data MCP-0.15/t/apps/PaxHeaders/stdio.pl 0000644 0000000 0000000 00000000132 15232632765 014034 x ustar 00 30 mtime=1785411061.349100107
30 atime=1785411061.353696318
30 ctime=1785411482.276697933
MCP-0.15/t/apps/stdio.pl 0000644 0001750 0000144 00000004325 15232632765 013536 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use MCP::Server;
use Mojo::IOLoop;
use Mojo::Promise;
my $server = MCP::Server->new;
$server->tool(
name => 'echo',
description => 'Echo the input text',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
return "Echo: $args->{msg}";
}
);
$server->tool(
name => 'echo_async',
description => 'Echo the input text asynchronously',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
my $promise = Mojo::Promise->new;
Mojo::IOLoop->timer(0.5 => sub { $promise->resolve("Echo (async): $args->{msg}") });
return $promise;
}
);
$server->tool(
name => 'echo_log',
description => 'Echo the input text and log a notification',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
$tool->context->notify_log(debug => 'too quiet');
$tool->context->notify_log(info => $args->{msg});
return "Echo: $args->{msg}";
}
);
$server->tool(
name => 'reload',
description => 'Broadcast a tools list_changed notification',
code => sub ($tool, $args) {
$server->notify_list_changed('tools');
return 'reloaded';
}
);
$server->tool(
name => 'echo_progress',
description => 'Echo the input text and report progress',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
$tool->context->notify_progress(0.5, 1, 'half');
return "Echo: $args->{msg}";
}
);
$server->tool(
name => 'echo_scoped',
description => 'Echo the input text, requires a scope',
scopes => ['mcp:read'],
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
return "Echo: $args->{msg}";
}
);
$server->tool(
name => 'boom',
description => 'Throw an exception',
code => sub ($tool, $args) {
die "kaboom\n";
}
);
$server->log->level('fatal');
$server->to_stdio;
MCP-0.15/t/apps/PaxHeaders/lite_app.pl 0000644 0000000 0000000 00000000074 15176660006 014510 x ustar 00 30 atime=1785410975.150529278
30 ctime=1785411482.277092874
MCP-0.15/t/apps/lite_app.pl 0000644 0001750 0000144 00000013372 15176660006 014207 0 ustar 00sri users use Mojolicious::Lite -signatures;
use MCP::Server;
use Mojo::IOLoop;
use Mojo::Promise;
use Mojo::File qw(curfile);
use Mojo::JSON qw(true false);
my $server = MCP::Server->new;
$server->tool(
name => 'echo',
description => 'Echo the input text',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
annotations => {title => 'echo'},
code => sub ($tool, $args) {
return "Echo: $args->{msg}";
}
);
$server->tool(
name => 'echo_async',
description => 'Echo the input text asynchronously',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
my $promise = Mojo::Promise->new;
Mojo::IOLoop->timer(0.5 => sub { $promise->resolve("Echo (async): $args->{msg}") });
return $promise;
}
);
$server->tool(
name => 'echo_header',
description => 'Echo the input text with a header',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {
my $context = $tool->context;
my $header = $context->{controller}->req->headers->header('Mcp-Custom-Header');
return "Echo with header: $args->{msg} (Header: $header)";
}
);
$server->tool(
name => 'time',
description => 'Get the current time in epoch format',
code => sub ($tool, $args) {
return time;
}
);
$server->tool(
name => 'generate_image',
description => 'Generate a simple image from text',
input_schema => {type => 'object', properties => {text => {type => 'string'}}, required => ['text']},
code => sub ($tool, $args) {
my $image = curfile->sibling('mojolicious.png')->slurp;
return $tool->image_result($image, {annotations => {audience => ['user']}});
}
);
$server->tool(
name => 'generate_audio',
description => 'Generate audio from text',
input_schema => {type => 'object', properties => {text => {type => 'string'}}, required => ['text']},
code => sub ($tool, $args) {
my $audio = curfile->sibling('empty.wav')->slurp;
return $tool->audio_result($audio);
}
);
$server->tool(
name => 'find_resource',
description => 'Find a resource for the given text',
input_schema => {type => 'object', properties => {text => {type => 'string'}}, required => ['text']},
annotations => {
title => 'find_resource',
readOnlyHint => true,
destructiveHint => false,
idempotentHint => true,
openWorldHint => false
},
code => sub ($tool, $args) {
my $uri = 'file:///path/to/resource.txt';
return $tool->resource_link_result($uri, {name => 'sample', description => 'An example resource'});
}
);
$server->tool(
name => 'current_weather',
description => 'Get current weather data for a location',
input_schema => {
type => 'object',
properties => {location => {type => 'string', description => 'City name or zip code'}},
required => ['location']
},
output_schema => {
type => 'object',
properties => {
temperature => {type => 'number', description => 'Temperature in celsius'},
conditions => {type => 'string', description => 'Weather conditions description'},
humidity => {type => 'number', description => 'Humidity percentage'}
},
required => ['temperature', 'conditions', 'humidity']
},
code => sub ($tool, $args) {
return $tool->structured_result({temperature => 22, conditions => 'Partly cloudy', humidity => 65})
if $args->{location} eq 'Bremen';
return $tool->structured_result({temperature => 19, conditions => 'Raining', humidity => 80});
}
);
$server->prompt(
name => 'time',
description => 'Tell the user the time',
code => sub ($tool, $args) {
return 'Tell the user the current time';
}
);
$server->prompt(
name => 'prompt_echo_async',
description => 'Make a prompt from the input text',
arguments => [{name => 'msg', description => 'Message to echo', required => 1}],
code => sub ($prompt, $args) {
my $promise = Mojo::Promise->new;
Mojo::IOLoop->timer(0.5 => sub { $promise->resolve("Tell the user (async): $args->{msg}") });
return $promise;
}
);
$server->prompt(
name => 'prompt_echo_header',
description => 'Make a prompt from the input text with a header',
arguments => [{name => 'msg', description => 'Message to echo', required => 1}],
code => sub ($prompt, $args) {
my $context = $prompt->context;
my $header = $context->{controller}->req->headers->header('Mcp-Custom-Header');
return $prompt->text_prompt("Prompt with header: $args->{msg} (Header: $header)",
'assistant', 'Echoed message with header');
}
);
$server->resource(
name => 'static_text',
description => 'A static text resource',
uri => 'file:///path/to/static.txt',
mime_type => 'text/plain',
code => sub ($resource) {
return "This is a static text resource.";
}
);
$server->resource(
uri => 'file:///path/to/image.png',
name => 'static_image',
description => 'A static image resource',
mime_type => 'image/png',
code => sub ($resource) {
my $image = curfile->sibling('mojolicious.png')->slurp;
return $resource->binary_resource($image);
}
);
$server->resource(
uri => 'file:///path/to/async.txt',
name => 'async_text',
description => 'An asynchronous text resource',
mime_type => 'text/plain',
code => sub ($resource) {
my $promise = Mojo::Promise->new;
Mojo::IOLoop->timer(0.5 => sub { $promise->resolve("This is an asynchronous text resource.") });
return $promise;
}
);
any '/mcp' => $server->to_action;
get '/' => {text => 'Hello MCP!'};
app->start;
MCP-0.15/t/PaxHeaders/cancel.t 0000644 0000000 0000000 00000000132 15232632765 013024 x ustar 00 30 mtime=1785411061.349369337
30 atime=1785411061.352388426
30 ctime=1785411482.275495726
MCP-0.15/t/cancel.t 0000644 0001750 0000144 00000006001 15232632765 012517 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Constants qw(META_CLIENT_CAPABILITIES META_PROTOCOL_VERSION PROTOCOL_VERSION);
use MCP::Server;
use Mojo::IOLoop;
use Mojo::JSON qw(from_json);
use Mojo::Promise;
my $server = MCP::Server->new;
my $observed = {};
$server->tool(
name => 'slow',
code => sub ($tool, $args) {
my $context = $tool->context;
my $promise = Mojo::Promise->new;
my $id = Mojo::IOLoop->recurring(0.05 => sub { $context->notify_progress(1, 2, 'working') });
$observed = {cancelled => 0, before => $context->is_cancelled};
$context->on(
cancelled => sub ($context) {
Mojo::IOLoop->remove($id);
$observed->{cancelled}++;
$observed->{after} = $context->is_cancelled;
$observed->{notify} = $context->notify('notifications/message', {data => 'too late'});
$promise->resolve('finished');
}
);
$context->notify_progress(0, 2, 'starting');
return $promise;
}
);
any '/mcp' => $server->to_action;
my $t = Test::Mojo->new;
subtest 'Cancellation by closing the response stream' => sub {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION, progressToken => 'p1'};
my $body
= {jsonrpc => '2.0', id => 1, method => 'tools/call', params => {name => 'slow', arguments => {}, _meta => $meta}};
my $headers = {
Accept => 'text/event-stream',
'MCP-Protocol-Version' => PROTOCOL_VERSION,
'Mcp-Method' => 'tools/call',
'Mcp-Name' => 'slow'
};
my @messages;
my $tx = $t->ua->build_tx(POST => $t->ua->server->url->path('/mcp') => $headers => json => $body);
$tx->res->content->on(
sse => sub ($content, $event = undef) {
return unless $event && $event->{text};
push @messages, from_json($event->{text});
Mojo::IOLoop->remove($tx->connection);
}
);
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->is_finished || $tx->error;
is $tx->res->code, 200, 'stream open';
is $tx->res->headers->content_type, 'text/event-stream', 'right content type';
is $tx->res->headers->header('X-Accel-Buffering'), 'no', 'buffering disabled';
is scalar @messages, 1, 'nothing written after the client left';
is $messages[0]{method}, 'notifications/progress', 'buffered notification flushed';
is $messages[0]{params}{message}, 'starting', 'progress message';
my $tick = Mojo::Promise->new;
Mojo::IOLoop->timer(0.2 => sub { $tick->resolve });
$tick->wait;
is $observed->{before}, 0, 'not cancelled while running';
is $observed->{cancelled}, 1, 'cancelled event emitted once';
is $observed->{after}, 1, 'cancelled afterwards';
is $observed->{notify}, undef, 'notifications declined after cancellation';
};
done_testing;
MCP-0.15/t/PaxHeaders/exceptions.t 0000644 0000000 0000000 00000000132 15232632765 013760 x ustar 00 30 mtime=1785411061.349502494
30 atime=1785411061.352388426
30 ctime=1785411482.275539451
MCP-0.15/t/exceptions.t 0000644 0001750 0000144 00000007633 15232632765 013467 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Constants qw(INTERNAL_ERROR META_PROTOCOL_VERSION PROTOCOL_VERSION);
use MCP::Server;
use Mojo::Promise;
my $server = MCP::Server->new;
$server->tool(name => 'boom', code => sub ($tool, $args) { die "kaboom in /secret/path.pm line 23\n" });
$server->tool(name => 'boom_async', code => sub ($tool, $args) { Mojo::Promise->reject('async kaboom') });
$server->tool(
name => 'boom_late',
code => sub ($tool, $args) {
Mojo::Promise->resolve->then(sub { die "late\n" });
}
);
$server->tool(name => 'fine', code => sub ($tool, $args) {'still here'});
$server->tool(
name => 'bad_dialect',
input_schema => {'$schema' => 'https://example.com/nope', type => 'object'},
code => sub ($tool, $args) {'unreachable'}
);
$server->prompt(name => 'boom', code => sub ($prompt, $args) { die "prompt kaboom\n" });
$server->resource(uri => 'file:///boom', name => 'boom', code => sub ($resource) { die "resource kaboom\n" });
$server->on(
tools => sub ($server, $tools, $context) { die "hook kaboom\n" if $context->client_info->{name} eq 'Boom' });
app->log->level('fatal');
any '/mcp' => $server->to_action;
my $t = Test::Mojo->new;
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
subtest 'Tool exceptions' => sub {
eval { $client->call_tool('boom') };
like $@, qr/^Error -32603: Internal error/, 'internal error';
eval { $client->call_tool('boom_async') };
like $@, qr/^Error -32603: Internal error/, 'rejected promise';
eval { $client->call_tool('boom_late') };
like $@, qr/^Error -32603: Internal error/, 'exception in a promise';
};
subtest 'Exceptions outside the primitive' => sub {
eval { $client->call_tool('bad_dialect') };
like $@, qr/^Error -32603: Internal error/, 'unsupported schema dialect';
my $boom = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'), name => 'Boom');
eval { $boom->list_tools };
like $@, qr/^Error -32603: Internal error/, 'dying event handler';
is scalar @{$client->list_tools->{tools}}, 5, 'other callers are unaffected';
};
subtest 'Prompt and resource exceptions' => sub {
eval { $client->get_prompt('boom') };
like $@, qr/^Error -32603: Internal error/, 'prompt internal error';
eval { $client->read_resource('file:///boom') };
like $@, qr/^Error -32603: Internal error/, 'resource internal error';
};
subtest 'Nothing is leaked' => sub {
my $meta = {META_PROTOCOL_VERSION() => PROTOCOL_VERSION, 'io.modelcontextprotocol/clientCapabilities' => {}};
my $request
= {jsonrpc => '2.0', id => 1, method => 'tools/call', params => {name => 'boom', arguments => {}, _meta => $meta}};
my $headers = {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'tools/call', 'Mcp-Name' => 'boom'};
$t->post_ok('/mcp' => $headers => json => $request)
->status_is(500)
->json_is('/error/code' => INTERNAL_ERROR)
->json_is('/error/message' => 'Internal error')
->json_hasnt('/error/data')
->content_unlike(qr/kaboom|secret/);
};
subtest 'Server survives' => sub {
is $client->call_tool('fine')->{content}[0]{text}, 'still here', 'still serving requests';
};
subtest 'Exceptions go to the application log' => sub {
is $server->log, app->log, 'application log adopted';
my $messages = app->log->capture('error');
eval { $client->call_tool('boom') };
eval { $client->get_prompt('boom') };
like $messages, qr/\[error\].*MCP request failed: kaboom in \/secret\/path\.pm/, 'tool exception logged';
like $messages->[-1], qr/MCP request failed: prompt kaboom/, 'prompt exception logged';
undef $messages;
$messages = app->log->capture('error');
is $client->call_tool('fine')->{content}[0]{text}, 'still here', 'tool called';
is_deeply [@$messages], [], 'nothing logged for a successful call';
undef $messages;
};
done_testing;
MCP-0.15/t/PaxHeaders/context_specific_app.t 0000644 0000000 0000000 00000000132 15232632765 015770 x ustar 00 30 mtime=1785411061.349429352
30 atime=1785411061.352388426
30 ctime=1785411482.275582259
MCP-0.15/t/context_specific_app.t 0000644 0001750 0000144 00000013216 15232632765 015471 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Server;
my $server = MCP::Server->new;
$server->tool(
name => 'user_tool',
code => sub ($tool, $args) {
return 'Hello user!';
}
);
$server->tool(
name => 'admin_tool',
code => sub ($tool, $args) {
return 'Hello admin!';
}
);
$server->on(
tools => sub ($server, $tools, $context) {
my $role = $context->controller->stash('role');
return if $role eq 'admin';
@$tools = grep { $_->name ne 'admin_tool' } @$tools;
}
);
$server->prompt(
name => 'user_prompt',
code => sub ($prompt, $args) {
return 'This is a user prompt';
}
);
$server->prompt(
name => 'admin_prompt',
code => sub ($prompt, $args) {
return 'This is an admin prompt';
}
);
$server->on(
prompts => sub ($server, $prompts, $context) {
my $role = $context->controller->stash('role');
return if $role eq 'admin';
@$prompts = grep { $_->name ne 'admin_prompt' } @$prompts;
}
);
$server->resource(
uri => 'file:///user_resource',
code => sub ($resource) {
return 'User resource content';
}
);
$server->resource(
uri => 'file:///admin_resource',
code => sub ($resource) {
return 'Admin resource content';
}
);
$server->on(
resources => sub ($server, $resources, $context) {
my $role = $context->controller->stash('role');
return if $role eq 'admin';
@$resources = grep { $_->uri ne 'file:///admin_resource' } @$resources;
}
);
get '/' => {text => 'Hello MCP!'};
# Fake authentication
under sub ($c) {
my $role = $c->param('role');
$c->stash(role => $role);
return 1;
};
any '/mcp' => $server->to_action;
my $t = Test::Mojo->new;
subtest 'Normal HTTP endpoint' => sub {
$t->get_ok('/')->status_is(200)->content_like(qr/Hello MCP!/);
};
subtest 'MCP endpoint' => sub {
subtest 'Admin user' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp')->query(role => 'admin'));
subtest 'Tools' => sub {
my $result = $client->list_tools;
is $result->{tools}[0]{name}, 'user_tool', 'user tool present';
is $result->{tools}[1]{name}, 'admin_tool', 'admin tool present';
is $result->{tools}[2], undef, 'no more tools';
is $result->{cacheScope}, 'private', 'per caller list is private';
my $user_result = $client->call_tool('user_tool');
is $user_result->{content}[0]{text}, 'Hello user!', 'user tool call result';
my $admin_result = $client->call_tool('admin_tool');
is $admin_result->{content}[0]{text}, 'Hello admin!', 'admin tool call result';
};
subtest 'Prompts' => sub {
my $result = $client->list_prompts;
is $result->{prompts}[0]{name}, 'user_prompt', 'user prompt present';
is $result->{prompts}[1]{name}, 'admin_prompt', 'admin prompt present';
is $result->{prompts}[2], undef, 'no more prompts';
my $user_prompt = $client->get_prompt('user_prompt');
is $user_prompt->{messages}[0]{content}{text}, 'This is a user prompt', 'user prompt result';
my $admin_prompt = $client->get_prompt('admin_prompt');
is $admin_prompt->{messages}[0]{content}{text}, 'This is an admin prompt', 'admin prompt result';
};
subtest 'Resources' => sub {
my $result = $client->list_resources;
is $result->{resources}[0]{uri}, 'file:///user_resource', 'user resource present';
is $result->{resources}[1]{uri}, 'file:///admin_resource', 'admin resource present';
is $result->{resources}[2], undef, 'no more resources';
my $user_resource = $client->read_resource('file:///user_resource');
is $user_resource->{contents}[0]{text}, 'User resource content', 'user resource result';
my $admin_resource = $client->read_resource('file:///admin_resource');
is $admin_resource->{contents}[0]{text}, 'Admin resource content', 'admin resource result';
};
};
subtest 'Normal user' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp')->query(role => 'user'));
subtest 'Tools' => sub {
my $result = $client->list_tools;
is $result->{tools}[0]{name}, 'user_tool', 'user tool present';
is $result->{tools}[1], undef, 'no more tools';
my $user_result = $client->call_tool('user_tool');
is $user_result->{content}[0]{text}, 'Hello user!', 'user tool call result';
eval { $client->call_tool('admin_tool', {}) };
like $@, qr/Error -32602: Tool 'admin_tool' not found/, 'right error';
};
subtest 'Prompts' => sub {
my $result = $client->list_prompts;
is $result->{prompts}[0]{name}, 'user_prompt', 'user prompt present';
is $result->{prompts}[1], undef, 'no more prompts';
my $user_prompt = $client->get_prompt('user_prompt');
is $user_prompt->{messages}[0]{content}{text}, 'This is a user prompt', 'user prompt result';
eval { $client->get_prompt('admin_prompt') };
like $@, qr/Error -32602: Prompt 'admin_prompt' not found/, 'right error';
};
subtest 'Resources' => sub {
my $result = $client->list_resources;
is $result->{resources}[0]{uri}, 'file:///user_resource', 'user resource present';
is $result->{resources}[1], undef, 'no more resources';
my $user_resource = $client->read_resource('file:///user_resource');
is $user_resource->{contents}[0]{text}, 'User resource content', 'user resource result';
eval { $client->read_resource('file:///admin_resource') };
like $@, qr{Error -32602: Resource 'file:///admin_resource' not found}, 'right error';
};
};
};
done_testing;
MCP-0.15/t/PaxHeaders/auth_scopes_app.t 0000644 0000000 0000000 00000000132 15232632765 014754 x ustar 00 30 mtime=1785411061.349310949
30 atime=1785411061.353696318
30 ctime=1785411482.275641698
MCP-0.15/t/auth_scopes_app.t 0000644 0001750 0000144 00000016466 15232632765 014467 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Constants qw(META_CLIENT_CAPABILITIES META_PROTOCOL_VERSION PROTOCOL_VERSION);
use MCP::Server;
my $server = MCP::Server->new;
$server->tool(
name => 'read_tool',
scopes => ['mcp:read'],
code => sub ($tool, $args) {
return 'Read result';
}
);
$server->tool(
name => 'write_tool',
scopes => ['mcp:write'],
code => sub ($tool, $args) {
return 'Write result';
}
);
$server->tool(
name => 'custom_tool',
scopes => ['mcp:something.custom'],
code => sub ($tool, $args) {
return 'custom result';
}
);
$server->on(
tools => sub ($server, $tools, $context) {
my $c = $context->controller;
my $role = $c ? $c->stash('role') : '';
return if $role eq 'admin';
@$tools = grep { $_->name ne 'custom_tool' } @$tools;
}
);
$server->prompt(
name => 'read_prompt',
scopes => ['mcp:read'],
code => sub ($prompt, $args) {
return 'Read prompt';
}
);
$server->prompt(
name => 'write_prompt',
scopes => ['mcp:write'],
code => sub ($prompt, $args) {
return 'Write prompt';
}
);
$server->resource(
uri => 'file:///read',
scopes => ['mcp:read'],
code => sub ($resource) {
return 'Read resource';
}
);
$server->resource(
uri => 'file:///write',
scopes => ['mcp:write'],
code => sub ($resource) {
return 'Write resource';
}
);
get '/.well-known/oauth-protected-resource' => sub ($c) {
$c->render(
json => $server->oauth_metadata(
resource => 'http://example.com/mcp',
authorization_servers => ['https://auth.example.com']
)
);
};
# Fake token validation, replace with real OAuth access token verification in production
my $tokens = {
ro => {scopes => ['mcp:read'], role => 'user'},
rw => {scopes => ['mcp:read', 'mcp:write', 'mcp:something.custom'], role => 'user'},
admin => {scopes => ['mcp:read', 'mcp:write', 'mcp:something.custom'], role => 'admin'}
};
my $metadata_url = 'http://example.com/.well-known/oauth-protected-resource';
any '/mcp' => $server->to_action({
auth => sub ($c) {
return undef unless ($c->req->headers->authorization // '') =~ /^Bearer\s+(\S+)$/;
return undef unless my $token = $tokens->{$1};
$c->stash(role => $token->{role});
return {scopes => $token->{scopes}};
},
metadata_url => $metadata_url
});
my $t = Test::Mojo->new;
subtest 'Discovery' => sub {
$t->post_ok('/mcp' => json => {})
->status_is(401)
->header_like('WWW-Authenticate' => qr/^Bearer/)
->header_like('WWW-Authenticate' => qr/resource_metadata="\Q$metadata_url\E"/);
$t->post_ok('/mcp' => {Authorization => 'Bearer bogus'} => json => {})->status_is(401);
$t->get_ok('/.well-known/oauth-protected-resource')
->status_is(200)
->json_is('/scopes_supported' => ['mcp:read', 'mcp:something.custom', 'mcp:write'])
->json_is('/authorization_servers' => ['https://auth.example.com']);
};
subtest 'Read-only token' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'),
headers => {Authorization => 'Bearer ro'});
subtest 'Tools' => sub {
my $result = $client->list_tools;
is $result->{tools}[0]{name}, 'read_tool', 'read tool present';
is $result->{tools}[1], undef, 'no more tools';
is $result->{cacheScope}, 'private', 'scope restricted list is private';
is $client->call_tool('read_tool')->{content}[0]{text}, 'Read result', 'read tool call result';
eval { $client->call_tool('write_tool') };
like $@, qr/Error -32003: Insufficient scope/, 'write tool denied';
};
subtest 'Prompts' => sub {
my $result = $client->list_prompts;
is $result->{prompts}[0]{name}, 'read_prompt', 'read prompt present';
is $result->{prompts}[1], undef, 'no more prompts';
is $client->get_prompt('read_prompt')->{messages}[0]{content}{text}, 'Read prompt', 'read prompt result';
eval { $client->get_prompt('write_prompt') };
like $@, qr/Error -32003: Insufficient scope/, 'write prompt denied';
};
subtest 'Resources' => sub {
my $result = $client->list_resources;
is $result->{resources}[0]{uri}, 'file:///read', 'read resource present';
is $result->{resources}[1], undef, 'no more resources';
is $client->read_resource('file:///read')->{contents}[0]{text}, 'Read resource', 'read resource result';
eval { $client->read_resource('file:///write') };
like $@, qr/Error -32003: Insufficient scope/, 'write resource denied';
};
};
subtest 'Read-write token' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'),
headers => {Authorization => 'Bearer rw'});
subtest 'Tools' => sub {
my $result = $client->list_tools;
is $result->{tools}[0]{name}, 'read_tool', 'read tool present';
is $result->{tools}[1]{name}, 'write_tool', 'write tool present';
is $result->{tools}[2], undef, 'custom tool hidden by role';
is $client->call_tool('write_tool')->{content}[0]{text}, 'Write result', 'write tool call result';
eval { $client->call_tool('custom_tool') };
like $@, qr/Error -32602/, 'custom tool hidden by role';
};
subtest 'Prompts' => sub {
my $result = $client->list_prompts;
is $result->{prompts}[0]{name}, 'read_prompt', 'read prompt present';
is $result->{prompts}[1]{name}, 'write_prompt', 'write prompt present';
is $result->{prompts}[2], undef, 'no more prompts';
is $client->get_prompt('write_prompt')->{messages}[0]{content}{text}, 'Write prompt', 'write prompt result';
};
subtest 'Resources' => sub {
my $result = $client->list_resources;
is $result->{resources}[0]{uri}, 'file:///read', 'read resource present';
is $result->{resources}[1]{uri}, 'file:///write', 'write resource present';
is $result->{resources}[2], undef, 'no more resources';
is $client->read_resource('file:///write')->{contents}[0]{text}, 'Write resource', 'write resource result';
};
};
subtest 'Admin token' => sub {
my $client = MCP::Client->new(
ua => $t->ua,
url => $t->ua->server->url->path('/mcp'),
headers => {Authorization => 'Bearer admin'}
);
my $result = $client->list_tools;
is $result->{tools}[0]{name}, 'read_tool', 'read tool present';
is $result->{tools}[1]{name}, 'write_tool', 'write tool present';
is $result->{tools}[2]{name}, 'custom_tool', 'custom tool present';
is $result->{tools}[3], undef, 'no more tools';
is $client->call_tool('custom_tool')->{content}[0]{text}, 'custom result', 'custom tool call result';
};
subtest 'Insufficient scope challenge' => sub {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
my $call = {
jsonrpc => '2.0',
id => 1,
method => 'tools/call',
params => {name => 'write_tool', arguments => {}, _meta => $meta}
};
my $headers = {
Authorization => 'Bearer ro',
'MCP-Protocol-Version' => PROTOCOL_VERSION,
'Mcp-Method' => 'tools/call',
'Mcp-Name' => 'write_tool'
};
$t->post_ok('/mcp' => $headers => json => $call)
->status_is(403)
->header_like('WWW-Authenticate' => qr/error="insufficient_scope"/)
->header_like('WWW-Authenticate' => qr/scope="mcp:write"/);
};
done_testing;
MCP-0.15/t/PaxHeaders/headers.t 0000644 0000000 0000000 00000000130 15232632765 013210 x ustar 00 29 mtime=1785411061.34958293
30 atime=1785411061.352388426
29 ctime=1785411482.27587662
MCP-0.15/t/headers.t 0000644 0001750 0000144 00000016440 15232632765 012715 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Constants qw(HEADER_MISMATCH INVALID_PARAMS META_CLIENT_CAPABILITIES META_PROTOCOL_VERSION),
qw(METHOD_NOT_FOUND PROTOCOL_VERSION UNSUPPORTED_PROTOCOL_VERSION);
use MCP::Server;
my $server = MCP::Server->new;
$server->tool(
name => 'search',
input_schema => {
type => 'object',
properties => {
query => {type => 'string', 'x-mcp-header' => 'Query'},
limit => {type => 'integer', 'x-mcp-header' => 'Limit'},
pretty => {type => 'boolean', 'x-mcp-header' => 'Pretty'},
notes => {type => ['string', 'null'], 'x-mcp-header' => 'Notes'},
filter => {type => 'object', properties => {tag => {type => 'string', 'x-mcp-header' => 'Tag'}}}
}
},
code => sub ($tool, $args) {
return 'searched';
}
);
$server->tool(
name => "Ünicode",
code => sub ($tool, $args) {
return 'unicode';
}
);
any '/mcp' => $server->to_action({origins => ['https://example.com']});
my $t = Test::Mojo->new;
sub call ($name, $args, $headers) {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
my $body = {
jsonrpc => '2.0',
id => 1,
method => 'tools/call',
params => {name => $name, arguments => $args, _meta => $meta}
};
my %all = ('MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'tools/call', 'Mcp-Name' => $name, %$headers);
delete @all{grep { !defined $all{$_} } keys %all};
return $t->post_ok('/mcp' => \%all => json => $body);
}
subtest 'Routing headers' => sub {
call('search', {}, {})->status_is(200)->json_is('/result/content/0/text' => 'searched');
my $lower = {'Mcp-Method' => undef, 'Mcp-Name' => undef, 'mcp-method' => 'tools/call', 'mcp-name' => 'search'};
call('search', {}, $lower)->status_is(200)->json_is('/result/content/0/text' => 'searched');
call('search', {}, {'Mcp-Method' => undef})
->status_is(400)
->json_is('/error/code' => HEADER_MISMATCH)
->json_is('/error/message' => 'Missing Mcp-Method header');
call('search', {}, {'Mcp-Method' => 'tools/list'})
->status_is(400)
->json_is('/error/message' => 'Mcp-Method header does not match the request body');
call('search', {}, {'Mcp-Name' => undef})->status_is(400)->json_is('/error/message' => 'Missing Mcp-Name header');
call('search', {}, {'Mcp-Name' => 'other'})
->status_is(400)
->json_is('/error/message' => 'Mcp-Name header does not match the request body');
};
subtest 'Protocol version' => sub {
call('search', {}, {'MCP-Protocol-Version' => undef})
->status_is(400)
->json_is('/error/code' => HEADER_MISMATCH)
->json_is('/error/message' => 'Missing MCP-Protocol-Version header');
call('search', {}, {'MCP-Protocol-Version' => '2025-11-25'})
->status_is(400)
->json_is('/error/message' => 'MCP-Protocol-Version header does not match the request body');
};
subtest 'Base64 sentinel' => sub {
call("Ünicode", {}, {'Mcp-Name' => '=?base64?w5xuaWNvZGU=?='})
->status_is(200)
->json_is('/result/content/0/text' => 'unicode');
call("Ünicode", {}, {'Mcp-Name' => "Ünicode"})
->status_is(400)
->json_is('/error/message' => 'Invalid Mcp-Name header');
call('=?base64?x?=', {}, {'Mcp-Name' => '=?base64?PT9iYXNlNjQ/eD89?='})
->status_is(200)
->json_is('/error/code' => INVALID_PARAMS);
call('=?base64?x?=', {}, {'Mcp-Name' => '=?base64?x?='})
->status_is(400)
->json_is('/error/message' => 'Mcp-Name header does not match the request body');
};
subtest 'Parameter headers' => sub {
my $args = {query => 'perl', limit => 10, pretty => \1, filter => {tag => 'news'}};
my $all
= {'Mcp-Param-Query' => 'perl', 'Mcp-Param-Limit' => 10, 'Mcp-Param-Pretty' => 'true', 'Mcp-Param-Tag' => 'news'};
call('search', $args, $all)->status_is(200)->json_is('/result/content/0/text' => 'searched');
call('search', $args, {%$all, 'Mcp-Param-Limit' => '10.0'})
->status_is(200)
->json_is('/result/content/0/text' => 'searched');
call('search', $args, {%$all, 'Mcp-Param-Limit' => '11'})
->status_is(400)
->json_is('/error/message' => 'Mcp-Param-Limit header does not match the request body');
call('search', $args, {%$all, 'Mcp-Param-Tag' => undef})
->status_is(400)
->json_is('/error/message' => 'Missing Mcp-Param-Tag header');
call('search', {query => 'perl'}, {'Mcp-Param-Query' => 'perl'})
->status_is(200)
->json_is('/result/content/0/text' => 'searched');
call('search', {query => 'perl'}, {'Mcp-Param-Query' => 'perl', 'Mcp-Param-Limit' => 10})
->status_is(400)
->json_is('/error/message' => 'Unexpected Mcp-Param-Limit header');
call('search', {notes => undef}, {})->status_is(200)->json_is('/result/content/0/text' => 'searched');
call('search', {notes => undef}, {'Mcp-Param-Notes' => ''})
->status_is(400)
->json_is('/error/message' => 'Unexpected Mcp-Param-Notes header');
};
subtest 'Request meta' => sub {
my $body = {jsonrpc => '2.0', id => 1, method => 'tools/list', params => {}};
my $headers = {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'tools/list'};
$t->post_ok('/mcp' => $headers => json => $body)
->status_is(400)
->json_is('/error/code' => INVALID_PARAMS)
->json_is('/error/message' => 'Missing protocol version');
$body->{params}{_meta} = {META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
$t->post_ok('/mcp' => $headers => json => $body)
->status_is(400)
->json_is('/error/message' => 'Missing client capabilities');
$body->{params}{_meta} = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => '2025-11-25'};
$t->post_ok('/mcp' => {%$headers, 'MCP-Protocol-Version' => '2025-11-25'} => json => $body)
->status_is(400)
->json_is('/error/code' => UNSUPPORTED_PROTOCOL_VERSION)
->json_is('/error/data/supported' => [PROTOCOL_VERSION])
->json_is('/error/data/requested' => '2025-11-25');
};
subtest 'Unknown method' => sub {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
my $body = {jsonrpc => '2.0', id => 1, method => 'ping', params => {_meta => $meta}};
my $headers = {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'ping'};
$t->post_ok('/mcp' => $headers => json => $body)->status_is(404)->json_is('/error/code' => METHOD_NOT_FOUND);
};
subtest 'Notifications' => sub {
my $body = {jsonrpc => '2.0', method => 'notifications/cancelled', params => {requestId => 1}};
$t->post_ok('/mcp' => json => $body)->status_is(202)->content_is('');
};
subtest 'Origin' => sub {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
my $body = {jsonrpc => '2.0', id => 1, method => 'tools/list', params => {_meta => $meta}};
my $headers = {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'tools/list'};
$t->post_ok('/mcp' => {%$headers, Origin => 'https://example.com'} => json => $body)->status_is(200);
$t->post_ok('/mcp' => {%$headers, Origin => 'https://evil.com'} => json => $body)
->status_is(403)
->json_is('/error' => 'Origin not allowed');
};
subtest 'Invalid JSON' => sub {
$t->post_ok('/mcp' => {'Content-Type' => 'application/json'} => 'not json')
->status_is(400)
->json_is('/error' => 'Invalid JSON');
};
done_testing;
MCP-0.15/t/PaxHeaders/tool_validation.t 0000644 0000000 0000000 00000000074 15232342434 014762 x ustar 00 30 atime=1785410975.150529278
30 ctime=1785411482.276021634
MCP-0.15/t/tool_validation.t 0000644 0001750 0000144 00000002135 15232342434 014454 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use MCP::Tool;
use Mojo::JSON qw(false);
subtest 'Default input schema' => sub {
my $tool = MCP::Tool->new;
is $tool->validate_input({}), 0, 'empty object is valid';
is $tool->validate_input(undef), 1, 'undefined arguments are invalid';
};
subtest 'Required properties' => sub {
my $tool = MCP::Tool->new(
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']});
is $tool->validate_input({msg => 'hello'}), 0, 'required string is valid';
is $tool->validate_input({}), 1, 'missing required property is invalid';
is $tool->validate_input({msg => 23}), 1, 'wrong property type is invalid';
};
subtest 'Additional properties' => sub {
my $tool = MCP::Tool->new(
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, additionalProperties => false});
is $tool->validate_input({msg => 'hello'}), 0, 'known property is valid';
is $tool->validate_input({msg => 'hello', extra => 1}), 1, 'unknown property is invalid';
};
done_testing;
MCP-0.15/t/PaxHeaders/pod_coverage.t 0000644 0000000 0000000 00000000074 15176660006 014235 x ustar 00 30 atime=1785410975.150529278
30 ctime=1785411482.276067026
MCP-0.15/t/pod_coverage.t 0000644 0001750 0000144 00000000446 15176660006 013732 0 ustar 00sri users use Mojo::Base -strict;
use Test::More;
plan skip_all => 'set TEST_POD to enable this test (developer only!)' unless $ENV{TEST_POD} || $ENV{TEST_ALL};
plan skip_all => 'Test::Pod::Coverage 1.04+ required for this test!' unless eval 'use Test::Pod::Coverage 1.04; 1';
all_pod_coverage_ok();
MCP-0.15/t/PaxHeaders/legacy.t 0000644 0000000 0000000 00000000132 15232632765 013043 x ustar 00 30 mtime=1785411061.349781852
30 atime=1785411061.352388426
30 ctime=1785411482.276255931
MCP-0.15/t/legacy.t 0000644 0001750 0000144 00000015153 15232632765 012546 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Constants qw(HEADER_MISMATCH META_CLIENT_CAPABILITIES META_PROTOCOL_VERSION METHOD_NOT_FOUND),
qw(PROTOCOL_VERSION);
use MCP::Server;
use Mojo::File qw(curfile);
use lib curfile->dirname->child('lib')->to_string;
use MCPStdioTest;
my $server = MCP::Server->new(name => 'LegacyServer', version => '2.0.0');
$server->tool(
name => 'echo',
description => 'Echo the input text',
input_schema => {type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']},
code => sub ($tool, $args) {"Echo: $args->{msg}"}
);
$server->prompt(
name => 'greet',
arguments => [{name => 'who', required => \1}],
code => sub ($prompt, $args) {"Hello $args->{who}"}
);
$server->resource(uri => 'file:///readme', name => 'readme', code => sub ($resource) {'Read me'});
my $minimal = MCP::Server->new(name => 'MinimalServer', version => '1.0.0');
$minimal->tool(name => 'noop', input_schema => {type => 'object'}, code => sub ($tool, $args) {'ok'});
any '/mcp' => $server->to_action;
any '/minimal' => $minimal->to_action;
my $t = Test::Mojo->new;
sub legacy ($id, $method, $params = {}) {
my $body = {jsonrpc => '2.0', id => $id, method => $method, params => $params};
return $t->post_ok('/mcp' => {'MCP-Protocol-Version' => '2025-11-25'} => json => $body);
}
subtest 'Handshake' => sub {
my $params = {protocolVersion => '2025-11-25', capabilities => {}, clientInfo => {name => 'Old', version => '1'}};
$t->post_ok('/mcp' => json => {jsonrpc => '2.0', id => 1, method => 'initialize', params => $params})
->status_is(200)
->json_is('/result/protocolVersion' => '2025-11-25')
->json_is('/result/serverInfo/name' => 'LegacyServer')
->json_is('/result/capabilities' => {prompts => {}, resources => {}, tools => {}})
->json_hasnt('/result/capabilities/tools/listChanged');
$t->post_ok('/minimal' => json => {jsonrpc => '2.0', id => 1, method => 'initialize', params => $params})
->status_is(200)
->json_is('/result/capabilities' => {tools => {}});
$t->post_ok('/mcp' => json => {jsonrpc => '2.0', method => 'notifications/initialized'})->status_is(202);
legacy(2, 'ping')->status_is(200)->json_hasnt('/error');
};
subtest 'Tools' => sub {
legacy(3, 'tools/list')->status_is(200)->json_is('/result/tools/0/name' => 'echo');
legacy(4, 'tools/call', {name => 'echo', arguments => {msg => 'hi'}})
->status_is(200)
->json_is('/result/content/0/text' => 'Echo: hi');
legacy(5, 'tools/call', {name => 'echo', arguments => {}})
->status_is(200)
->json_is('/error/message' => 'Invalid arguments');
};
subtest 'Prompts and resources' => sub {
legacy(6, 'prompts/list')->status_is(200)->json_is('/result/prompts/0/name' => 'greet');
legacy(7, 'prompts/get', {name => 'greet', arguments => {who => 'world'}})
->status_is(200)
->json_is('/result/messages/0/content/text' => 'Hello world');
legacy(8, 'resources/list')->status_is(200)->json_is('/result/resources/0/uri' => 'file:///readme');
legacy(9, 'resources/read', {uri => 'file:///readme'})
->status_is(200)
->json_is('/result/contents/0/text' => 'Read me');
};
subtest 'No routing headers required' => sub {
my $body
= {jsonrpc => '2.0', id => 10, method => 'tools/call', params => {name => 'echo', arguments => {msg => 'x'}}};
$t->post_ok('/mcp' => {'MCP-Protocol-Version' => '2025-11-25'} => json => $body)
->status_is(200)
->json_is('/result/content/0/text' => 'Echo: x');
};
subtest 'Older revisions' => sub {
for my $version ('2024-11-05', '2025-03-26', '2025-06-18') {
my $params = {protocolVersion => $version, capabilities => {}, clientInfo => {name => 'Old', version => '1'}};
$t->post_ok('/mcp' => json => {jsonrpc => '2.0', id => 20, method => 'initialize', params => $params})
->status_is(200)
->json_is('/result/protocolVersion' => $version);
}
my $params = {protocolVersion => '1999-01-01', capabilities => {}};
$t->post_ok('/mcp' => json => {jsonrpc => '2.0', id => 21, method => 'initialize', params => $params})
->status_is(200)
->json_is('/result/protocolVersion' => '2025-11-25');
my $body
= {jsonrpc => '2.0', id => 22, method => 'tools/call', params => {name => 'echo', arguments => {msg => 'y'}}};
$t->post_ok('/mcp' => json => $body)->status_is(200)->json_is('/result/content/0/text' => 'Echo: y');
};
subtest 'Current clients are unaffected' => sub {
my $meta = {META_CLIENT_CAPABILITIES() => {}, META_PROTOCOL_VERSION() => PROTOCOL_VERSION};
my $body = {
jsonrpc => '2.0',
id => 11,
method => 'tools/call',
params => {name => 'echo', arguments => {msg => 'hi'}, _meta => $meta}
};
$t->post_ok('/mcp' => {'MCP-Protocol-Version' => PROTOCOL_VERSION} => json => $body)
->status_is(400)
->json_is('/error/code' => HEADER_MISMATCH)
->json_is('/error/message' => 'Missing Mcp-Method header');
my $headers = {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'tools/call', 'Mcp-Name' => 'echo'};
$t->post_ok('/mcp' => $headers => json => $body)->status_is(200)->json_is('/result/content/0/text' => 'Echo: hi');
$t->post_ok('/mcp' => $headers => json => {%$body, method => 'ping'})->status_is(400);
$t->post_ok('/mcp' => {%$headers, 'MCP-Protocol-Version' => '2025-11-25'} => json => $body)
->status_is(400)
->json_is('/error/message' => 'MCP-Protocol-Version header does not match the request body');
my $discover = {jsonrpc => '2.0', id => 12, method => 'server/discover', params => {_meta => $meta}};
$t->post_ok(
'/mcp' => {'MCP-Protocol-Version' => PROTOCOL_VERSION, 'Mcp-Method' => 'server/discover'} => json => $discover)
->status_is(200)
->json_is('/result/supportedVersions/0' => PROTOCOL_VERSION);
};
subtest 'Stdio' => sub {
plan skip_all => 'set TEST_STDIO to enable this test (developer only!)' unless $ENV{TEST_STDIO} || $ENV{TEST_ALL};
my $test = MCPStdioTest->new;
$test->run($^X, curfile->dirname->child('apps', 'stdio.pl')->to_string);
my $res = $test->send({jsonrpc => '2.0', id => 1, method => 'initialize', params => {}});
is $res->{id}, 1, 'request id';
is $res->{result}{protocolVersion}, '2025-11-25', 'protocol version';
is $res->{result}{serverInfo}{name}, 'PerlServer', 'server name';
$res
= $test->send({
jsonrpc => '2.0', id => 2, method => 'tools/call', params => {name => 'echo', arguments => {msg => 'hi'}}
});
is $res->{id}, 2, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'tool call result';
ok $test->stop, 'process stopped';
};
done_testing;
MCP-0.15/t/PaxHeaders/lib 0000644 0000000 0000000 00000000132 15232633632 012075 x ustar 00 30 mtime=1785411482.276335336
30 atime=1785411482.276429872
30 ctime=1785411482.276335336
MCP-0.15/t/lib/ 0000755 0001750 0000144 00000000000 15232633632 011650 5 ustar 00sri users MCP-0.15/t/lib/PaxHeaders/MCPStdioTest.pm 0000644 0000000 0000000 00000000132 15232632765 015000 x ustar 00 30 mtime=1785411061.349919634
30 atime=1785411061.353696318
30 ctime=1785411482.276429872
MCP-0.15/t/lib/MCPStdioTest.pm 0000644 0001750 0000144 00000002747 15232632765 014510 0 ustar 00sri users package MCPStdioTest;
use Mojo::Base -base, -signatures;
use Carp qw(croak);
use IPC::Run qw(finish pump start timeout);
use Time::HiRes qw(sleep);
use Mojo::JSON qw(decode_json encode_json);
use MCP::Client;
has client => sub { MCP::Client->new };
sub notify ($self, $method, $params) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($self->client->build_notification($method, $params)) . "\n";
return 1;
}
sub read_line ($self) {
$self->{timeout}->start(60);
pump $self->{run} until $self->{stdout} =~ s/^(.*)\n//;
return eval { decode_json($1) };
}
sub request ($self, $method, $params) {
$self->send_request($method, $params);
return $self->read_line;
}
sub send ($self, $request) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($request) . "\n";
return $self->read_line;
}
sub send_request ($self, $method, $params) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($self->client->build_request($method, $params)) . "\n";
return 1;
}
sub send_request_crlf ($self, $method, $params) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($self->client->build_request($method, $params)) . "\r\n";
return 1;
}
sub run ($self, @command) {
$self->{run} = start(\@command, \$self->{stdin}, \$self->{stdout}, \$self->{stderr}, $self->{timeout} = timeout(60));
}
sub stop ($self) {
return undef unless $self->{run};
finish($self->{run}) or croak "Command returned: $?";
delete $self->{run};
return 1;
}
1;
MCP-0.15/t/PaxHeaders/streaming.t 0000644 0000000 0000000 00000000132 15232632765 013570 x ustar 00 30 mtime=1785411061.350532404
30 atime=1785411061.353696318
30 ctime=1785411482.276783382
MCP-0.15/t/streaming.t 0000644 0001750 0000144 00000007524 15232632765 013276 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Constants qw(META_SUBSCRIPTION_ID PROTOCOL_VERSION);
use MCP::Server;
use Mojo::IOLoop;
use Mojo::JSON qw(true);
use Mojo::Promise;
my $server = MCP::Server->new;
$server->tool(
name => 'echo',
code => sub ($tool, $args) {
return 'echo';
}
);
$server->prompt(
name => 'plan',
code => sub ($prompt, $args) {
return 'plan';
}
);
$server->resource(
uri => 'file:///report',
code => sub ($resource) {
return 'report';
}
);
any '/mcp' => $server->to_action({streaming => 1, heartbeat => 0});
my $t = Test::Mojo->new;
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
sub settle ($delay = 0.1) {
my $tick = Mojo::Promise->new;
Mojo::IOLoop->timer($delay => sub { $tick->resolve });
return $tick->wait;
}
subtest 'Discovery' => sub {
my $caps = $client->discover->{capabilities};
is $caps->{prompts}{listChanged}, true, 'prompts listChanged advertised';
is $caps->{resources}{listChanged}, true, 'resources listChanged advertised';
is $caps->{tools}{listChanged}, true, 'tools listChanged advertised';
};
subtest 'Other methods' => sub {
$t->get_ok('/mcp')->status_is(405)->json_is('/error' => 'Method not allowed');
$t->delete_ok('/mcp')->status_is(405)->json_is('/error' => 'Method not allowed');
};
subtest 'List changed' => sub {
my @messages;
ok $client->listen(
{promptsListChanged => true, resourceSubscriptions => true, toolsListChanged => true},
sub ($message) {
push @messages, $message;
if (@messages == 1) {
$server->notify_list_changed('resources');
$server->notify_list_changed('prompts');
}
return @messages < 2;
}
),
'stream closed by callback';
my $ack = $messages[0];
is $ack->{jsonrpc}, '2.0', 'JSON-RPC version';
is $ack->{method}, 'notifications/subscriptions/acknowledged', 'acknowledged first';
is_deeply $ack->{params}{notifications}, {promptsListChanged => true, toolsListChanged => true},
'unsupported notification types dropped';
ok my $id = $ack->{params}{_meta}{+META_SUBSCRIPTION_ID}, 'subscription id';
my $changed = $messages[1];
is $changed->{method}, 'notifications/prompts/list_changed', 'unsubscribed type never delivered';
is $changed->{params}{_meta}{+META_SUBSCRIPTION_ID}, $id, 'subscription id';
is scalar @messages, 2, 'no more messages';
};
subtest 'List changed (no subscriptions)' => sub {
settle;
is_deeply $server->transport->subscriptions, {}, 'subscription removed on disconnect';
ok $server->notify_list_changed('tools'), 'broadcast attempted';
};
subtest 'Heartbeat' => sub {
my $transport = $server->transport;
$transport->heartbeat(0.1);
my $request = $client->build_request('subscriptions/listen', {notifications => {toolsListChanged => true}});
my $headers = {
Accept => 'text/event-stream',
'MCP-Protocol-Version' => PROTOCOL_VERSION,
'Mcp-Method' => 'subscriptions/listen'
};
my $tx = $t->ua->build_tx(POST => $t->ua->server->url->path('/mcp') => $headers => json => $request);
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
is $tx->res->code, 200, 'stream open';
is $tx->res->headers->content_type, 'text/event-stream', 'right content type';
# SSE parser strips comments
my $bytes = '';
Mojo::IOLoop->stream($tx->connection)->on(read => sub ($stream, $chunk) { $bytes .= $chunk });
settle 0.5;
like $bytes, qr/: keepalive/, 'heartbeat sent';
Mojo::IOLoop->remove($tx->connection);
$transport->heartbeat(0);
settle;
is_deeply $transport->subscriptions, {}, 'subscription removed on disconnect';
};
done_testing;
MCP-0.15/t/PaxHeaders/stdio.t 0000644 0000000 0000000 00000000132 15232632765 012721 x ustar 00 30 mtime=1785411061.350435173
30 atime=1785411061.353696318
30 ctime=1785411482.277289449
MCP-0.15/t/stdio.t 0000644 0001750 0000144 00000023735 15232632765 012431 0 ustar 00sri users use Mojo::Base -strict;
use Test::More;
BEGIN {
plan skip_all => 'set TEST_STDIO to enable this test (developer only!)' unless $ENV{TEST_STDIO} || $ENV{TEST_ALL};
}
use MCP::Constants qw(INTERNAL_ERROR META_LOG_LEVEL META_SERVER_INFO META_SUBSCRIPTION_ID PROTOCOL_VERSION);
use Mojo::File qw(curfile);
use Mojo::JSON qw(false true);
use lib curfile->dirname->child('lib')->to_string;
use MCPStdioTest;
my $test = MCPStdioTest->new;
$test->run($^X, curfile->dirname->child('apps', 'stdio.pl')->to_string);
subtest 'Discovery' => sub {
my $res = $test->request('server/discover', {});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 1, 'request id';
is_deeply $res->{result}{supportedVersions}, [PROTOCOL_VERSION], 'supported versions';
is_deeply $res->{result}{capabilities}{extensions}, {}, 'no extensions';
is $res->{result}{capabilities}{tools}{listChanged}, true, 'tools listChanged';
is $res->{result}{capabilities}{prompts}, undef, 'no prompts capability';
is $res->{result}{capabilities}{resources}, undef, 'no resources capability';
is $res->{result}{instructions}, undef, 'no instructions';
is $res->{result}{resultType}, 'complete', 'result type';
is $res->{result}{cacheScope}, 'public', 'cache scope';
is $res->{result}{ttlMs}, 0, 'cache ttl';
is $res->{result}{_meta}{+META_SERVER_INFO}{name}, 'PerlServer', 'server name';
is $res->{result}{_meta}{+META_SERVER_INFO}{version}, '1.0.0', 'server version';
};
subtest 'Unsupported protocol version' => sub {
my $req = $test->client->build_request('tools/list', {});
$req->{params}{_meta}{'io.modelcontextprotocol/protocolVersion'} = '2025-11-25';
my $res = $test->send($req);
is $res->{id}, 2, 'request id';
is $res->{error}{code}, -32022, 'error code';
is $res->{error}{data}{requested}, '2025-11-25', 'requested version';
is_deeply $res->{error}{data}{supported}, [PROTOCOL_VERSION], 'supported versions';
};
subtest 'Missing client capabilities' => sub {
my $req = $test->client->build_request('tools/list', {});
delete $req->{params}{_meta}{'io.modelcontextprotocol/clientCapabilities'};
my $res = $test->send($req);
is $res->{id}, 3, 'request id';
is $res->{error}{code}, -32602, 'error code';
};
subtest 'Unknown method' => sub {
my $res = $test->request('ping', {});
is $res->{id}, 4, 'request id';
is $res->{error}{code}, -32601, 'error code';
};
subtest 'List tools' => sub {
my $res = $test->request('tools/list', {});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 5, 'request id';
is $res->{result}{tools}[0]{name}, 'echo', 'tool name';
is $res->{result}{tools}[0]{description}, 'Echo the input text', 'tool description';
is $res->{result}{tools}[0]{inputSchema}{type}, 'object', 'input schema type';
is $res->{result}{cacheScope}, 'private', 'cache scope';
is $res->{result}{ttlMs}, 0, 'cache ttl';
ok $test->notify('notifications/cancelled', {requestId => 5, reason => 'AbortError: This operation was aborted'}),
'cancelled';
};
subtest 'Tool call' => sub {
my $res = $test->request('tools/call', {name => 'echo', arguments => {msg => 'hello mojo'}});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 6, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hello mojo', type => 'text'}], 'tool call result';
is $res->{result}{isError}, false, 'not an error';
is $res->{result}{resultType}, 'complete', 'result type';
is_deeply $res->{result}{_meta}{+META_SERVER_INFO}, {name => 'PerlServer', version => '1.0.0'}, 'server info';
};
subtest 'Unknown tool' => sub {
my $res = $test->request('tools/call', {name => 'nope', arguments => {}});
is $res->{id}, 7, 'request id';
is $res->{error}{code}, -32602, 'error code';
is $res->{error}{message}, "Tool 'nope' not found", 'error message';
};
subtest 'Tool call (async)' => sub {
my $res = $test->request('tools/call', {name => 'echo_async', arguments => {msg => 'hello mojo'}});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 8, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo (async): hello mojo', type => 'text'}], 'tool call result';
};
subtest 'Unicode' => sub {
my $res = $test->request('tools/call', {name => 'echo', arguments => {msg => 'i ♥ mcp'}});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 9, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: i ♥ mcp', type => 'text'}], 'tool call result';
};
subtest 'Tool call (log level not requested)' => sub {
my $res = $test->request('tools/call', {name => 'echo_log', arguments => {msg => 'hi'}});
is $res->{id}, 10, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'tool call result';
};
subtest 'Tool call (with notification)' => sub {
$test->send_request('tools/call',
{name => 'echo_log', arguments => {msg => 'hi'}, _meta => {META_LOG_LEVEL() => 'info'}});
my $notif = $test->read_line;
is $notif->{jsonrpc}, '2.0', 'JSON-RPC version';
is $notif->{id}, undef, 'no request id';
is $notif->{method}, 'notifications/message', 'notification method';
is $notif->{params}{level}, 'info', 'notification level';
is $notif->{params}{data}, 'hi', 'notification payload';
my $res = $test->read_line;
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 11, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'tool call result';
};
subtest 'Subscription' => sub {
$test->send_request('subscriptions/listen',
{notifications => {promptsListChanged => true, toolsListChanged => true}});
my $ack = $test->read_line;
is $ack->{jsonrpc}, '2.0', 'JSON-RPC version';
is $ack->{method}, 'notifications/subscriptions/acknowledged', 'notification method';
is $ack->{params}{_meta}{+META_SUBSCRIPTION_ID}, 12, 'subscription id';
is_deeply $ack->{params}{notifications}, {promptsListChanged => true, toolsListChanged => true}, 'honoured filter';
$test->send_request('tools/call', {name => 'reload', arguments => {}});
my $notif = $test->read_line;
is $notif->{id}, undef, 'no request id';
is $notif->{method}, 'notifications/tools/list_changed', 'notification method';
is $notif->{params}{_meta}{+META_SUBSCRIPTION_ID}, 12, 'subscription id';
my $res = $test->read_line;
is $res->{id}, 13, 'request id';
is_deeply $res->{result}{content}, [{text => 'reloaded', type => 'text'}], 'tool call result';
};
subtest 'Subscription (cancelled)' => sub {
ok $test->notify('notifications/cancelled', {requestId => 12}), 'cancelled';
my $res = $test->request('tools/call', {name => 'reload', arguments => {}});
is $res->{id}, 14, 'request id';
is_deeply $res->{result}{content}, [{text => 'reloaded', type => 'text'}], 'tool call result';
};
subtest 'Tool call (with progress)' => sub {
$test->send_request('tools/call',
{name => 'echo_progress', arguments => {msg => 'hi'}, _meta => {progressToken => 'p1'}});
my $notif = $test->read_line;
is $notif->{jsonrpc}, '2.0', 'JSON-RPC version';
is $notif->{id}, undef, 'no request id';
is $notif->{method}, 'notifications/progress', 'notification method';
is $notif->{params}{progressToken}, 'p1', 'progress token echoed';
is $notif->{params}{progress}, 0.5, 'progress value';
is $notif->{params}{total}, 1, 'total value';
is $notif->{params}{message}, 'half', 'progress message';
my $res = $test->read_line;
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 15, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'tool call result';
};
subtest 'Scoped tool (no scope enforcement over stdio)' => sub {
my $res = $test->request('tools/call', {name => 'echo_scoped', arguments => {msg => 'hi'}});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 16, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'tool call result';
};
subtest 'Tool call (CRLF line endings)' => sub {
$test->send_request_crlf('tools/call', {name => 'echo', arguments => {msg => 'hello mojo'}});
my $res = $test->read_line;
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 17, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hello mojo', type => 'text'}], 'tool call result';
};
subtest 'Tool call (exception)' => sub {
my $res = $test->request('tools/call', {name => 'boom', arguments => {}});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 18, 'request id';
is $res->{error}{code}, INTERNAL_ERROR, 'internal error';
is $res->{error}{message}, 'Internal error', 'error message';
unlike $res->{error}{message}, qr/kaboom/, 'exception is not leaked';
$res = $test->request('tools/call', {name => 'echo', arguments => {msg => 'hi'}});
is $res->{id}, 19, 'request id';
is_deeply $res->{result}{content}, [{text => 'Echo: hi', type => 'text'}], 'server survived';
};
ok $test->stop, 'process stopped';
done_testing;
MCP-0.15/t/PaxHeaders/lite_app.t 0000644 0000000 0000000 00000000132 15232632765 013374 x ustar 00 30 mtime=1785411061.350044414
30 atime=1785411061.353696318
30 ctime=1785411482.277351514
MCP-0.15/t/lite_app.t 0000644 0001750 0000144 00000041750 15232632765 013101 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Test::Mojo;
use Mojo::ByteStream qw(b);
use Mojo::File qw(curfile);
use Mojo::JSON qw(from_json true false);
use MCP::Client;
use MCP::Constants qw(META_SERVER_INFO PROTOCOL_VERSION);
use MCP::Server;
my $t = Test::Mojo->new(curfile->sibling('apps', 'lite_app.pl'));
subtest 'Normal HTTP endpoint' => sub {
$t->get_ok('/')->status_is(200)->content_like(qr/Hello MCP!/);
};
subtest 'List changed without streaming' => sub {
my $server = MCP::Server->new;
$server->to_action;
is $server->notify_list_changed('tools'), undef, 'no broadcast without streaming';
};
subtest 'MCP endpoint' => sub {
$t->get_ok('/mcp')->status_is(405)->content_like(qr/Method not allowed/);
$t->delete_ok('/mcp')->status_is(405)->content_like(qr/Method not allowed/);
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
subtest 'Discovery' => sub {
my $result = $client->discover;
is_deeply $result->{supportedVersions}, [PROTOCOL_VERSION], 'supported versions';
is_deeply $result->{capabilities}{extensions}, {}, 'no extensions';
is_deeply $result->{capabilities}{prompts}, {}, 'no listChanged for prompts';
is_deeply $result->{capabilities}{resources}, {}, 'no listChanged for resources';
is_deeply $result->{capabilities}{tools}, {}, 'no listChanged for tools';
is $result->{instructions}, undef, 'no instructions';
is $result->{resultType}, 'complete', 'result type';
is $result->{cacheScope}, 'public', 'cache scope';
is $result->{ttlMs}, 0, 'cache ttl';
is $result->{_meta}{+META_SERVER_INFO}{name}, 'PerlServer', 'server name';
is $result->{_meta}{+META_SERVER_INFO}{version}, '1.0.0', 'server version';
};
subtest 'List tools' => sub {
my $result = $client->list_tools;
is $result->{resultType}, 'complete', 'result type';
is $result->{cacheScope}, 'public', 'cache scope';
is $result->{ttlMs}, 0, 'cache ttl';
is $result->{tools}[0]{name}, 'echo', 'tool name';
is $result->{tools}[0]{description}, 'Echo the input text', 'tool description';
is_deeply $result->{tools}[0]{inputSchema},
{type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']}, 'tool input schema';
ok !exists($result->{tools}[0]{outputSchema}), 'no output schema';
is_deeply $result->{tools}[0]{annotations}, {title => 'echo'}, 'corrent number of annotations';
is $result->{tools}[1]{name}, 'echo_async', 'tool name';
is $result->{tools}[1]{description}, 'Echo the input text asynchronously', 'tool description';
is_deeply $result->{tools}[1]{inputSchema},
{type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']}, 'tool input schema';
ok !exists($result->{tools}[1]{outputSchema}), 'no output schema';
is keys %{$result->{tools}[1]{annotations}}, 0, 'empty annotations not serialized';
is $result->{tools}[2]{name}, 'echo_header', 'tool name';
is $result->{tools}[2]{description}, 'Echo the input text with a header', 'tool description';
is_deeply $result->{tools}[2]{inputSchema},
{type => 'object', properties => {msg => {type => 'string'}}, required => ['msg']}, 'tool input schema';
ok !exists($result->{tools}[2]{outputSchema}), 'no output schema';
is $result->{tools}[3]{name}, 'time', 'tool name';
is $result->{tools}[3]{description}, 'Get the current time in epoch format', 'tool description';
is_deeply $result->{tools}[3]{inputSchema}, {type => 'object'}, 'tool input schema';
ok !exists($result->{tools}[3]{outputSchema}), 'no output schema';
is $result->{tools}[4]{name}, 'generate_image', 'tool name';
is $result->{tools}[4]{description}, 'Generate a simple image from text', 'tool description';
is_deeply $result->{tools}[4]{inputSchema},
{type => 'object', properties => {text => {type => 'string'}}, required => ['text']}, 'tool input schema';
ok !exists($result->{tools}[4]{outputSchema}), 'no output schema';
is $result->{tools}[5]{name}, 'generate_audio', 'tool name';
is $result->{tools}[5]{description}, 'Generate audio from text', 'tool description';
is_deeply $result->{tools}[5]{inputSchema},
{type => 'object', properties => {text => {type => 'string'}}, required => ['text']}, 'tool input schema';
ok !exists($result->{tools}[5]{outputSchema}), 'no output schema';
is $result->{tools}[6]{name}, 'find_resource', 'tool name';
is $result->{tools}[6]{description}, 'Find a resource for the given text', 'tool description';
is_deeply $result->{tools}[6]{inputSchema},
{type => 'object', properties => {text => {type => 'string'}}, required => ['text']}, 'tool input schema';
ok !exists($result->{tools}[6]{outputSchema}), 'no output schema';
ok exists($result->{tools}[6]{annotations}), 'has annotations';
is keys %{$result->{tools}[6]{annotations}}, 5, 'all annotations are serialized';
is $result->{tools}[6]{annotations}{readOnlyHint}, true, 'annotation has correct value';
is $result->{tools}[7]{name}, 'current_weather', 'tool name';
is $result->{tools}[7]{description}, 'Get current weather data for a location', 'tool description';
my $input_schema = {
type => 'object',
properties => {location => {type => 'string', description => 'City name or zip code'}},
required => ['location']
};
is_deeply $result->{tools}[7]{inputSchema}, $input_schema, 'tool input schema';
my $output_schema = {
type => 'object',
properties => {
temperature => {type => 'number', description => 'Temperature in celsius'},
conditions => {type => 'string', description => 'Weather conditions description'},
humidity => {type => 'number', description => 'Humidity percentage'}
},
required => ['temperature', 'conditions', 'humidity']
};
is_deeply $result->{tools}[7]{outputSchema}, $output_schema, 'tool output schema';
};
subtest 'Tool call' => sub {
my $result = $client->call_tool('echo', {msg => 'hello mojo'});
is $result->{content}[0]{text}, 'Echo: hello mojo', 'tool call result';
is $result->{resultType}, 'complete', 'result type';
is $result->{cacheScope}, undef, 'no cache scope';
is $result->{ttlMs}, undef, 'no cache ttl';
is_deeply $result->{_meta}{+META_SERVER_INFO}, {name => 'PerlServer', version => '1.0.0'}, 'server info';
};
subtest 'Tool call (async)' => sub {
my $result = $client->call_tool('echo_async', {msg => 'hello mojo'});
is $result->{content}[0]{text}, 'Echo (async): hello mojo', 'tool call result';
};
subtest 'Tool call (Unicode)' => sub {
my $result = $client->call_tool('echo', {msg => 'i ♥ mcp'});
is $result->{content}[0]{text}, 'Echo: i ♥ mcp', 'tool call result';
};
subtest 'Tool call (Unicode and async)' => sub {
my $result = $client->call_tool('echo_async', {msg => 'i ♥ mcp'});
is $result->{content}[0]{text}, 'Echo (async): i ♥ mcp', 'tool call result';
};
subtest 'Tool call (with HTTP header)' => sub {
$client->ua->once(
start => sub ($ua, $tx) {
$tx->req->headers->header('MCP-Custom-Header' => 'TestHeaderWorks');
}
);
my $result = $client->call_tool('echo_header', {msg => 'hello mojo'});
is $result->{content}[0]{text}, 'Echo with header: hello mojo (Header: TestHeaderWorks)', 'tool call result';
};
subtest 'Tool call (no arguments)' => sub {
my $result = $client->call_tool('time');
like $result->{content}[0]{text}, qr/^\d+$/, 'tool call result';
};
subtest 'Tool call (image)' => sub {
my $result = $client->call_tool('generate_image', {text => 'a cat?'});
is $result->{content}[0]{mimeType}, 'image/png', 'tool call image type';
is b($result->{content}[0]{data})->b64_decode->md5_sum, 'f55ea29e32455f6314ecc8b5c9f0590b',
'tool call image result';
is_deeply $result->{content}[0]{annotations}, {audience => ['user']}, 'tool call image annotations';
};
subtest 'Tool call (audio)' => sub {
my $result = $client->call_tool('generate_audio', {text => 'a cat?'});
is $result->{content}[0]{mimeType}, 'audio/wav', 'tool call audio type';
is b($result->{content}[0]{data})->b64_decode->md5_sum, 'e5de045688efc9777361ee3f7d47551d',
'tool call audio result';
};
subtest 'Tool call (resource link)' => sub {
my $result = $client->call_tool('find_resource', {text => 'a cat?'});
is $result->{content}[0]{uri}, 'file:///path/to/resource.txt', 'tool call resource uri';
is $result->{content}[0]{name}, 'sample', 'tool call resource name';
is $result->{content}[0]{description}, 'An example resource', 'tool call resource description';
is $result->{content}[0]{mimeType}, 'text/plain', 'tool call resource mime type';
};
subtest 'Tool call (structured)' => sub {
my $result = $client->call_tool('current_weather', {location => 'Bremen'});
my $json = from_json($result->{content}[0]{text});
is $json->{temperature}, 22, 'temperature';
is $json->{conditions}, 'Partly cloudy', 'conditions';
is $json->{humidity}, 65, 'humidity';
is_deeply $result->{structuredContent}, $json, 'structured content';
my $result2 = $client->call_tool('current_weather', {location => 'Whatever'});
my $json2 = from_json($result2->{content}[0]{text});
is $json2->{temperature}, 19, 'temperature';
is $json2->{conditions}, 'Raining', 'conditions';
is $json2->{humidity}, 80, 'humidity';
is_deeply $result2->{structuredContent}, $json2, 'structured content';
};
subtest 'Unknown method' => sub {
my $res = $client->send_request($client->build_request('unknownMethod'));
is $res->{error}{code}, -32601, 'error code';
is $res->{error}{message}, "Method 'unknownMethod' not found", 'error message';
};
subtest 'Invalid tool name' => sub {
eval { $client->call_tool('unknownTool', {}) };
like $@, qr/Error -32602: Tool 'unknownTool' not found/, 'right error';
};
subtest 'Invalid tool arguments' => sub {
eval { $client->call_tool('echo', {just => 'a test'}) };
like $@, qr/Error -32602: Invalid arguments/, 'right error';
};
subtest 'List prompts' => sub {
my $result = $client->list_prompts;
is $result->{cacheScope}, 'public', 'cache scope';
is $result->{ttlMs}, 0, 'cache ttl';
is $result->{prompts}[0]{name}, 'time', 'prompt name';
is $result->{prompts}[0]{description}, 'Tell the user the time', 'prompt description';
is_deeply $result->{prompts}[0]{arguments}, [], 'no prompt arguments';
is $result->{prompts}[1]{name}, 'prompt_echo_async', 'prompt name';
is $result->{prompts}[1]{description}, 'Make a prompt from the input text', 'prompt description';
is_deeply $result->{prompts}[1]{arguments}, [{name => 'msg', description => 'Message to echo', required => 1}],
'prompt arguments';
is $result->{prompts}[2]{name}, 'prompt_echo_header', 'prompt name';
is $result->{prompts}[2]{description}, 'Make a prompt from the input text with a header', 'prompt description';
is_deeply $result->{prompts}[2]{arguments}, [{name => 'msg', description => 'Message to echo', required => 1}],
'prompt arguments';
is $result->{prompts}[3], undef, 'no more prompts';
};
subtest 'Get prompt' => sub {
my $result = $client->get_prompt('time');
is $result->{messages}[0]{role}, 'user', 'prompt role';
is $result->{messages}[0]{content}{text}, 'Tell the user the current time', 'prompt result';
};
subtest 'Get prompt (async)' => sub {
my $result = $client->get_prompt('prompt_echo_async', {msg => 'hello mojo'});
is $result->{messages}[0]{role}, 'user', 'prompt role';
is $result->{messages}[0]{content}{text}, 'Tell the user (async): hello mojo', 'prompt result';
};
subtest 'Get prompt (Unicode)' => sub {
my $result = $client->get_prompt('prompt_echo_async', {msg => 'i ♥ mcp'});
is $result->{messages}[0]{role}, 'user', 'prompt role';
is $result->{messages}[0]{content}{text}, 'Tell the user (async): i ♥ mcp', 'prompt result';
};
subtest 'Get prompt (with HTTP header)' => sub {
$client->ua->once(
start => sub ($ua, $tx) {
$tx->req->headers->header('MCP-Custom-Header' => 'TestHeaderWorks');
}
);
my $result = $client->get_prompt('prompt_echo_header', {msg => 'hello mojo'});
is $result->{description}, 'Echoed message with header', 'prompt description';
is $result->{messages}[0]{role}, 'assistant', 'prompt role';
is $result->{messages}[0]{content}{text}, 'Prompt with header: hello mojo (Header: TestHeaderWorks)',
'prompt result';
};
subtest 'Invalid prompt name' => sub {
eval { $client->get_prompt('unknownPrompt', {}) };
like $@, qr/Error -32602: Prompt 'unknownPrompt' not found/, 'right error';
};
subtest 'Invalid prompt arguments' => sub {
eval { $client->get_prompt('prompt_echo_async', {just => 'a test'}) };
like $@, qr/Error -32602: Invalid arguments/, 'right error';
};
subtest 'List resources' => sub {
my $result = $client->list_resources;
is $result->{cacheScope}, 'public', 'cache scope';
is $result->{ttlMs}, 0, 'cache ttl';
is $result->{resources}[0]{name}, 'static_text', 'resource name';
is $result->{resources}[0]{description}, 'A static text resource', 'resource description';
is $result->{resources}[0]{uri}, 'file:///path/to/static.txt', 'resource uri';
is $result->{resources}[0]{mimeType}, 'text/plain', 'resource mime type';
is $result->{resources}[1]{name}, 'static_image', 'resource name';
is $result->{resources}[1]{description}, 'A static image resource', 'resource description';
is $result->{resources}[1]{uri}, 'file:///path/to/image.png', 'resource uri';
is $result->{resources}[1]{mimeType}, 'image/png', 'resource mime type';
is $result->{resources}[2]{name}, 'async_text', 'resource name';
is $result->{resources}[2]{description}, 'An asynchronous text resource', 'resource description';
is $result->{resources}[2]{uri}, 'file:///path/to/async.txt', 'resource uri';
is $result->{resources}[2]{mimeType}, 'text/plain', 'resource mime type';
is $result->{resources}[3], undef, 'no more resources';
};
subtest 'Read resource (text)' => sub {
my $result = $client->read_resource('file:///path/to/static.txt');
is $result->{resultType}, 'complete', 'result type';
is $result->{cacheScope}, 'public', 'cache scope';
is $result->{ttlMs}, 0, 'cache ttl';
is $result->{contents}[0]{uri}, 'file:///path/to/static.txt', 'resource uri';
is $result->{contents}[0]{mimeType}, 'text/plain', 'resource mime type';
is $result->{contents}[0]{text}, 'This is a static text resource.', 'resource text';
};
subtest 'Read resource (image)' => sub {
my $result = $client->read_resource('file:///path/to/image.png');
is $result->{contents}[0]{uri}, 'file:///path/to/image.png', 'resource uri';
is $result->{contents}[0]{mimeType}, 'image/png', 'resource mime type';
is b($result->{contents}[0]{blob})->b64_decode->md5_sum, 'f55ea29e32455f6314ecc8b5c9f0590b', 'resource image data';
};
subtest 'Read resource (async)' => sub {
my $result = $client->read_resource('file:///path/to/async.txt');
is $result->{contents}[0]{uri}, 'file:///path/to/async.txt', 'resource uri';
is $result->{contents}[0]{mimeType}, 'text/plain', 'resource mime type';
is $result->{contents}[0]{text}, 'This is an asynchronous text resource.', 'resource text';
};
subtest 'Invalid resource uri' => sub {
eval { $client->read_resource('file://whatever') };
like $@, qr{Error -32602: Resource 'file://whatever' not found}, 'right error';
};
};
done_testing;
MCP-0.15/t/PaxHeaders/notifications.t 0000644 0000000 0000000 00000000132 15232632765 014450 x ustar 00 30 mtime=1785411061.350222831
30 atime=1785411061.352388426
30 ctime=1785411482.277400158
MCP-0.15/t/notifications.t 0000644 0001750 0000144 00000010464 15232632765 014153 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Constants qw(META_LOG_LEVEL METHOD_NOT_FOUND);
use MCP::Server;
use Mojo::IOLoop;
use Mojo::Promise;
my $server = MCP::Server->new;
$server->tool(
name => 'progress',
code => sub ($tool, $args) {
my $sent = $tool->context->notify_progress(1, 2, 'halfway');
return $sent ? 'sent' : 'no token';
}
);
$server->tool(
name => 'async_progress',
code => sub ($tool, $args) {
my $context = $tool->context;
my $promise = Mojo::Promise->new;
Mojo::IOLoop->timer(
0.1 => sub {
$context->notify_progress(2, 2, 'late');
$promise->resolve('done');
}
);
return $promise;
}
);
$server->tool(
name => 'log',
code => sub ($tool, $args) {
my $context = $tool->context;
my @sent = map { $context->notify_log($_, "$_ message") ? 1 : 0 } qw(debug warning);
return join ',', @sent;
}
);
any '/mcp' => $server->to_action;
my $t = Test::Mojo->new;
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
my @notifications;
$client->on(notification => sub ($client, $notification) { push @notifications, $notification });
subtest 'Progress' => sub {
my $request
= $client->build_request('tools/call', {name => 'progress', arguments => {}, _meta => {progressToken => 'tok-1'}});
my $result = $client->send_request($request)->{result};
is $result->{content}[0]{text}, 'sent', 'tool call result';
my $progress = shift @notifications;
is $progress->{jsonrpc}, '2.0', 'JSON-RPC version';
is $progress->{method}, 'notifications/progress', 'notification method';
is $progress->{params}{progressToken}, 'tok-1', 'progress token echoed';
is $progress->{params}{progress}, 1, 'progress value';
is $progress->{params}{total}, 2, 'total value';
is $progress->{params}{message}, 'halfway', 'progress message';
is scalar @notifications, 0, 'no more notifications';
};
subtest 'Progress (async)' => sub {
my $request = $client->build_request('tools/call',
{name => 'async_progress', arguments => {}, _meta => {progressToken => 'tok-2'}});
my $result = $client->send_request($request)->{result};
is $result->{content}[0]{text}, 'done', 'tool call result';
my $progress = shift @notifications;
is $progress->{method}, 'notifications/progress', 'notification method';
is $progress->{params}{progressToken}, 'tok-2', 'progress token echoed';
is $progress->{params}{message}, 'late', 'progress message';
is scalar @notifications, 0, 'no more notifications';
};
subtest 'Progress (no token)' => sub {
is $client->call_tool('progress')->{content}[0]{text}, 'no token', 'notify_progress declines without a token';
is scalar @notifications, 0, 'no notifications';
};
subtest 'Logging' => sub {
my $request
= $client->build_request('tools/call', {name => 'log', arguments => {}, _meta => {META_LOG_LEVEL() => 'info'}});
my $result = $client->send_request($request)->{result};
is $result->{content}[0]{text}, '0,1', 'levels below the minimum are declined';
my $message = shift @notifications;
is $message->{method}, 'notifications/message', 'notification method';
is $message->{params}{level}, 'warning', 'notification level';
is $message->{params}{data}, 'warning message', 'notification payload';
is scalar @notifications, 0, 'no more notifications';
};
subtest 'Logging (no level)' => sub {
is $client->call_tool('log')->{content}[0]{text}, '0,0', 'nothing is logged unless the client asks';
is scalar @notifications, 0, 'no notifications';
};
subtest 'Subscriptions without streaming' => sub {
is $server->notify_list_changed('tools'), undef, 'no broadcast without streaming';
my $request = $client->build_request('subscriptions/listen', {notifications => {toolsListChanged => 1}});
my $response = $client->send_request($request);
is $response->{error}{code}, METHOD_NOT_FOUND, 'method not found';
};
done_testing;
MCP-0.15/t/PaxHeaders/mrtr.t 0000644 0000000 0000000 00000000132 15232632765 012563 x ustar 00 30 mtime=1785411061.350155398
30 atime=1785411061.352388426
30 ctime=1785411482.277596733
MCP-0.15/t/mrtr.t 0000644 0001750 0000144 00000013613 15232632765 012265 0 ustar 00sri users use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use MCP::Client;
use MCP::Server;
use Mojo::JSON qw(true);
my $deploy = sub ($tool, $args) {
my $context = $tool->context;
my $state = $context->request_state;
my $confirm = ($context->input_responses // {})->{confirm} // {};
return $tool->text_result("Deployed $state->{target}") if $state && ($confirm->{action} // '') eq 'accept';
return $tool->input_required(
{
confirm => {
method => 'elicitation/create',
params => {
message => "Really deploy to $args->{target}?",
requestedSchema => {type => 'object', properties => {ok => {type => 'boolean'}}}
}
}
},
{target => $args->{target}}
);
};
my $schema = {type => 'object', properties => {target => {type => 'string'}}, required => ['target']};
my $server = MCP::Server->new(state_secret => 'test-secret');
$server->tool(name => 'deploy', input_schema => $schema, code => $deploy);
$server->tool(
name => 'steal',
code => sub ($tool, $args) {
my $state = $tool->context->request_state;
return $tool->text_result($state ? "Stolen $state->{target}" : 'No state');
}
);
$server->prompt(
name => 'plan',
code => sub ($prompt, $args) {
return $prompt->text_prompt('Ready to deploy') if $prompt->context->request_state;
return $prompt->input_required(undef, {asked => 1});
}
);
$server->resource(
uri => 'file:///report',
cache_ttl => 60_000,
code => sub ($resource) {
return 'Deployment report';
}
);
my $expired = MCP::Server->new(state_secret => 'test-secret', state_timeout => -1);
$expired->tool(name => 'deploy', input_schema => $schema, code => $deploy);
any '/mcp' => $server->to_action({
auth => sub ($c) {
return undef unless ($c->req->headers->authorization // '') =~ /^Bearer\s+(\S+)$/;
return {principal => $1};
}
});
any '/expired' => $expired->to_action;
my $t = Test::Mojo->new;
my $client = MCP::Client->new(
ua => $t->ua,
url => $t->ua->server->url->path('/mcp'),
headers => {Authorization => 'Bearer alice'}
);
my $state;
subtest 'Input required' => sub {
my $result = $client->call_tool('deploy', {target => 'prod'});
is $result->{resultType}, 'input_required', 'result type';
is $result->{inputRequests}{confirm}{method}, 'elicitation/create', 'input request method';
is $result->{inputRequests}{confirm}{params}{message}, 'Really deploy to prod?', 'input request message';
is $result->{content}, undef, 'no content';
is $result->{ttlMs}, undef, 'no cache ttl';
is $result->{cacheScope}, undef, 'no cache scope';
ok $state = $result->{requestState}, 'request state';
};
subtest 'Retry' => sub {
my $responses = {confirm => {action => 'accept', content => {ok => true}}};
my $result
= $client->call_tool('deploy', {target => 'prod'}, {input_responses => $responses, request_state => $state});
is $result->{resultType}, 'complete', 'result type';
is_deeply $result->{content}, [{text => 'Deployed prod', type => 'text'}], 'tool call result';
};
subtest 'Retry (no input responses)' => sub {
my $result = $client->call_tool('deploy', {target => 'prod'}, {request_state => $state});
is $result->{resultType}, 'input_required', 'asked again';
};
subtest 'Tampered state' => sub {
my $tampered = $state;
substr $tampered, 0, 1, 'X';
my $responses = {confirm => {action => 'accept', content => {ok => true}}};
my $result
= $client->call_tool('deploy', {target => 'prod'}, {input_responses => $responses, request_state => $tampered});
is $result->{resultType}, 'input_required', 'asked again';
};
subtest 'State from another tool' => sub {
my $result = $client->call_tool('steal', {}, {request_state => $state});
is_deeply $result->{content}, [{text => 'No state', type => 'text'}], 'tool call result';
};
subtest 'State from another principal' => sub {
my $bob = MCP::Client->new(
ua => $t->ua,
url => $t->ua->server->url->path('/mcp'),
headers => {Authorization => 'Bearer bob'}
);
my $responses = {confirm => {action => 'accept', content => {ok => true}}};
my $result = $bob->call_tool('deploy', {target => 'prod'}, {input_responses => $responses, request_state => $state});
is $result->{resultType}, 'input_required', 'asked again';
};
subtest 'Expired state' => sub {
my $stale = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/expired'));
my $first = $stale->call_tool('deploy', {target => 'prod'});
is $first->{resultType}, 'input_required', 'result type';
my $responses = {confirm => {action => 'accept', content => {ok => true}}};
my $result = $stale->call_tool(
'deploy',
{target => 'prod'},
{input_responses => $responses, request_state => $first->{requestState}}
);
is $result->{resultType}, 'input_required', 'asked again';
};
subtest 'Prompt' => sub {
my $result = $client->get_prompt('plan');
is $result->{resultType}, 'input_required', 'result type';
is $result->{inputRequests}, undef, 'no input requests';
ok $result->{requestState}, 'request state';
my $retry = $client->get_prompt('plan', {}, {request_state => $result->{requestState}});
is $retry->{resultType}, 'complete', 'result type';
is $retry->{messages}[0]{content}{text}, 'Ready to deploy', 'prompt result';
};
subtest 'Resource cache hints' => sub {
my $result = $client->read_resource('file:///report');
is $result->{ttlMs}, 60_000, 'cache ttl';
is $result->{cacheScope}, 'public', 'cache scope';
my $retry = $client->read_resource('file:///report', {request_state => $state});
is $retry->{ttlMs}, undef, 'no cache ttl';
is $retry->{cacheScope}, undef, 'no cache scope';
};
done_testing;
MCP-0.15/t/PaxHeaders/pod.t 0000644 0000000 0000000 00000000074 15176660006 012362 x ustar 00 30 atime=1785410975.150529278
30 ctime=1785411482.277836907
MCP-0.15/t/pod.t 0000644 0001750 0000144 00000000431 15176660006 012051 0 ustar 00sri users use Mojo::Base -strict;
use Test::More;
plan skip_all => 'set TEST_POD to enable this test (developer only!)' unless $ENV{TEST_POD} || $ENV{TEST_ALL};
plan skip_all => 'Test::Pod 1.14+ required for this test!' unless eval 'use Test::Pod 1.14; 1';
all_pod_files_ok();
MCP-0.15/PaxHeaders/lib 0000644 0000000 0000000 00000000132 15232633632 011632 x ustar 00 30 mtime=1785411482.275786169
30 atime=1785411482.275092781
30 ctime=1785411482.275786169
MCP-0.15/lib/ 0000755 0001750 0000144 00000000000 15232633632 011405 5 ustar 00sri users MCP-0.15/lib/PaxHeaders/MCP 0000644 0000000 0000000 00000000132 15232633632 012251 x ustar 00 30 mtime=1785411482.277596733
30 atime=1785411482.275128753
30 ctime=1785411482.277596733
MCP-0.15/lib/MCP/ 0000755 0001750 0000144 00000000000 15232633632 012024 5 ustar 00sri users MCP-0.15/lib/MCP/PaxHeaders/Prompt.pm 0000644 0000000 0000000 00000000132 15232632765 014153 x ustar 00 30 mtime=1785411061.347765042
30 atime=1785411061.353696318
30 ctime=1785411482.275128753
MCP-0.15/lib/MCP/Prompt.pm 0000644 0001750 0000144 00000005265 15232632765 013661 0 ustar 00sri users package MCP::Prompt;
use Mojo::Base 'MCP::Primitive', -signatures;
use Scalar::Util qw(blessed);
has arguments => sub { [] };
has code => sub { die 'Prompt code not implemented' };
has description => 'Generic MCP prompt';
has name => 'prompt';
sub call ($self, $args, $context) {
local $self->{context} = $context;
my $result = $self->code->($self, $args);
return $result->then(sub { $self->_type_check($_[0]) }) if blessed($result) && $result->isa('Mojo::Promise');
return $self->_type_check($result);
}
sub text_prompt ($self, $text, $role = 'user', $description = undef) {
my $result = {messages => [{role => $role, content => {type => 'text', text => "$text"}}]};
$result->{description} = $description if defined $description;
return $result;
}
sub validate_input ($self, $args) {
for my $arg (@{$self->arguments}) {
next unless $arg->{required};
return 1 unless exists $args->{$arg->{name}};
}
return 0;
}
sub _type_check ($self, $result) {
return $result if ref $result eq 'HASH' && (exists $result->{messages} || exists $result->{resultType});
return $self->text_prompt($result);
}
1;
=encoding utf8
=head1 NAME
MCP::Prompt - Prompt container
=head1 SYNOPSIS
use MCP::Prompt;
my $prompt = MCP::Prompt->new;
=head1 DESCRIPTION
L is a container for prompts.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 arguments
my $args = $prompt->arguments;
$prompt = $prompt->arguments([{name => 'foo', description => 'Whatever', required => 1}]);
Arguments for the prompt.
=head2 code
my $code = $prompt->code;
$prompt = $prompt->code(sub { ... });
Prompt code.
=head2 description
my $description = $prompt->description;
$prompt = $prompt->description('A brief description of the prompt');
Description of the prompt.
=head2 name
my $name = $prompt->name;
$prompt = $prompt->name('my_prompt');
Name of the Prompt.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 call
my $result = $prompt->call($args, $context);
Calls the prompt with the given arguments and context, returning a result. The result can be a promise or a direct
value.
=head2 text_prompt
my $result = $prompt->text_prompt('Some text');
my $result = $prompt->text_prompt('Some text', $role);
my $result = $prompt->text_prompt('Some text', $role, $description);
Returns a text prompt in the expected format.
=head2 validate_input
my $bool = $prompt->validate_input($args);
Validates the input arguments. Returns true if validation failed.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/PaxHeaders/Constants.pm 0000644 0000000 0000000 00000000132 15232632765 014646 x ustar 00 30 mtime=1785411061.347558576
30 atime=1785411061.353696318
30 ctime=1785411482.275193444
MCP-0.15/lib/MCP/Constants.pm 0000644 0001750 0000144 00000007301 15232632765 014345 0 ustar 00sri users package MCP::Constants;
use Mojo::Base 'Exporter';
use constant {
HEADER_MISMATCH => -32020,
INSUFFICIENT_SCOPE => -32003,
INTERNAL_ERROR => -32603,
INVALID_PARAMS => -32602,
INVALID_REQUEST => -32600,
META_CLIENT_CAPABILITIES => 'io.modelcontextprotocol/clientCapabilities',
META_CLIENT_INFO => 'io.modelcontextprotocol/clientInfo',
META_LOG_LEVEL => 'io.modelcontextprotocol/logLevel',
META_PROTOCOL_VERSION => 'io.modelcontextprotocol/protocolVersion',
META_SERVER_INFO => 'io.modelcontextprotocol/serverInfo',
META_SUBSCRIPTION_ID => 'io.modelcontextprotocol/subscriptionId',
METHOD_NOT_FOUND => -32601,
MISSING_CLIENT_CAPABILITY => -32021,
PARSE_ERROR => -32700,
PROTOCOL_VERSION => $ENV{MOJO_MCP_VERSION} || '2026-07-28',
UNSUPPORTED_PROTOCOL_VERSION => -32022
};
use constant SUPPORTED_VERSIONS => [PROTOCOL_VERSION];
our @EXPORT_OK = (
qw(HEADER_MISMATCH INSUFFICIENT_SCOPE INTERNAL_ERROR INVALID_PARAMS INVALID_REQUEST META_CLIENT_CAPABILITIES),
qw(META_CLIENT_INFO META_LOG_LEVEL META_PROTOCOL_VERSION META_SERVER_INFO META_SUBSCRIPTION_ID),
qw(METHOD_NOT_FOUND MISSING_CLIENT_CAPABILITY PARSE_ERROR PROTOCOL_VERSION SUPPORTED_VERSIONS),
qw(UNSUPPORTED_PROTOCOL_VERSION)
);
1;
=encoding utf8
=head1 NAME
MCP::Constants - Constants for MCP (Model Context Protocol)
=head1 SYNOPSIS
use MCP::Constants qw(PROTOCOL_VERSION);
=head1 DESCRIPTION
L provides constants used in MCP (Model Context Protocol).
=head1 CONSTANTS
L exports the following constants.
=head2 HEADER_MISMATCH
The error code for a request whose routing headers disagree with its JSON-RPC body.
=head2 INSUFFICIENT_SCOPE
The error code for a request whose access token lacks a required OAuth scope. This is a local authorization policy
rather than a spec-defined code, and lives in the C<-32000> to C<-32019> range the specification grandfathers for
existing SDK use; C<-32020> to C<-32099> is reserved for the specification itself.
=head2 INTERNAL_ERROR
The error code for a prompt, resource, or tool that died, or returned a promise that was rejected.
=head2 INVALID_PARAMS
The error code for invalid parameters. Also used for prompts, resources, and tools that were not found.
=head2 INVALID_REQUEST
The error code for an invalid request.
=head2 META_CLIENT_CAPABILITIES
The C<_meta> key carrying the capabilities of the client making the request.
=head2 META_CLIENT_INFO
The C<_meta> key carrying the name and version of the client making the request.
=head2 META_LOG_LEVEL
The C<_meta> key carrying the minimum log level the client wants to receive for a request.
=head2 META_PROTOCOL_VERSION
The C<_meta> key carrying the protocol version a request is made with.
=head2 META_SERVER_INFO
The C<_meta> key carrying the name and version of the server in a result.
=head2 META_SUBSCRIPTION_ID
The C<_meta> key carrying the subscription a notification belongs to.
=head2 METHOD_NOT_FOUND
The error code for a method that was not found.
=head2 MISSING_CLIENT_CAPABILITY
The error code for a request that requires a client capability the client did not declare.
=head2 PARSE_ERROR
The error code for a parse error.
=head2 PROTOCOL_VERSION
The version of the Model Context Protocol being used.
=head2 SUPPORTED_VERSIONS
An array reference with every protocol version the server accepts, newest first.
=head2 UNSUPPORTED_PROTOCOL_VERSION
The error code for a request made with a protocol version the server does not support.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/PaxHeaders/Server 0000644 0000000 0000000 00000000127 15232633632 013523 x ustar 00 29 mtime=1785411482.27766109
29 atime=1785411482.27543612
29 ctime=1785411482.27766109
MCP-0.15/lib/MCP/Server/ 0000755 0001750 0000144 00000000000 15232633632 013272 5 ustar 00sri users MCP-0.15/lib/MCP/Server/PaxHeaders/Legacy.pm 0000644 0000000 0000000 00000000131 15232632765 015343 x ustar 00 30 mtime=1785411061.348647584
30 atime=1785411061.352388426
29 ctime=1785411482.27543612
MCP-0.15/lib/MCP/Server/Legacy.pm 0000644 0001750 0000144 00000006763 15232632765 015056 0 ustar 00sri users package MCP::Server::Legacy;
use Mojo::Base 'Exporter', -signatures;
use MCP::Constants qw(META_PROTOCOL_VERSION);
our @EXPORT_OK = qw(legacy_context legacy_request legacy_result);
my @VERSIONS = ('2024-10-07', '2024-11-05', '2025-03-26', '2025-06-18', '2025-11-25');
sub legacy_context ($params, $context) {
my $meta = $params->{_meta} // {};
$context->client_capabilities({})->client_info({})->protocol_version($context->legacy);
$context->progress_token($meta->{progressToken}) if defined $meta->{progressToken};
return $context;
}
sub legacy_request ($version, $request) {
my $params = $request->{params} // {};
# The handshake exists only in legacy revisions, so answer it with the closest version we can serve
if (($request->{method} // '') eq 'initialize') {
my $requested = $params->{protocolVersion} // '';
return (grep { $_ eq $requested } @VERSIONS) ? $requested : $VERSIONS[-1];
}
return undef if $params->{_meta}{+META_PROTOCOL_VERSION};
return $VERSIONS[-1] unless defined $version;
return (grep { $_ eq $version } @VERSIONS) ? $version : undef;
}
sub legacy_result ($server, $method, $version) {
return {} if $method eq 'ping';
return undef unless $method eq 'initialize';
my $capabilities = {};
$capabilities->{prompts} = {} if @{$server->prompts};
$capabilities->{resources} = {} if @{$server->resources};
$capabilities->{tools} = {} if @{$server->tools};
return {
protocolVersion => $version,
capabilities => $capabilities,
serverInfo => {name => $server->name, version => $server->version}
};
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Legacy - Fallback for clients speaking a previous protocol version
=head1 SYNOPSIS
use MCP::Server::Legacy qw(legacy_request);
my $version = legacy_request('2025-11-25', {jsonrpc => '2.0', id => 1, method => 'tools/call'});
=head1 DESCRIPTION
L answers the C handshake of clients speaking a protocol revision older than
L, so they can still list and call tools, prompts and resources while the
ecosystem catches up. Nothing beyond that is supported, in particular no notifications and no multi round-trip
requests. It is a temporary convenience and will be removed again in a future release.
=head1 FUNCTIONS
L implements the following functions, which can be imported individually.
=head2 legacy_context
my $context = legacy_context($params, $context);
Populate an L with the values a current request would have carried in C<_meta>.
=head2 legacy_request
my $version = legacy_request($version, $request);
The protocol revision a request was made with, or C if it is not legacy, based on the
C header and the JSON-RPC request. A request carrying
C<_meta.io.modelcontextprotocol/protocolVersion> is never legacy, whatever the header says, so a current client with
a misconfigured header still gets a proper error. Revisions before C<2025-06-18> predate the header, so a request
without one is assumed to be legacy.
=head2 legacy_result
my $result = legacy_result($server, $method, $version);
The result for a C or C request, or C for every other method. The handshake echoes the
requested protocol revision and advertises the same primitives as C, but never C,
since list change notifications are not supported.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/Server/PaxHeaders/Transport 0000644 0000000 0000000 00000000132 15232633632 015513 x ustar 00 30 mtime=1785411482.277190161
30 atime=1785411482.275717685
30 ctime=1785411482.277190161
MCP-0.15/lib/MCP/Server/Transport/ 0000755 0001750 0000144 00000000000 15232633632 015266 5 ustar 00sri users MCP-0.15/lib/MCP/Server/Transport/PaxHeaders/HTTP.pm 0000644 0000000 0000000 00000000132 15232632765 016713 x ustar 00 30 mtime=1785411061.348876596
30 atime=1785411061.353696318
30 ctime=1785411482.275717685
MCP-0.15/lib/MCP/Server/Transport/HTTP.pm 0000644 0001750 0000144 00000031643 15232632765 016420 0 ustar 00sri users package MCP::Server::Transport::HTTP;
use Mojo::Base 'MCP::Server::Transport', -signatures;
use Crypt::Misc qw(random_v4uuid);
use List::Util qw(first);
use MCP::Constants qw(HEADER_MISMATCH META_PROTOCOL_VERSION);
use MCP::Server::Context;
use MCP::Server::Legacy qw(legacy_request);
use MCP::Server::Subscription;
use Mojo::IOLoop;
use Mojo::JSON qw(to_json);
use Mojo::Util qw(b64_decode decode dumper);
use Scalar::Util qw(blessed looks_like_number weaken);
use constant DEBUG => $ENV{MCP_DEBUG} || 0;
use constant NAMES => {'prompts/get' => 'name', 'resources/read' => 'uri', 'tools/call' => 'name'};
has 'auth';
has heartbeat => 30;
has 'metadata_url';
has 'origins';
has streaming => 0;
has subscriptions => sub { {} };
sub handle_request ($self, $c) {
my $server = $self->server;
$server->log($c->app->log) unless $server->{log};
return $c->render(json => {error => 'Origin not allowed'}, status => 403) unless $self->_check_origin($c);
if (my $auth = $self->auth) {
return $self->_unauthorized($c) unless my $info = $auth->($c);
$c->stash('mcp.auth' => $info);
}
return $self->_handle_post($c) if $c->req->method eq 'POST';
return $c->render(json => {error => 'Method not allowed'}, status => 405);
}
sub notifications ($self) { $self->streaming ? 1 : 0 }
sub notify_all ($self, $method, $params = {}) {
return undef unless $self->streaming;
for my $subscription (values %{$self->subscriptions}) {
next unless $subscription->wants($method);
_write($subscription->stream, $subscription->notification($method, $params));
}
return 1;
}
sub _arg_value ($args, $path) {
my $value = $args;
for my $key (@$path) {
return undef unless ref $value eq 'HASH';
$value = $value->{$key};
}
return $value;
}
sub _challenge_header ($self, %extra) {
my @parts;
push @parts, qq{resource_metadata="@{[$self->metadata_url]}"} if $self->metadata_url;
push @parts, qq{error="$extra{error}"} if $extra{error};
push @parts, qq{scope="$extra{scope}"} if defined $extra{scope};
return 'Bearer' . (@parts ? ' ' . join(', ', @parts) : '');
}
sub _check_headers ($self, $c, $data) {
my $headers = $c->req->headers;
my $params = $data->{params} // {};
my $version = $headers->header('MCP-Protocol-Version');
return 'Missing MCP-Protocol-Version header' unless defined $version;
my $expected = ($params->{_meta} // {})->{+META_PROTOCOL_VERSION};
return 'MCP-Protocol-Version header does not match the request body' if defined $expected && $expected ne $version;
my $method = $data->{method} // '';
my $sent = $headers->header('Mcp-Method');
return 'Missing Mcp-Method header' unless defined $sent;
return 'Mcp-Method header does not match the request body' unless $sent eq $method;
if (my $key = NAMES->{$method}) {
my $name = $headers->header('Mcp-Name');
return 'Missing Mcp-Name header' unless defined $name;
return 'Invalid Mcp-Name header' unless defined($name = _decode_header($name));
return 'Mcp-Name header does not match the request body' unless $name eq ($params->{$key} // '');
}
return $method eq 'tools/call' ? $self->_check_params($c, $params) : undef;
}
sub _check_origin ($self, $c) {
return 1 unless defined(my $origin = $c->req->headers->origin);
return 1 unless my $origins = $self->origins;
return $origins->($c, $origin) ? 1 : 0 if ref $origins eq 'CODE';
return first { $_ eq $origin } @$origins;
}
sub _check_params ($self, $c, $params) {
return undef unless my $tool = first { $_->name eq ($params->{name} // '') } @{$self->server->tools};
my $args = $params->{arguments} // {};
my $headers = $c->req->headers;
for my $param (@{$tool->header_params}) {
my $name = "Mcp-Param-$param->{name}";
my $value = _arg_value($args, $param->{path});
my $header = $headers->header($name);
if (!defined $value) {
return "Unexpected $name header" if defined $header;
next;
}
return "Missing $name header" unless defined $header;
return "Invalid $name header" unless defined($header = _decode_header($header));
return "$name header does not match the request body" unless _match_value($param->{type}, $header, $value);
}
return undef;
}
sub _decode_header ($value) {
return decode('UTF-8', b64_decode($1)) if $value =~ /^=\?base64\?(.*)\?=$/s;
return $value =~ /^[\t\x20-\x7e]*\z/ ? $value : undef;
}
sub _finish ($c, $context, $response) {
return undef if $context->is_cancelled;
$context->stream(undef);
return _write($c, $response)->finish;
}
sub _handle ($self, $data, $context) {
warn "-- MCP Request\n@{[dumper($data)]}\n" if DEBUG;
my $result = $self->server->handle($data, $context);
warn "-- MCP Response\n@{[dumper($result)]}\n" if DEBUG && $result;
return $result;
}
sub _handle_post ($self, $c) {
my $data = $c->req->json;
return $c->render(json => {error => 'Invalid JSON'}, status => 400) unless ref $data eq 'HASH';
# Legacy
my $legacy = legacy_request($c->req->headers->header('MCP-Protocol-Version'), $data);
if (!$legacy && defined(my $id = $data->{id})) {
if (my $message = $self->_check_headers($c, $data)) {
my $error = {code => HEADER_MISMATCH, message => $message};
return $c->render(json => {jsonrpc => '2.0', id => $id, error => $error}, status => 400);
}
}
return $self->_handle_request($c, $data, $legacy);
}
sub _handle_request ($self, $c, $data, $legacy = undef) {
my $info = $c->stash('mcp.auth') // {};
my $context = MCP::Server::Context->new(
controller => $c,
legacy => $legacy,
principal => $info->{principal},
scopes => $self->_scopes($c),
transport => $self
);
return $c->render(data => '', status => 202) unless defined(my $result = $self->_handle($data, $context));
# Subscription
return $self->_handle_subscription($c, $result) if blessed($result) && $result->isa('MCP::Server::Subscription');
# Async
if (blessed($result) && $result->isa('Mojo::Promise')) {
_stream($c, $context);
return $result->then(sub { _finish($c, $context, $_[0]) });
}
# Insufficient scope
if (my $needed = $context->insufficient_scope) {
$c->res->headers->header(
'WWW-Authenticate' => $self->_challenge_header(error => 'insufficient_scope', scope => join(' ', @$needed)));
}
# Sync
my $status = $context->status // 200;
return $c->render(json => $result, status => $status) if $status != 200 || !@{$context->buffer};
_stream($c, $context);
return _finish($c, $context, $result);
}
sub _handle_subscription ($self, $c, $subscription) {
my $id = random_v4uuid;
$self->subscriptions->{$id} = $subscription->stream($c);
_write(_open_stream($c), $subscription->acknowledgement);
my $heartbeat_id;
if (my $interval = $self->heartbeat) {
$heartbeat_id = Mojo::IOLoop->recurring($interval => sub { $c->write_sse({comment => 'keepalive'}) });
}
weaken(my $self_weak = $self);
return $c->on(
finish => sub {
Mojo::IOLoop->remove($heartbeat_id) if $heartbeat_id;
delete $self_weak->subscriptions->{$id} if $self_weak;
}
);
}
sub _match_value ($type, $header, $value) {
return looks_like_number($header) && looks_like_number($value) && $header == $value if $type eq 'integer';
return $header eq ($value ? 'true' : 'false') if $type eq 'boolean';
return $header eq "$value";
}
sub _open_stream ($c) {
$c->inactivity_timeout(0);
$c->res->headers->header('X-Accel-Buffering' => 'no');
return $c->write_sse;
}
sub _scopes ($self, $c) {
return undef unless $self->auth;
return ($c->stash('mcp.auth') // {})->{scopes} // [];
}
sub _stream ($c, $context) {
_open_stream($c);
$c->on(finish => sub { $context->stream(undef)->cancel if $context->stream });
return $context->stream(sub ($notification) {
_write($c, $notification);
})->flush;
}
sub _unauthorized ($self, $c) {
$c->res->headers->header('WWW-Authenticate' => $self->_challenge_header);
return $c->render(json => {error => 'Unauthorized'}, status => 401);
}
sub _write ($c, $message) { return $c->write_sse({text => to_json($message)}) }
1;
=encoding utf8
=head1 NAME
MCP::Server::Transport::HTTP - HTTP transport for MCP servers
=head1 SYNOPSIS
use MCP::Server::Transport::HTTP;
my $http = MCP::Server::Transport::HTTP->new;
=head1 DESCRIPTION
L is a transport for MCP (Model Context Protocol) server that uses HTTP as the
underlying transport mechanism.
Only C requests are handled; C and C are answered with status C<405>. The protocol is stateless,
so nothing is remembered between requests and the transport can be deployed behind a load balancer and a pre-forking
web server. Notifications that belong to a request, such as progress reports, are delivered on the response stream
of that very request, which is upgraded from C to C whenever there is something
to deliver.
The one exception is L, which opts in to C. Long-lived notification streams
require per-process state and are therefore not compatible with pre-forking web servers.
Routing headers are validated against the JSON-RPC body before a request is dispatched, so a gateway that routes on
C, C, or C alone can never disagree with the server about what was called.
=head1 ATTRIBUTES
L inherits all attributes from L and implements the following
new ones.
=head2 auth
my $cb = $http->auth;
$http = $http->auth(sub ($c) {...});
Optional callback to authenticate each request before it is dispatched. It receives the L
and returns a hash reference of authentication info on success, or a false value to reject the request with a
C<401> C challenge. The C and C keys of the returned hash reference are made
available to handlers as L and L. Token validation
is left to the application, so this is where you verify an OAuth 2.0 access token; when not set, requests are not
authenticated.
=head2 heartbeat
my $seconds = $http->heartbeat;
$http = $http->heartbeat(30);
Interval in seconds at which a keep-alive comment is sent on each open subscription stream. Defaults to C<30>; set
to C<0> to disable. Useful when running behind reverse proxies that close idle connections. Only used when
L is enabled.
=head2 metadata_url
my $url = $http->metadata_url;
$http = $http->metadata_url('https://example.com/.well-known/oauth-protected-resource');
URL of the OAuth 2.0 Protected Resource Metadata document. When set, it is included as the C
parameter of the C challenge sent with C<401> and C<403> responses, so clients can discover the
authorization server. Use an absolute URL so remote clients can fetch it. See L.
=head2 origins
my $origins = $http->origins;
$http = $http->origins(['https://example.com']);
$http = $http->origins(sub ($c, $origin) {...});
Origins allowed to make browser requests, as an array reference of exact matches or a callback returning true for
an acceptable origin. Requests carrying an C header that is not allowed are rejected with status C<403>,
which protects against DNS rebinding attacks on servers bound to localhost. Defaults to C, which accepts
every origin.
=head2 streaming
my $bool = $http->streaming;
$http = $http->streaming(1);
Enable C, so clients can open a long-lived stream for the C notifications they
ask for. Defaults to false. When enabled, the transport tracks every open stream in L and
advertises the C capabilities in C. Progress and log notifications do not depend on
this, since they are delivered on the response stream of the request they belong to.
=head2 subscriptions
my $subscriptions = $http->subscriptions;
$http = $http->subscriptions({});
Per-process registry of active L objects. Only used when L is enabled.
=head1 METHODS
L inherits all methods from L and implements the following new
ones.
=head2 handle_request
$http->handle_request(Mojolicious::Controller->new);
Handles an incoming HTTP request.
=head2 notifications
my $bool = $http->notifications;
True when L is enabled, false otherwise.
=head2 notify_all
my $bool = $http->notify_all($method);
my $bool = $http->notify_all($method, {foo => 'bar'});
Send a JSON-RPC notification to every subscription that asked for it. Returns true on success, or C when
L is disabled.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/Server/Transport/PaxHeaders/Stdio.pm 0000644 0000000 0000000 00000000132 15232632765 017216 x ustar 00 30 mtime=1785411061.348969576
30 atime=1785411061.353696318
30 ctime=1785411482.277239472
MCP-0.15/lib/MCP/Server/Transport/Stdio.pm 0000644 0001750 0000144 00000010300 15232632765 016706 0 ustar 00sri users package MCP::Server::Transport::Stdio;
use Mojo::Base 'MCP::Server::Transport', -signatures;
use MCP::Server::Context;
use MCP::Server::Legacy qw(legacy_request);
use MCP::Server::Subscription;
use Mojo::JSON qw(decode_json encode_json);
use Scalar::Util qw(blessed);
has subscriptions => sub { {} };
sub handle_requests ($self) {
my $server = $self->server;
binmode STDIN, ':raw';
binmode STDOUT, ':raw';
STDOUT->autoflush(1);
my $buffer = '';
my $legacy = undef;
while (defined(my $input = _read_line(\$buffer))) {
next if $input eq '';
my $request = eval { decode_json($input) };
next if $self->_cancel($request);
# Legacy
$legacy ||= legacy_request(undef, ref $request eq 'HASH' ? $request : {});
my $context = MCP::Server::Context->new(legacy => $legacy, stream => \&_print_response, transport => $self);
next unless my $response = $server->handle($request, $context);
if (blessed($response) && $response->isa('MCP::Server::Subscription')) { $self->_subscribe($response) }
elsif (blessed($response) && $response->isa('Mojo::Promise')) {
$response->then(sub { _print_response($_[0]) unless $context->is_cancelled })->wait;
}
else { _print_response($response) }
}
}
sub notify_all ($self, $method, $params = {}) {
for my $subscription (values %{$self->subscriptions}) {
next unless $subscription->wants($method);
_print_response($subscription->notification($method, $params));
}
return 1;
}
sub _cancel ($self, $request) {
return 0 unless ref $request eq 'HASH';
return 0 unless ($request->{method} // '') eq 'notifications/cancelled';
my $id = ($request->{params} // {})->{requestId};
delete $self->subscriptions->{$id} if defined $id;
return 1;
}
sub _print_response ($response) { print encode_json($response) . "\n" }
sub _read_line ($buffer) {
while (index($$buffer, "\n") < 0) {
last unless sysread STDIN, my $chunk, 131072;
$$buffer .= $chunk;
}
return undef if $$buffer eq '';
my $pos = index($$buffer, "\n");
my $line = $pos < 0 ? substr($$buffer, 0, length($$buffer), '') : substr($$buffer, 0, $pos + 1, '');
$line =~ s/\r?\n?$//;
return $line;
}
sub _subscribe ($self, $subscription) {
$self->subscriptions->{$subscription->id} = $subscription;
return _print_response($subscription->acknowledgement);
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Transport::Stdio - Stdio transport for MCP servers
=head1 SYNOPSIS
use MCP::Server::Transport::Stdio;
my $stdio = MCP::Server::Transport::Stdio->new;
=head1 DESCRIPTION
L is a transport for MCP (Model Context Protocol) server that reads requests from
standard input (STDIN) and writes responses to standard output (STDOUT). It is designed for command-line tools and
debugging tasks.
All messages share the one channel, so a C request is answered with an acknowledgement
notification and then left open, with its JSON-RPC response withheld until the client cancels it.
Requests are processed strictly in order, so a C notification cannot be read while the
request it refers to is still in flight; it can only cancel a subscription. Use L for
workloads where cancelling a running tool matters.
=head1 ATTRIBUTES
L inherits all attributes from L and implements the following
new ones.
=head2 subscriptions
my $subscriptions = $stdio->subscriptions;
$stdio = $stdio->subscriptions({});
Registry of active L objects, keyed by the id of the request that opened them.
=head1 METHODS
L inherits all methods from L and implements the following new
ones.
=head2 handle_requests
$stdio->handle_requests;
Reads requests from standard input and prints responses to standard output.
=head2 notify_all
my $bool = $stdio->notify_all($method);
my $bool = $stdio->notify_all($method, {foo => 'bar'});
Send a JSON-RPC notification to standard output, once for every subscription in L that asked for
it.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/Server/PaxHeaders/Transport.pm 0000644 0000000 0000000 00000000074 15176715330 016136 x ustar 00 30 atime=1785410975.150529278
30 ctime=1785411482.276335336
MCP-0.15/lib/MCP/Server/Transport.pm 0000644 0001750 0000144 00000001734 15176715330 015634 0 ustar 00sri users package MCP::Server::Transport;
use Mojo::Base -base, -signatures;
has 'server';
sub notifications ($self) {1}
1;
=encoding utf8
=head1 NAME
MCP:Transport - Transport base class
=head1 SYNOPSIS
package MyMCPTransport;
use Mojo::Base 'MCP::Server::Transport';
1;
=head1 DESCRIPTION
L is a base class for MCP (Model Context Protocol) transport implementations.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 server
my $server = $transport->server;
$transport = $transport->server(MCP::Server->new);
The server instance that this transport is associated with.
=head1 METHODS
L implements the following methods.
=head2 notifications
my $bool = $transport->notifications;
True when the transport can push server-to-client notifications outside an in-flight response.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/Server/PaxHeaders/Subscription.pm 0000644 0000000 0000000 00000000130 15232632765 016622 x ustar 00 28 mtime=1785411061.3487166
30 atime=1785411061.352388426
30 ctime=1785411482.276482142
MCP-0.15/lib/MCP/Server/Subscription.pm 0000644 0001750 0000144 00000006734 15232632765 016334 0 ustar 00sri users package MCP::Server::Subscription;
use Mojo::Base -base, -signatures;
use MCP::Constants qw(META_SUBSCRIPTION_ID);
use Mojo::JSON qw(true);
use constant FILTERS => {
'notifications/prompts/list_changed' => 'promptsListChanged',
'notifications/resources/list_changed' => 'resourcesListChanged',
'notifications/tools/list_changed' => 'toolsListChanged'
};
has 'id';
has notifications => sub { {} };
has 'stream';
sub acknowledgement ($self) {
my $params = {_meta => {META_SUBSCRIPTION_ID() => $self->id}, notifications => $self->honoured};
return {jsonrpc => '2.0', method => 'notifications/subscriptions/acknowledged', params => $params};
}
sub honoured ($self) {
my $requested = $self->notifications;
return {map { $_ => true } grep { $requested->{$_} } sort values %{(FILTERS)}};
}
sub notification ($self, $method, $params = {}) {
my $meta = {%{$params->{_meta} // {}}, META_SUBSCRIPTION_ID() => $self->id};
return {jsonrpc => '2.0', method => $method, params => {%$params, _meta => $meta}};
}
sub wants ($self, $method) {
return undef unless my $key = FILTERS->{$method};
return $self->notifications->{$key} ? 1 : 0;
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Subscription - Subscription container
=head1 SYNOPSIS
use MCP::Server::Subscription;
my $subscription = MCP::Server::Subscription->new(id => 1, notifications => {toolsListChanged => 1});
my $bool = $subscription->wants('notifications/tools/list_changed');
=head1 DESCRIPTION
L is a container for a C notification stream.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 id
my $id = $subscription->id;
$subscription = $subscription->id(1);
The JSON-RPC id of the C request that opened this subscription, sent to the client as
C<_meta.io.modelcontextprotocol/subscriptionId> with every message on the stream.
=head2 notifications
my $filter = $subscription->notifications;
$subscription = $subscription->notifications({toolsListChanged => 1});
The notification filter the client requested, as a hash reference. Notification types that were not requested are
never delivered.
=head2 stream
my $stream = $subscription->stream;
$subscription = $subscription->stream(Mojolicious::Controller->new);
The L serving the SSE stream for this subscription, when the HTTP transport is in use.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 acknowledgement
my $notification = $subscription->acknowledgement;
The C notification a server has to send as the very first message on a
subscription stream, listing the notification types it will actually deliver.
=head2 honoured
my $filter = $subscription->honoured;
The subset of L the server actually supports.
=head2 notification
my $notification = $subscription->notification($method);
my $notification = $subscription->notification($method, {foo => 'bar'});
Build a JSON-RPC notification for this subscription, tagged with L in
C<_meta.io.modelcontextprotocol/subscriptionId>.
=head2 wants
my $bool = $subscription->wants('notifications/tools/list_changed');
Returns true if the given notification method was requested in L.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/Server/PaxHeaders/Context.pm 0000644 0000000 0000000 00000000132 15232632765 015564 x ustar 00 30 mtime=1785411061.348566398
30 atime=1785411061.353696318
30 ctime=1785411482.277712985
MCP-0.15/lib/MCP/Server/Context.pm 0000644 0001750 0000144 00000030414 15232632765 015264 0 ustar 00sri users package MCP::Server::Context;
use Mojo::Base 'Mojo::EventEmitter', -signatures;
use Carp qw(croak);
use Crypt::Mac::HMAC qw(hmac);
use Crypt::Misc qw(slow_eq);
use Mojo::JSON qw(decode_json encode_json);
use Mojo::Util qw(b64_decode b64_encode);
use constant LEVELS =>
{debug => 0, info => 1, notice => 2, warning => 3, error => 4, critical => 5, alert => 6, emergency => 7};
has buffer => sub { [] };
has [qw(client_capabilities client_info controller input_responses insufficient_scope legacy log_level principal)];
has [qw(progress_token protocol_version raw_request_state scopes state_binding state_secret)];
has state_timeout => 300;
has [qw(status stream transport)];
sub cancel ($self) {
return $self if $self->{cancelled}++;
return $self->emit('cancelled');
}
sub flush ($self) {
return 0 unless my $stream = $self->stream;
my @buffered = splice @{$self->buffer};
$stream->($_) for @buffered;
return scalar @buffered;
}
sub has_scope ($self, @needed) {
return 1 unless defined(my $scopes = $self->scopes);
my %granted = map { $_ => 1 } @$scopes;
for my $scope (@needed) { return 0 unless $granted{$scope} }
return 1;
}
sub is_cancelled ($self) { $self->{cancelled} ? 1 : 0 }
sub notify ($self, $method, $params = {}) {
return undef if $self->is_cancelled;
my $notification = {jsonrpc => '2.0', method => $method, params => $params};
if (my $stream = $self->stream) { $stream->($notification) }
else { push @{$self->buffer}, $notification }
return 1;
}
sub notify_log ($self, $level, $data) {
return undef unless defined(my $minimum = $self->log_level);
return undef unless (LEVELS->{$level} // 0) >= (LEVELS->{$minimum} // 0);
return $self->notify('notifications/message', {level => $level, data => $data});
}
sub notify_progress ($self, $progress, $total = undef, $message = undef) {
return undef unless defined(my $token = $self->progress_token);
my $params = {progressToken => $token, progress => $progress};
$params->{total} = $total if defined $total;
$params->{message} = $message if defined $message;
return $self->notify('notifications/progress', $params);
}
sub request_state ($self) { return $self->{request_state} //= $self->_unseal }
sub seal_state ($self, $state) {
croak 'No state secret' unless my $secret = $self->state_secret;
my $data = {
binding => $self->state_binding,
expires => time + $self->state_timeout,
payload => $state,
principal => $self->principal
};
my $payload = b64_encode(encode_json($data), '');
return "$payload." . b64_encode(hmac('SHA256', $secret, $payload), '');
}
sub _unseal ($self) {
return undef unless my $secret = $self->state_secret;
return undef unless ($self->raw_request_state // '') =~ /^([^.]+)\.([^.]+)$/;
my ($payload, $mac) = ($1, $2);
return undef unless slow_eq(b64_decode($mac), hmac('SHA256', $secret, $payload));
return undef unless my $data = eval { decode_json(b64_decode($payload)) };
return undef unless ($data->{expires} // 0) > time;
return undef unless ($data->{binding} // '') eq ($self->state_binding // '');
return undef unless ($data->{principal} // '') eq ($self->principal // '');
return $data->{payload};
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Context - Request context container
=head1 SYNOPSIS
use MCP::Server::Context;
my $context = MCP::Server::Context->new;
$context->notify_progress(1, 2, 'halfway');
=head1 DESCRIPTION
L is a container for per-invocation request context.
=head1 EVENTS
L inherits all events from L and emits the following new ones.
=head2 cancelled
$context->on(cancelled => sub ($context) { ... });
Emitted once when the client abandons the current request, either by closing its response stream or by sending a
C notification. Long running operations should stop as soon as practical.
my $id = Mojo::IOLoop->recurring(1 => sub { ... });
$context->on(cancelled => sub ($context) { Mojo::IOLoop->remove($id) });
=head1 ATTRIBUTES
L implements the following attributes.
=head2 buffer
my $buffer = $context->buffer;
$context = $context->buffer([]);
Notifications that have been queued up because no response L was available yet, to be delivered by
L.
=head2 client_capabilities
my $capabilities = $context->client_capabilities;
$context = $context->client_capabilities({elicitation => {}});
Capabilities declared by the client for the current request, from
C<_meta.io.modelcontextprotocol/clientCapabilities>. Every request has to declare them, so this is only C
outside of request handling.
=head2 client_info
my $info = $context->client_info;
$context = $context->client_info({name => 'MyClient', version => '1.0.0'});
Name and version of the client making the current request, from C<_meta.io.modelcontextprotocol/clientInfo>, or
C if the client did not identify itself.
=head2 controller
my $c = $context->controller;
$context = $context->controller(Mojolicious::Controller->new);
The L serving the current request, when the HTTP transport is in use.
=head2 input_responses
my $responses = $context->input_responses;
$context = $context->input_responses({confirm => {action => 'accept', content => {ok => \1}}});
Responses to the input requests of an earlier C result, keyed by the same names, or C if the
current request is not a retry. See L.
=head2 insufficient_scope
my $needed = $context->insufficient_scope;
$context = $context->insufficient_scope(['mcp:write']);
Array reference of scopes a denied request was missing, set by the server so the HTTP transport can emit an
C challenge. C when no scope check failed.
=head2 legacy
my $version = $context->legacy;
$context = $context->legacy('2025-11-25');
The protocol revision a legacy request was made with, or C for a current request, see
L.
=head2 log_level
my $level = $context->log_level;
$context = $context->log_level('info');
The minimum severity of log messages the client wants for the current request, from
C<_meta.io.modelcontextprotocol/logLevel>, or C if the client asked for none.
=head2 principal
my $principal = $context->principal;
$context = $context->principal('user@example.com');
The authenticated caller the current request belongs to, populated from the C key returned by the C
hook of the HTTP transport. Request state is bound to it, so state minted for one caller is never accepted from
another. C for unauthenticated requests.
=head2 progress_token
my $token = $context->progress_token;
$context = $context->progress_token('tok-1');
The progress token provided by the client in C<_meta.progressToken>, or C if none was sent.
=head2 protocol_version
my $version = $context->protocol_version;
$context = $context->protocol_version('2026-07-28');
The protocol version the current request was made with, from C<_meta.io.modelcontextprotocol/protocolVersion>.
=head2 raw_request_state
my $state = $context->raw_request_state;
$context = $context->raw_request_state('eyJ...');
The C string the client sent back, exactly as received and not verified in any way. Use
L instead, unless you want to protect the state yourself.
=head2 scopes
my $scopes = $context->scopes;
$context = $context->scopes(['mcp:read', 'mcp:write']);
OAuth scopes granted to the current request, as an array reference, populated from the C hook of the HTTP
transport. C (the default) imposes no scope restriction, so scopes are only enforced for authenticated
requests that provide them.
=head2 state_binding
my $binding = $context->state_binding;
$context = $context->state_binding("tools/call\0deploy");
Identifies the request that request state may be used with, set by the server to the method name and the name or
URI of the primitive being called. State sealed for one primitive is never accepted by another.
=head2 state_secret
my $secret = $context->state_secret;
$context = $context->state_secret($bytes);
Key used to authenticate request state, copied from L.
=head2 state_timeout
my $seconds = $context->state_timeout;
$context = $context->state_timeout(300);
How long request state sealed during this request stays valid, in seconds, copied from
L.
=head2 status
my $status = $context->status;
$context = $context->status(404);
HTTP status the current request has to be answered with, set by the server for the protocol errors the specification
maps to a specific status, such as C<404> for an unknown method. C (the default) means C<200>, and transports
other than L ignore it.
=head2 stream
my $cb = $context->stream;
$context = $context->stream(sub ($notification) { ... });
Callback the transport installs once the response stream for the current request is open, to be called with every
notification that belongs to it. Notifications sent before that are queued up in L.
=head2 transport
my $transport = $context->transport;
$context = $context->transport(MCP::Server::Transport::HTTP->new);
The transport handling the current request.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 cancel
$context = $context->cancel;
Mark the current request as cancelled and emit the L event, at most once.
=head2 flush
my $num = $context->flush;
Deliver all notifications queued up in L to L, and return the number of notifications
delivered.
=head2 has_scope
my $bool = $context->has_scope('mcp:write');
my $bool = $context->has_scope('mcp:read', 'mcp:write');
Returns true if every given scope is present in L, or if L is C (no restriction).
=head2 is_cancelled
my $bool = $context->is_cancelled;
Returns true if the current request has been cancelled, for operations that cannot subscribe to the
L event and have to poll instead.
=head2 notify
my $bool = $context->notify($method);
my $bool = $context->notify($method, {foo => 'bar'});
Send a JSON-RPC notification on the response stream of the current request. Returns true on success, or C if
the request has been cancelled.
=head2 notify_log
my $bool = $context->notify_log('info', 'Something happened');
my $bool = $context->notify_log('error', {code => 23});
Send a C JSON-RPC notification with the given severity and payload. Returns C unless
the client requested logging with C<_meta.io.modelcontextprotocol/logLevel> and the given severity is at or above
the level it asked for.
=head2 notify_progress
my $bool = $context->notify_progress($progress);
my $bool = $context->notify_progress($progress, $total);
my $bool = $context->notify_progress($progress, $total, $message);
Send a C JSON-RPC notification for the progress token associated with the current request.
Returns true on success, or C if no progress token was provided by the client.
=head2 request_state
my $state = $context->request_state;
Verify and decode the request state the client sent back, returning the data structure that was passed to
L. Returns C if there was no state, or if it was tampered with, has expired,
was sealed for a different primitive, or belongs to a different L, so a primitive that cannot tell
those cases apart simply asks for input again.
Replay within L is not prevented; servers that need one-shot semantics have to enforce that
themselves, for example by embedding a nonce and remembering it.
=head2 seal_state
my $sealed = $context->seal_state({step => 2});
Serialize a data structure into an opaque string, authenticated with L and bound to
L, L, and L. Usually called through
L rather than directly.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.15/lib/MCP/PaxHeaders/Tool.pm 0000644 0000000 0000000 00000000131 15232632765 013606 x ustar 00 30 mtime=1785411061.349100107
30 atime=1785411061.353696318
29 ctime=1785411482.27658664
MCP-0.15/lib/MCP/Tool.pm 0000644 0001750 0000144 00000022435 15232632765 013313 0 ustar 00sri users package MCP::Tool;
use Mojo::Base 'MCP::Primitive', -signatures;
use Carp qw(croak);
use JSON::Schema::Tiny;
use Mojo::JSON qw(false to_json true);
use Mojo::Util qw(b64_encode);
use Scalar::Util qw(blessed);
use constant DIALECTS => {
'http://json-schema.org/draft-07/schema#' => 'draft7',
'https://json-schema.org/draft/2019-09/schema' => 'draft2019-09',
'https://json-schema.org/draft/2020-12/schema' => 'draft2020-12'
};
has annotations => sub { {} };
has code => sub { die 'Tool code not implemented' };
has description => 'Generic MCP tool';
has input_schema => sub { {type => 'object'} };
has max_schema_depth => 50;
has name => 'tool';
has 'output_schema';
sub audio_result ($self, $audio, $options = {}, $is_error = 0) {
return {
content => [{type => 'audio', data => b64_encode($audio, ''), mimeType => $options->{mime_type} // 'audio/wav'}],
isError => $is_error ? true : false
};
}
sub call ($self, $args, $context) {
local $self->{context} = $context;
my $result = $self->code->($self, $args);
return $result->then(sub { $self->_type_check($_[0]) }) if blessed($result) && $result->isa('Mojo::Promise');
return $self->_type_check($result);
}
sub header_params ($self) { return $self->{header_params} //= _header_params($self->input_schema) }
sub image_result ($self, $image, $options = {}, $is_error = 0) {
return {
content => [{
type => 'image',
data => b64_encode($image, ''),
mimeType => $options->{mime_type} // 'image/png',
annotations => $options->{annotations} // {}
}],
isError => $is_error ? true : false
};
}
sub resource_link_result ($self, $uri, $options = {}, $is_error = 0) {
return {
content => [{
type => 'resource_link',
uri => $uri,
name => $options->{name} // '',
description => $options->{description} // '',
mimeType => $options->{mime_type} // 'text/plain',
annotations => $options->{annotations} // {}
}],
isError => $is_error ? true : false
};
}
sub structured_result ($self, $data, $is_error = 0) {
return $self->text_result('Structured content does not match the output schema', 1) if $self->validate_output($data);
my $result = $self->text_result(to_json($data), $is_error);
$result->{structuredContent} = $data;
return $result;
}
sub text_result ($self, $text, $is_error = 0) {
return {content => [{type => 'text', text => "$text"}], isError => $is_error ? true : false};
}
sub validate_input ($self, $args) {
my $schema = $self->input_schema;
my $validator = $self->{input_validator} //= $self->_validator($schema);
return $validator->evaluate($args, $schema) ? 0 : 1;
}
sub validate_output ($self, $data) {
return 0 unless my $schema = $self->output_schema;
my $validator = $self->{output_validator} //= $self->_validator($schema);
return $validator->evaluate($data, $schema) ? 0 : 1;
}
sub _header_params ($schema, $path = []) {
return [] unless ref $schema eq 'HASH' && ref(my $properties = $schema->{properties}) eq 'HASH';
my @params;
for my $key (sort keys %$properties) {
next unless ref(my $property = $properties->{$key}) eq 'HASH';
my @next = (@$path, $key);
push @params, {name => $property->{'x-mcp-header'}, path => \@next, type => $property->{type} // ''}
if defined $property->{'x-mcp-header'};
push @params, @{_header_params($property, \@next)};
}
return \@params;
}
sub _type_check ($self, $result) {
return $result if ref $result eq 'HASH' && (exists $result->{content} || exists $result->{resultType});
return $self->text_result($result);
}
sub _validator ($self, $schema) {
my %options = (boolean_result => 1, max_depth => $self->max_schema_depth);
if (my $dialect = ref $schema eq 'HASH' ? $schema->{'$schema'} : undef) {
croak qq{Unsupported JSON Schema dialect "$dialect"} unless DIALECTS->{$dialect};
}
else { $options{specification_version} = 'draft2020-12' }
return JSON::Schema::Tiny->new(%options);
}
1;
=encoding utf8
=head1 NAME
MCP::Tool - Tool container
=head1 SYNOPSIS
use MCP::Tool;
my $tool = MCP::Tool->new;
=head1 DESCRIPTION
L is a container for tools to be called. Arguments and structured content are validated with
L, which covers JSON Schema 2020-12, 2019-09, and draft-07, but only partially implements
C<$id>, C<$dynamicRef>, and C<$dynamicAnchor>.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 annotations
my $annotations = $tool->annotations;
$tool = $tool->annotations({title => '...'});
Optional annotations for the tool which provide additional metadata about the tool behavior.
=head2 code
my $code = $tool->code;
$tool = $tool->code(sub { ... });
Tool code.
=head2 description
my $description = $tool->description;
$tool = $tool->description('A brief description of the tool');
Description of the tool.
=head2 input_schema
my $schema = $tool->input_schema;
$tool = $tool->input_schema({type => 'object', properties => {foo => {type => 'string'}}});
JSON schema for validating input arguments. Schemas without a C<$schema> keyword are interpreted as JSON Schema
2020-12, the default dialect of the Model Context Protocol; schemas with one are interpreted as the dialect it
names, which has to be one of 2020-12, 2019-09, or draft-07. Any other dialect is an error.
Properties may carry an C keyword, naming the HTTP header a client has to mirror the argument in, for
the benefit of gateways that route on headers alone. See L.
=head2 max_schema_depth
my $depth = $tool->max_schema_depth;
$tool = $tool->max_schema_depth(10);
How many levels deep validation may descend into a schema before it is aborted, which bounds the work a deeply
nested or recursive schema can cause. Defaults to C<50>.
=head2 name
my $name = $tool->name;
$tool = $tool->name('my_tool');
Name of the tool.
=head2 output_schema
my $schema = $tool->output_schema;
$tool = $tool->output_schema({type => 'object', properties => {foo => {type => 'string'}}});
JSON schema for validating output results, interpreted with the same dialect rules as L.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 audio_result
my $result = $tool->audio_result($bytes, $options, $is_error);
Returns an audio result in the expected format, optionally marking it as an error.
These options are currently available:
=over 2
=item mime_type
mime_type => 'audio/wav'
Specifies the MIME type of the audio, defaults to C