MCP-0.10/ 0000755 0000765 0000024 00000000000 15176725613 010546 5 ustar sri staff MCP-0.10/LICENSE 0000644 0000765 0000024 00000002073 15031727753 011552 0 ustar sri staff The MIT License (MIT)
Copyright (c) 2025 Sebastian Riedel
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
MCP-0.10/Changes 0000644 0000765 0000024 00000003751 15176725323 012045 0 ustar sri staff
0.10 2026-05-06
- Added opt-in server-to-client streaming and session termination to the HTTP transport. Not compatible with
pre-forking web servers.
- Added support for list_changed notifications.
- Added support for progress notifications.
- Added MCP::Primitive class.
- Added MCP::Server::Context class.
- Added MCP::Server::Session class.
- Added heartbeat, session_timeout, sessions, and streaming attributes, and a notify method, to
MCP::Server::Transport::HTTP.
- Added notify method to MCP::Server::Transport::Stdio.
- Added notifications method to MCP::Server::Transport.
- Added notify_all method to MCP::Server::Transport::HTTP and MCP::Server::Transport::Stdio.
- Added notify_list_changed method to MCP::Server.
- Added delete_session method to MCP::Client.
0.08 2026-02-17
- Added support for tool annotations. (d3flex)
0.07 2026-01-16
- Fixed bug in MCP::Prompt where text prompts had the wrong format.
0.06 2025-12-05
- Protocol version is now 2025-11-25.
- Added support for resources.
- Added support for audio and resource results.
- Added support for sessions specific prompt, resource, and tool lists.
- Added MCP::Resource class.
- Added read_resource and list_resources methods to MCP::Client.
- Added resource method to MCP::Server.
- Added audio_result and resource_link_result methods to MCP::Tool.
- Added prompts, resources, and tools events to MCP::Server.
0.05 2025-08-28
- Added support for prompts.
- Added MCP::Prompt class.
- Added get_prompt and list_prompts methods to MCP::Client.
- Added prompt method to MCP::Server.
0.04 2025-08-04
- Added support for structured content.
- Added output_schema attribute to MCP::Tool.
- Added structured_result method to MCP::Tool.
0.03 2025-08-01
- Added image_result method to MCP::Tool.
- Improved streaming HTTP transport to use SSE for async responses.
0.02 2025-08-01
- Fixed support for tool calls without arguments.
0.01 2025-08-01
- First release.
MCP-0.10/MANIFEST 0000644 0000765 0000024 00000001432 15176725613 011677 0 ustar sri staff .perltidyrc
Changes
examples/echo_http.pl
examples/echo_stdio.pl
examples/streaming_http.pl
lib/MCP.pm
lib/MCP/Client.pm
lib/MCP/Constants.pm
lib/MCP/Primitive.pm
lib/MCP/Prompt.pm
lib/MCP/Resource.pm
lib/MCP/Server.pm
lib/MCP/Server/Context.pm
lib/MCP/Server/Session.pm
lib/MCP/Server/Transport.pm
lib/MCP/Server/Transport/HTTP.pm
lib/MCP/Server/Transport/Stdio.pm
lib/MCP/Tool.pm
LICENSE
Makefile.PL
MANIFEST This list of files
README.md
t/apps/empty.wav
t/apps/lite_app.pl
t/apps/mojolicious.png
t/apps/stdio.pl
t/lib/MCPStdioTest.pm
t/lite_app.t
t/pod.t
t/pod_coverage.t
t/session_specific_app.t
t/stdio.t
t/streaming.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
MCP-0.10/t/ 0000755 0000765 0000024 00000000000 15176725613 011011 5 ustar sri staff MCP-0.10/t/pod.t 0000644 0000765 0000024 00000000431 15043143763 011747 0 ustar sri staff 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.10/t/streaming.t 0000644 0000765 0000024 00000030002 15176725323 013160 0 ustar sri staff use Mojo::Base -strict, -signatures;
use Test::More;
use Mojolicious::Lite;
use Test::Mojo;
use Mojo::IOLoop;
use Mojo::JSON qw(from_json true);
use Mojo::Promise;
use MCP::Client;
use MCP::Server;
my $server = MCP::Server->new;
$server->tool(
name => 'push_log',
code => sub ($tool, $args) {
$tool->context->notify('notifications/message', {level => 'info', data => 'hello stream'});
return 'pushed';
}
);
$server->tool(
name => 'notify_status',
code => sub ($tool, $args) {
my $sent = $tool->context->notify('notifications/message', {data => 'x'});
return $sent ? 'sent' : 'no stream';
}
);
$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(1, 2, 'late');
$promise->resolve('done');
}
);
return $promise;
}
);
any '/mcp' => $server->to_action({streaming => 1, heartbeat => 0, session_timeout => 0.5});
my $t = Test::Mojo->new;
subtest 'No session' => sub {
$t->get_ok('/mcp')->status_is(400)->json_is('/error' => 'Missing session ID');
$t->delete_ok('/mcp')->status_is(400)->json_is('/error' => 'Missing session ID');
};
subtest 'Unknown session' => sub {
$t->get_ok('/mcp' => {'Mcp-Session-Id' => 'nope'})->status_is(404);
$t->delete_ok('/mcp' => {'Mcp-Session-Id' => 'nope'})->status_is(404);
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
eval { $client->session_id('nope'); $client->ping };
like $@, qr/404 response/, 'POST with unknown session is rejected';
};
subtest 'List changed' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
my $caps = $client->initialize_session->{capabilities};
is $caps->{tools}{listChanged}, true, 'tools listChanged advertised';
is $caps->{prompts}{listChanged}, true, 'prompts listChanged advertised';
is $caps->{resources}{listChanged}, true, 'resources listChanged advertised';
my $got_notification = Mojo::Promise->new;
my $msg;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $client->session_id});
$tx->res->content->on(
sse => sub ($content, $event = undef) {
return if $msg;
return unless $event && $event->{text} && (my $parsed = eval { from_json($event->{text}) });
$msg = $parsed;
$got_notification->resolve;
}
);
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
ok $server->notify_list_changed('tools'), 'broadcast attempted';
$got_notification->timeout(5)->wait;
is $msg->{jsonrpc}, '2.0', 'JSON-RPC version';
is $msg->{method}, 'notifications/tools/list_changed', 'notification method';
$client->delete_session;
};
subtest 'List changed (no streams)' => sub {
ok $server->notify_list_changed('prompts'), 'broadcast attempted';
};
subtest 'Bidirectional flow' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
ok $client->session_id, 'session id set';
my $got_notification = Mojo::Promise->new;
my $msg;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $client->session_id});
$tx->res->content->on(
sse => sub ($content, $event = undef) {
return if $msg;
return unless $event && $event->{text} && (my $parsed = eval { from_json($event->{text}) });
$msg = $parsed;
$got_notification->resolve;
}
);
$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';
my $result = $client->call_tool('push_log');
is $result->{content}[0]{text}, 'pushed', 'tool call result';
$got_notification->timeout(5)->wait;
is $msg->{jsonrpc}, '2.0', 'JSON-RPC version';
is $msg->{method}, 'notifications/message', 'notification method';
is $msg->{params}{data}, 'hello stream', 'notification payload';
is $msg->{params}{level}, 'info', 'notification level';
$t->get_ok('/mcp' => {'Mcp-Session-Id' => $client->session_id})->status_is(409);
my $session_id = $client->session_id;
ok $client->delete_session, 'session deleted';
is $client->session_id, undef, 'session id cleared';
my $closed = Mojo::Promise->new;
$tx->on(finish => sub { $closed->resolve });
$closed->timeout(5)->wait unless $tx->is_finished;
ok $tx->is_finished, 'stream closed by server';
$t->get_ok('/mcp' => {'Mcp-Session-Id' => $session_id})->status_is(404);
$t->delete_ok('/mcp' => {'Mcp-Session-Id' => $session_id})->status_is(404);
};
subtest 'Notify (no stream)' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $result = $client->call_tool('notify_status');
is $result->{content}[0]{text}, 'no stream', 'notify returns false without an open stream';
$client->delete_session;
};
subtest 'Progress notifications' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $got_notification = Mojo::Promise->new;
my $msg;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $client->session_id});
$tx->res->content->on(
sse => sub ($content, $event = undef) {
return if $msg;
return unless $event && $event->{text} && (my $parsed = eval { from_json($event->{text}) });
$msg = $parsed;
$got_notification->resolve;
}
);
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
my $request
= $client->build_request('tools/call', {name => 'progress', arguments => {}, _meta => {progressToken => 'tok-1'}});
my $response = $client->send_request($request);
is $response->{result}{content}[0]{text}, 'sent', 'tool call result';
$got_notification->timeout(5)->wait;
is $msg->{jsonrpc}, '2.0', 'JSON-RPC version';
is $msg->{method}, 'notifications/progress', 'notification method';
is $msg->{params}{progressToken}, 'tok-1', 'progress token echoed';
is $msg->{params}{progress}, 1, 'progress value';
is $msg->{params}{total}, 2, 'total value';
is $msg->{params}{message}, 'halfway', 'progress message';
$client->delete_session;
};
subtest 'Progress notifications (async)' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $got_notification = Mojo::Promise->new;
my $msg;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $client->session_id});
$tx->res->content->on(
sse => sub ($content, $event = undef) {
return if $msg;
return unless $event && $event->{text} && (my $parsed = eval { from_json($event->{text}) });
$msg = $parsed;
$got_notification->resolve;
}
);
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
my $request = $client->build_request('tools/call',
{name => 'async_progress', arguments => {}, _meta => {progressToken => 'tok-2'}});
my $response = $client->send_request($request);
is $response->{result}{content}[0]{text}, 'done', 'tool call result';
$got_notification->timeout(5)->wait;
is $msg->{jsonrpc}, '2.0', 'JSON-RPC version';
is $msg->{method}, 'notifications/progress', 'notification method';
is $msg->{params}{progressToken}, 'tok-2', 'progress token echoed';
is $msg->{params}{progress}, 1, 'progress value';
is $msg->{params}{total}, 2, 'total value';
is $msg->{params}{message}, 'late', 'progress message';
$client->delete_session;
};
subtest 'Progress (no token)' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $result = $client->call_tool('progress');
is $result->{content}[0]{text}, 'no token', 'notify_progress returns false without a token';
$client->delete_session;
};
subtest 'Delete (no stream)' => sub {
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $session_id = $client->session_id;
ok $client->delete_session, 'session deleted';
$t->get_ok('/mcp' => {'Mcp-Session-Id' => $session_id})->status_is(404);
};
subtest 'Stream cleanup on disconnect' => sub {
my $transport = $server->transport;
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $session_id = $client->session_id;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $session_id});
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
ok $transport->sessions->{$session_id}->stream, 'stream registered';
my $closed = Mojo::Promise->new;
$tx->on(finish => sub { $closed->resolve });
$transport->sessions->{$session_id}->stream->finish;
$closed->timeout(5)->wait;
ok !$transport->sessions->{$session_id}->stream, 'stream cleared on finish';
$client->delete_session;
};
subtest 'Heartbeat' => sub {
my $transport = $server->transport;
$transport->heartbeat(1);
my $client = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$client->initialize_session;
my $session_id = $client->session_id;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $session_id});
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
is $tx->res->code, 200, 'stream open';
# SSE parser strips comments
my $bytes = '';
Mojo::IOLoop->stream($tx->connection)->on(read => sub ($stream, $chunk) { $bytes .= $chunk });
my $deadline = Mojo::Promise->new;
Mojo::IOLoop->timer(1.5 => sub { $deadline->resolve });
$deadline->wait;
like $bytes, qr/: keepalive/, 'heartbeat sent';
$transport->heartbeat(0);
$client->delete_session;
};
subtest 'Session expiration' => sub {
my $sessions = $server->transport->sessions;
my $idle = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$idle->initialize_session;
my $idle_id = $idle->session_id;
my $open = MCP::Client->new(ua => $t->ua, url => $t->ua->server->url->path('/mcp'));
$open->initialize_session;
my $open_id = $open->session_id;
my $url = $t->ua->server->url->path('/mcp');
my $tx = $t->ua->build_tx(GET => $url => {Accept => 'text/event-stream', 'Mcp-Session-Id' => $open_id});
$t->ua->start_p($tx)->catch(sub { });
Mojo::IOLoop->one_tick until $tx->res->code || $tx->error;
ok exists $sessions->{$idle_id}, 'idle session registered';
ok exists $sessions->{$open_id}, 'streaming session registered';
my $tick = Mojo::Promise->new;
Mojo::IOLoop->timer(1.5 => sub { $tick->resolve });
$tick->wait;
ok !exists $sessions->{$idle_id}, 'idle session swept';
ok exists $sessions->{$open_id}, 'streaming session survives sweep';
$open->delete_session;
eval { $idle->ping };
like $@, qr/404 response/, 'POST for swept session is rejected';
};
done_testing;
MCP-0.10/t/session_specific_app.t 0000644 0000765 0000024 00000013163 15132461025 015354 0 ustar sri staff 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'));
$client->initialize_session;
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';
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'));
$client->initialize_session;
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 -32601: 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 -32601: 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 -32002: Resource not found/, 'right error';
};
};
};
done_testing;
MCP-0.10/t/lib/ 0000755 0000765 0000024 00000000000 15176725613 011557 5 ustar sri staff MCP-0.10/t/lib/MCPStdioTest.pm 0000644 0000765 0000024 00000002241 15176716121 014370 0 ustar sri staff 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_request ($self, $method, $params) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($self->client->build_request($method, $params)) . "\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.10/t/stdio.t 0000644 0000765 0000024 00000013065 15176725323 012323 0 ustar sri staff 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(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 'Initialization' => sub {
my $res = $test->request(initialize =>
{capabilities => {}, clientInfo => {name => 'mojo-mcp', version => '1.0.0'}, protocolVersion => '2025-06-18'});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 1, 'request id';
is $res->{result}{protocolVersion}, PROTOCOL_VERSION, 'protocol version';
is $res->{result}{serverInfo}{name}, 'PerlServer', 'server name';
is $res->{result}{serverInfo}{version}, '1.0.0', 'server version';
ok $res->{result}{capabilities}, 'has capabilities';
is $res->{result}{capabilities}{tools}{listChanged}, true, 'tools listChanged';
is $res->{result}{capabilities}{prompts}{listChanged}, true, 'prompts listChanged';
is $res->{result}{capabilities}{resources}{listChanged}, true, 'resources listChanged';
ok $test->notify('notifications/initialized', {}), 'initialized';
};
subtest 'List tools' => sub {
my $res = $test->request('tools/list', {});
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 2, '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';
ok $test->notify('notifications/cancelled', {requestId => 2, 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}, 3, 'request id';
is_deeply $res->{result}, {content => [{text => 'Echo: hello mojo', type => 'text'}], isError => false},
'tool call result';
};
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}, 4, 'request id';
is_deeply $res->{result}, {content => [{text => 'Echo (async): hello mojo', type => 'text'}], isError => false},
'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}, 5, 'request id';
is_deeply $res->{result}, {content => [{text => 'Echo: i ♥ mcp', type => 'text'}], isError => false},
'tool call result';
};
subtest 'Tool call (with notification)' => sub {
$test->send_request('tools/call', {name => 'echo_log', arguments => {msg => 'hi'}});
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}, 6, 'request id';
is_deeply $res->{result}, {content => [{text => 'Echo: hi', type => 'text'}], isError => false}, 'tool call result';
};
subtest 'Tool call (with broadcast)' => sub {
$test->send_request('tools/call', {name => 'reload', arguments => {}});
my $notif = $test->read_line;
is $notif->{jsonrpc}, '2.0', 'JSON-RPC version';
is $notif->{id}, undef, 'no request id';
is $notif->{method}, 'notifications/tools/list_changed', 'notification method';
my $res = $test->read_line;
is $res->{jsonrpc}, '2.0', 'JSON-RPC version';
is $res->{id}, 7, 'request id';
is_deeply $res->{result}, {content => [{text => 'reloaded', type => 'text'}], isError => false}, '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}, 8, 'request id';
is_deeply $res->{result}, {content => [{text => 'Echo: hi', type => 'text'}], isError => false}, 'tool call result';
};
ok $test->stop, 'process stopped';
done_testing;
MCP-0.10/t/pod_coverage.t 0000644 0000765 0000024 00000000446 15043143757 013633 0 ustar sri staff 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.10/t/apps/ 0000755 0000765 0000024 00000000000 15176725613 011754 5 ustar sri staff MCP-0.10/t/apps/mojolicious.png 0000644 0000765 0000024 00000007772 15043171466 015025 0 ustar sri staff 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.10/t/apps/empty.wav 0000644 0000765 0000024 00000000116 15114316467 013622 0 ustar sri staff RIFFF WAVEfmt D LIST INFOISFT
Lavf62.3.100 data MCP-0.10/t/apps/stdio.pl 0000644 0000765 0000024 00000003330 15176725323 013430 0 ustar sri staff 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('notifications/message', {level => 'info', data => $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->to_stdio;
MCP-0.10/t/apps/lite_app.pl 0000644 0000765 0000024 00000013372 15145055531 014103 0 ustar sri staff 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.10/t/lite_app.t 0000644 0000765 0000024 00000037771 15176716121 013004 0 ustar sri staff 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(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 'Initialize session' => sub {
is $client->session_id, undef, 'no session id';
my $result = $client->initialize_session;
is $result->{protocolVersion}, PROTOCOL_VERSION, 'protocol version';
is $result->{serverInfo}{name}, 'PerlServer', 'server name';
is $result->{serverInfo}{version}, '1.0.0', 'server version';
ok $result->{capabilities}, 'has capabilities';
ok $result->{capabilities}{prompts}, 'has prompts capability';
ok $result->{capabilities}{resources}, 'has resources capability';
ok $result->{capabilities}{tools}, 'has tools capability';
ok !exists $result->{capabilities}{tools}{listChanged}, 'no listChanged for tools';
ok !exists $result->{capabilities}{prompts}{listChanged}, 'no listChanged for prompts';
ok !exists $result->{capabilities}{resources}{listChanged}, 'no listChanged for resources';
ok $client->session_id, 'session id set';
};
subtest 'Ping' => sub {
my $result = $client->ping;
is_deeply $result, {}, 'ping response';
};
subtest 'List tools' => sub {
my $result = $client->list_tools;
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';
};
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 -32601: 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->{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 -32601: 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->{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->{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 -32002: Resource not found/, 'right error';
};
};
done_testing;
MCP-0.10/README.md 0000644 0000765 0000024 00000006522 15176725323 012030 0 ustar sri staff
# MCP Perl SDK
[](https://github.com/mojolicious/mojo-mcp/actions) [](https://github.com/mojolicious/mojo-mcp/actions)
[Model Context Protocol](https://modelcontextprotocol.io/) support for [Perl](https://perl.org) and the
[Mojolicious](https://mojolicious.org) real-time web framework.
### Features
Please be aware that this module is still in development and will be changing rapidly. Additionally the MCP
specification is getting regular updates which we will implement. Breaking changes are very likely.
* Tool calling, prompts and resources
* Streamable HTTP and Stdio transports
* Notifications for list changes (tools, prompts, resources)
* Progress tracking for long-running operations
* Scalable with pre-forking web server and async tools using promises
* HTTP client for testing
* Can be embedded in Mojolicious web apps
## Installation
All you need is Perl 5.20 or newer. Just install from [CPAN](https://metacpan.org/pod/MCP).
$ cpanm -n MCP
We recommend the use of a [Perlbrew](http://perlbrew.pl) environment.
## Streamable HTTP Transport
Use the `to_action` method to add an MCP endpoint to any Mojolicious application.
```perl
use Mojolicious::Lite -signatures;
use MCP::Server;
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}";
}
);
any '/mcp' => $server->to_action;
app->start;
```
Authentication can be added by the web application, just like for any other route.
## Server-to-Client Streaming
The HTTP transport can optionally accept `GET` requests to open a long-lived SSE stream the server can push
notifications to, and `DELETE` requests to terminate a session. This requires per-process state and is not
compatible with pre-forking web servers, so it is opt-in.
```perl
use Mojolicious::Lite -signatures;
use MCP::Server;
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) {
$tool->context->notify('notifications/message', {level => 'info', data => "Echoing: $args->{msg}"});
return "Echo: $args->{msg}";
}
);
any '/mcp' => $server->to_action({streaming => 1});
app->start;
```
## Stdio Transport
Build local command line applications and use the stdio transport for testing with the `to_stdio` method.
```perl
use Mojo::Base -strict, -signatures;
use MCP::Server;
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->to_stdio;
```
Just run the script and type requests on the command line.
```
$ perl examples/echo_stdio.pl
{"jsonrpc":"2.0","id":"1","method":"tools/list"}
{"jsonrpc":"2.0","id":"2","method":"tools/call","params":{"name":"echo","arguments":{"msg":"hello perl"}}}
```
MCP-0.10/examples/ 0000755 0000765 0000024 00000000000 15176725613 012364 5 ustar sri staff MCP-0.10/examples/echo_stdio.pl 0000644 0000765 0000024 00000001417 15054060316 015027 0 ustar sri staff #
# This example demonstrates a simple MCP server using stdio
#
# mcp.json:
# {
# "mcpServers": {
# "mojo": {
# "command": "/home/kraih/mojo-mcp/examples/echo_stdio.pl"
# }
# }
# }
#
use Mojo::Base -strict, -signatures;
use MCP::Server;
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->prompt(
name => 'echo',
description => 'A prompt to demonstrate the echo tool',
code => sub ($prompt, $args) {
return 'Use the echo tool with the message "Hello, World!"';
}
);
$server->to_stdio;
MCP-0.10/examples/echo_http.pl 0000644 0000765 0000024 00000001553 15114316140 014661 0 ustar sri staff #
# This example demonstrates a simple MCP server using Mojolicious
#
# mcp.json:
# {
# "mcpServers": {
# "mojo": {
# "url": "http://127.0.0.1:3000/mcp",
# "headers": {
# "Authorization": "Bearer mojo:test:123"
# }
# }
# }
# }
#
use Mojolicious::Lite -signatures;
use MCP::Server;
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->prompt(
name => 'echo',
description => 'A prompt to demonstrate the echo tool',
code => sub ($prompt, $args) {
return 'Use the echo tool with the message "Hello, World!"';
}
);
any '/mcp' => $server->to_action;
app->start;
MCP-0.10/examples/streaming_http.pl 0000644 0000765 0000024 00000002120 15176725323 015742 0 ustar sri staff #
# This example demonstrates progress notifications for a long-running MCP tool
#
# mcp.json:
# {
# "mcpServers": {
# "mojo": {
# "url": "http://127.0.0.1:3000/mcp"
# }
# }
# }
#
use Mojolicious::Lite -signatures;
use MCP::Server;
use Mojo::IOLoop;
use Mojo::Promise;
my $server = MCP::Server->new;
$server->tool(
name => 'process_items',
description => 'Process a number of items and report progress along the way',
input_schema => {type => 'object', properties => {items => {type => 'integer'}}},
code => sub ($tool, $args) {
my $context = $tool->context;
my $total = $args->{items} || 5;
my $promise = Mojo::Promise->new;
my $done = 0;
my $id;
$id = Mojo::IOLoop->recurring(
0.5 => sub {
$done++;
$context->notify_progress($done, $total, "Processed item $done of $total");
return if $done < $total;
Mojo::IOLoop->remove($id);
$promise->resolve("Processed $total items");
}
);
return $promise;
}
);
any '/mcp' => $server->to_action({streaming => 1});
app->start;
MCP-0.10/META.yml 0000644 0000765 0000024 00000001727 15176725613 012026 0 ustar sri staff ---
abstract: 'Connect Perl with AI using MCP (Model Context Protocol)'
author:
- 'Sebastian Riedel '
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 0
generated_by: 'ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010'
license: mit
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: MCP
no_index:
directory:
- t
- inc
- examples
- t
requires:
CryptX: '0.087'
IPC::Run: '20231003.0'
JSON::Validator: '5.15'
Mojolicious: '9.41'
perl: '5.020'
resources:
IRC:
url: irc://irc.libera.chat/#mojo
web: https://web.libera.chat/#mojo
bugtracker: https://github.com/mojolicious/mojo-mcp/issues
homepage: https://mojolicious.org
license: http://www.opensource.org/licenses/mit
repository: https://github.com/mojolicious/mojo-mcp.git
version: '0.10'
x_serialization_backend: 'CPAN::Meta::YAML version 0.020'
MCP-0.10/lib/ 0000755 0000765 0000024 00000000000 15176725613 011314 5 ustar sri staff MCP-0.10/lib/MCP/ 0000755 0000765 0000024 00000000000 15176725613 011733 5 ustar sri staff MCP-0.10/lib/MCP/Server.pm 0000644 0000765 0000024 00000026250 15176725323 013542 0 ustar sri staff package MCP::Server;
use Mojo::Base 'Mojo::EventEmitter', -signatures;
use List::Util qw(first);
use Mojo::JSON qw(false true);
use MCP::Constants qw(INVALID_PARAMS INVALID_REQUEST METHOD_NOT_FOUND PARSE_ERROR PROTOCOL_VERSION RESOURCE_NOT_FOUND);
use MCP::Prompt;
use MCP::Resource;
use MCP::Server::Transport::HTTP;
use MCP::Server::Transport::Stdio;
use MCP::Tool;
use Scalar::Util qw(blessed);
has name => 'PerlServer';
has prompts => sub { [] };
has resources => sub { [] };
has tools => sub { [] };
has 'transport';
has version => '1.0.0';
sub handle ($self, $request, $context) {
return _jsonrpc_error(PARSE_ERROR, 'Invalid JSON-RPC request') unless ref $request eq 'HASH';
return _jsonrpc_error(INVALID_REQUEST, 'Missing JSON-RPC method') unless my $method = $request->{method};
# Requests
if (defined(my $id = $request->{id})) {
my $token = ($request->{params} // {})->{_meta}{progressToken};
$context->progress_token($token) if defined $token;
if ($method eq 'initialize') {
my $result = $self->_handle_initialize($request->{params} // {});
return _jsonrpc_response($result, $id);
}
elsif ($method eq 'tools/list') {
my $result = $self->_handle_tools_list($context);
return _jsonrpc_response($result, $id);
}
elsif ($method eq 'tools/call') {
return $self->_handle_tools_call($request->{params} // {}, $id, $context);
}
elsif ($method eq 'ping') {
return _jsonrpc_response({}, $id);
}
elsif ($method eq 'prompts/list') {
my $result = $self->_handle_prompts_list($context);
return _jsonrpc_response($result, $id);
}
elsif ($method eq 'prompts/get') {
return $self->_handle_prompts_get($request->{params} // {}, $id, $context);
}
elsif ($method eq 'resources/list') {
my $result = $self->_handle_resources_list($context);
return _jsonrpc_response($result, $id);
}
elsif ($method eq 'resources/read') {
return $self->_handle_resources_read($request->{params} // {}, $id, $context);
}
# Method not found
return _jsonrpc_error(METHOD_NOT_FOUND, "Method '$method' not found", $id);
}
# Notifications (ignored for now)
return undef;
}
sub notify_list_changed ($self, $kind) {
return undef unless my $transport = $self->transport;
return $transport->notify_all("notifications/$kind/list_changed");
}
sub prompt ($self, %args) {
my $prompt = MCP::Prompt->new(%args);
push @{$self->prompts}, $prompt;
return $prompt;
}
sub resource ($self, %args) {
my $resource = MCP::Resource->new(%args);
push @{$self->resources}, $resource;
return $resource;
}
sub to_action ($self, $options = {}) {
$self->transport(my $http = MCP::Server::Transport::HTTP->new(server => $self, %$options));
return sub ($c) { $http->handle_request($c) };
}
sub to_stdio ($self) {
$self->transport(my $stdio = MCP::Server::Transport::Stdio->new(server => $self));
$self->transport->handle_requests;
}
sub tool ($self, %args) {
my $tool = MCP::Tool->new(%args);
push @{$self->tools}, $tool;
return $tool;
}
sub _handle_initialize ($self, $params) {
my $transport = $self->transport;
my $caps = $transport && $transport->notifications ? {listChanged => true} : {};
return {
protocolVersion => PROTOCOL_VERSION,
capabilities => {prompts => $caps, resources => $caps, tools => $caps},
serverInfo => {name => $self->name, version => $self->version}
};
}
sub _handle_prompts_list ($self, $context) {
my @prompts;
for my $prompt (@{$self->_prompts($context)}) {
my $info = {name => $prompt->name, description => $prompt->description, arguments => $prompt->arguments};
push @prompts, $info;
}
return {prompts => \@prompts};
}
sub _handle_prompts_get ($self, $params, $id, $context) {
my $name = $params->{name} // '';
my $args = $params->{arguments} // {};
return _jsonrpc_error(METHOD_NOT_FOUND, "Prompt '$name' not found")
unless my $prompt = first { $_->name eq $name } @{$self->_prompts($context)};
return _jsonrpc_error(INVALID_PARAMS, 'Invalid arguments') if $prompt->validate_input($args);
my $result = $prompt->call($args, $context);
return $result->then(sub { _jsonrpc_response($_[0], $id) }) if blessed($result) && $result->isa('Mojo::Promise');
return _jsonrpc_response($result, $id);
}
sub _handle_resources_list ($self, $context) {
my @resources;
for my $resource (@{$self->_resources($context)}) {
my $info = {
uri => $resource->uri,
name => $resource->name,
description => $resource->description,
mimeType => $resource->mime_type
};
push @resources, $info;
}
return {resources => \@resources};
}
sub _handle_resources_read ($self, $params, $id, $context) {
my $uri = $params->{uri} // '';
return _jsonrpc_error(RESOURCE_NOT_FOUND, 'Resource not found')
unless my $resource = first { $_->uri eq $uri } @{$self->_resources($context)};
my $result = $resource->call($context);
return $result->then(sub { _jsonrpc_response($_[0], $id) }) if blessed($result) && $result->isa('Mojo::Promise');
return _jsonrpc_response($result, $id);
}
sub _handle_tools_call ($self, $params, $id, $context) {
my $name = $params->{name} // '';
my $args = $params->{arguments} // {};
return _jsonrpc_error(METHOD_NOT_FOUND, "Tool '$name' not found")
unless my $tool = first { $_->name eq $name } @{$self->_tools($context)};
return _jsonrpc_error(INVALID_PARAMS, 'Invalid arguments') if $tool->validate_input($args);
my $result = $tool->call($args, $context);
return $result->then(sub { _jsonrpc_response($_[0], $id) }) if blessed($result) && $result->isa('Mojo::Promise');
return _jsonrpc_response($result, $id);
}
sub _handle_tools_list ($self, $context) {
my @tools;
for my $tool (@{$self->_tools($context)}) {
my $info = {name => $tool->name, description => $tool->description, inputSchema => $tool->input_schema};
if (my $output_schema = $tool->output_schema) { $info->{outputSchema} = $output_schema }
my $annotations = $tool->annotations;
$info->{annotations} = $annotations if keys %$annotations;
push @tools, $info;
}
return {tools => \@tools};
}
sub _jsonrpc_error ($code, $message, $id = undef) {
return {jsonrpc => '2.0', id => $id, error => {code => $code, message => $message}};
}
sub _jsonrpc_response ($result, $id = undef) {
return {jsonrpc => '2.0', id => $id, result => $result};
}
sub _prompts ($self, $context) {
my $prompts = [@{$self->prompts}];
$self->emit('prompts', $prompts, $context);
return $prompts;
}
sub _resources ($self, $context) {
my $resources = [@{$self->resources}];
$self->emit('resources', $resources, $context);
return $resources;
}
sub _tools ($self, $context) {
my $tools = [@{$self->tools}];
$self->emit('tools', $tools, $context);
return $tools;
}
1;
=encoding utf8
=head1 NAME
MCP::Server - MCP server implementation
=head1 SYNOPSIS
use MCP::Server;
my $server = MCP::Server->new(name => 'MyServer');
$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->prompt(
name => 'echo',
description => 'A prompt to demonstrate the echo tool',
code => sub ($prompt, $args) {
return 'Use the echo tool with the message "Hello, World!"';
}
);
$server->resource(
uri => 'file:///example.txt',
name => 'example',
description => 'A simple text resource',
mime_type => 'text/plain',
code => sub ($resource) {
return 'This is an example resource content.';
}
);
$server->to_stdio;
=head1 DESCRIPTION
L is an MCP (Model Context Protocol) server.
=head1 EVENTS
L inherits all events from L and emits the following new ones.
=head2 prompts
$server->on(prompts => sub ($server, $prompts, $context) { ... });
Emitted whenever the list of prompts is accessed.
=head2 resources
$server->on(resources => sub ($server, $resources, $context) { ... });
Emitted whenever the list of resources is accessed.
=head2 tools
$server->on(tools => sub ($server, $tools, $context) { ... });
Emitted whenever the list of tools is accessed.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 name
my $name = $server->name;
$server = $server->name('MyServer');
The name of the server, used for identification.
=head2 prompts
my $prompts = $server->prompts;
$server = $server->prompts([MCP::Prompt->new]);
An array reference containing registered prompts.
=head2 resources
my $resources = $server->resources;
$server = $server->resources([MCP::Resource->new]);
An array reference containing registered resources.
=head2 tools
my $tools = $server->tools;
$server = $server->tools([MCP::Tool->new]);
An array reference containing registered tools.
=head2 transport
my $transport = $server->transport;
$server = $server->transport(MCP::Server::Transport::HTTP->new);
The transport layer used by the server, such as L or L.
=head2 version
my $version = $server->version;
$server = $server->version('1.0.0');
The version of the server.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 handle
my $response = $server->handle($request, $context);
Handle a JSON-RPC request and return a response.
=head2 notify_list_changed
my $bool = $server->notify_list_changed('tools');
Broadcast a C JSON-RPC notification to all connected clients. Returns true on
success, or C if no notification could be delivered.
=head2 prompt
my $prompt = $server->prompt(
name => 'my_prompt',
description => 'A sample prompt',
arguments => [{name => 'foo', description => 'Whatever', required => 1}],
code => sub ($prompt, $args) { ... }
);
Register a new prompt with the server.
=head2 resource
my $resource = $server->resource(
uri => 'file://my_resource',
name => 'sample_resource',
description => 'A sample resource',
mime_type => 'text/plain',
code => sub ($resource) { ... }
);
Register a new resource with the server.
=head2 to_action
my $action = $server->to_action;
my $action = $server->to_action({streaming => 1});
Convert the server to a L action. Any options are passed through to the constructor of
L; in particular, C<< streaming => 1 >> opts in to the server-to-client SSE stream
and explicit session termination.
=head2 to_stdio
$server->to_stdio;
Handles JSON-RPC requests over standard input/output.
=head2 tool
my $tool = $server->tool(
name => 'my_tool',
description => 'A sample tool',
input_schema => {type => 'object', properties => {foo => {type => 'string'}}},
code => sub ($tool, $args) { ... }
);
Register a new tool with the server.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Constants.pm 0000644 0000765 0000024 00000002333 15114322113 014222 0 ustar sri staff package MCP::Constants;
use Mojo::Base 'Exporter';
use constant {
INVALID_PARAMS => -32602,
INVALID_REQUEST => -32600,
METHOD_NOT_FOUND => -32601,
PARSE_ERROR => -32700,
PROTOCOL_VERSION => $ENV{MOJO_MCP_VERSION} || '2025-11-25',
RESOURCE_NOT_FOUND => -32002
};
our @EXPORT_OK = qw(INVALID_PARAMS INVALID_REQUEST METHOD_NOT_FOUND PARSE_ERROR PROTOCOL_VERSION RESOURCE_NOT_FOUND);
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 INVALID_PARAMS
The error code for invalid parameters.
=head2 INVALID_REQUEST
The error code for an invalid request.
=head2 METHOD_NOT_FOUND
The error code for a method that was not found.
=head2 PARSE_ERROR
The error code for a parse error.
=head2 PROTOCOL_VERSION
The version of the Model Context Protocol being used.
=head2 RESOURCE_NOT_FOUND
The error code for a resource that was not found.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Client.pm 0000644 0000765 0000024 00000016346 15176716121 013513 0 ustar sri staff package MCP::Client;
use Mojo::Base -base, -signatures;
use Carp qw(croak);
use MCP::Constants qw(PROTOCOL_VERSION);
use Mojo::JSON qw(from_json);
use Mojo::UserAgent;
use Scalar::Util qw(weaken);
has name => 'PerlClient';
has 'session_id';
has ua => sub { Mojo::UserAgent->new };
has url => sub {'http://localhost:3000/mcp'};
has version => '1.0.0';
sub build_request ($self, $method, $params = {}) {
my $request = $self->build_notification($method, $params);
$request->{id} = $self->{id} = $self->{id} ? $self->{id} + 1 : 1;
return $request;
}
sub build_notification ($self, $method, $params = {}) {
return {jsonrpc => '2.0', method => $method, params => $params};
}
sub call_tool ($self, $name, $args = {}) {
my $request = $self->build_request('tools/call', {name => $name, arguments => $args});
return _result($self->send_request($request));
}
sub delete_session ($self) {
return undef unless my $session_id = $self->session_id;
my $tx = $self->ua->build_tx(DELETE => $self->url => {'Mcp-Session-Id' => $session_id});
$tx = $self->ua->start($tx);
if (my $err = $tx->error) {
croak "$err->{code} response: $err->{message}" if $err->{code};
croak "Connection error: $err->{message}";
}
$self->session_id(undef);
return 1;
}
sub get_prompt ($self, $name, $args = {}) {
my $request = $self->build_request('prompts/get', {name => $name, arguments => $args});
return _result($self->send_request($request));
}
sub initialize_session ($self) {
my $request = $self->build_request(
initialize => {
protocolVersion => PROTOCOL_VERSION,
capabilities => {},
clientInfo => {name => $self->name, version => $self->version,},
}
);
my $result = _result($self->send_request($request));
$self->send_request($self->build_notification('notifications/initialized'));
return $result;
}
sub list_prompts ($self) { _result($self->send_request($self->build_request('prompts/list'))) }
sub list_resources ($self) { _result($self->send_request($self->build_request('resources/list'))) }
sub list_tools ($self) { _result($self->send_request($self->build_request('tools/list'))) }
sub ping ($self) { _result($self->send_request($self->build_request('ping'))) }
sub read_resource ($self, $uri) {
my $request = $self->build_request('resources/read', {uri => $uri});
return _result($self->send_request($request));
}
sub send_request ($self, $request) {
my $headers = {Accept => 'application/json, text/event-stream', 'Content-Type' => 'application/json'};
if (my $session_id = $self->session_id) { $headers->{'Mcp-Session-Id'} = $session_id }
my $ua = $self->ua;
my $tx = $ua->build_tx(POST => $self->url => $headers => json => $request);
# SSE handling
my $id = $request->{id};
my $response;
$tx->res->content->on(
sse => sub {
my ($content, $event) = @_;
return unless $event->{text} && (my $res = eval { from_json($event->{text}) });
return unless defined($res->{id}) && defined($id) && $res->{id} eq $id;
$response = $res;
$tx->res->error({message => 'Interrupted'});
}
);
$tx = $ua->start($tx);
if (my $session_id = $tx->res->headers->header('Mcp-Session-Id')) { $self->session_id($session_id) }
# Request or notification accepted without a response
return undef if $tx->res->code eq '202';
if (my $err = $tx->error) {
return $response if $err->{message} eq 'Interrupted';
croak "$err->{code} response: $err->{message}" if $err->{code};
croak "Connection error: $err->{message}";
}
return $tx->res->json;
}
sub _result ($res) {
croak 'No response' unless $res;
if (my $err = $res->{error}) { croak "Error $err->{code}: $err->{message}" }
return $res->{result};
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Transport::HTTP - HTTP transport for MCP servers
=head1 SYNOPSIS
use MCP::Client;
my $client = MCP::Client->new(url => 'http://localhost:3000/mcp');
$client->initialize_session;
my $tools = $client->list_tools;
=head1 DESCRIPTION
L is a client for MCP (Model Context Protocol) that communicates with MCP servers over HTTP.
=head1 ATTRIBUTES
L inherits all attributes from L and implements the following new ones.
=head2 name
my $name = $client->name;
$client = $client->name('PerlClient');
The name of the client, defaults to C.
=head2 session_id
my $session_id = $client->session_id;
$client = $client->session_id('12345');
The session ID for the client, used to maintain state across requests.
=head2 ua
my $ua = $client->ua;
$client = $client->ua(Mojo::UserAgent->new);
The user agent used for making HTTP requests, defaults to a new instance of L.
=head2 url
my $url = $client->url;
$client = $client->url('http://localhost:3000/mcp');
The URL of the MCP server, defaults to C.
=head2 version
my $version = $client->version;
$client = $client->version('1.0.0');
The version of the client, defaults to C<1.0.0>.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 build_request
my $request = $client->build_request('method_name', {param1 => 'value1'});
Builds a JSON-RPC request with the given method name and parameters.
=head2 build_notification
my $notification = $client->build_notification('method_name', {param1 => 'value1'});
Builds a JSON-RPC notification with the given method name and parameters.
=head2 call_tool
my $result = $client->call_tool('tool_name');
my $result = $client->call_tool('tool_name', {arg1 => 'value1'});
Calls a tool on the MCP server with the specified name and arguments, returning the result.
=head2 delete_session
my $bool = $client->delete_session;
Send a C request to terminate the current session on the MCP server, and clear the local
L. Returns true on success, or C if no session is active. The server only honors this when it
was configured with C<< streaming => 1 >>.
=head2 get_prompt
my $result = $client->get_prompt('prompt_name');
my $result = $client->get_prompt('prompt_name', {arg1 => 'value1'});
Get a prompt from the MCP server with the specified name and arguments, returning the result.
=head2 initialize_session
my $result = $client->initialize_session;
Initializes a session with the MCP server, setting up the protocol version and client information.
=head2 list_prompts
my $prompts = $client->list_prompts;
Lists all available prompts on the MCP server.
=head2 list_resources
my $resources = $client->list_resources;
Lists all available resources on the MCP server.
=head2 list_tools
my $tools = $client->list_tools;
Lists all available tools on the MCP server.
=head2 ping
my $result = $client->ping;
Sends a ping request to the MCP server to check connectivity.
=head2 read_resource
my $result = $client->read_resource('file:///path/to/resource.txt');
Reads a resource from the MCP server with the specified URI, returning the result.
=head2 send_request
my $response = $client->send_request($request);
Sends a JSON-RPC request to the MCP server and returns the response.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Server/ 0000755 0000765 0000024 00000000000 15176725613 013201 5 ustar sri staff MCP-0.10/lib/MCP/Server/Transport.pm 0000644 0000765 0000024 00000001734 15176716121 015532 0 ustar sri staff 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.10/lib/MCP/Server/Transport/ 0000755 0000765 0000024 00000000000 15176725613 015175 5 ustar sri staff MCP-0.10/lib/MCP/Server/Transport/HTTP.pm 0000644 0000765 0000024 00000021447 15176725323 016320 0 ustar sri staff package MCP::Server::Transport::HTTP;
use Mojo::Base 'MCP::Server::Transport', -signatures;
use Crypt::Misc qw(random_v4uuid);
use MCP::Server::Context;
use MCP::Server::Session;
use Mojo::IOLoop;
use Mojo::JSON qw(to_json true);
use Mojo::Util qw(dumper);
use Scalar::Util qw(blessed weaken);
use constant DEBUG => $ENV{MCP_DEBUG} || 0;
has heartbeat => 30;
has session_timeout => 3600;
has sessions => sub { {} };
has streaming => 0;
sub notifications ($self) { $self->streaming ? 1 : 0 }
sub handle_request ($self, $c) {
my $method = $c->req->method;
return $self->_handle_post($c) if $method eq 'POST';
return $self->_handle_get($c) if $method eq 'GET' && $self->streaming;
return $self->_handle_delete($c) if $method eq 'DELETE' && $self->streaming;
return $c->render(json => {error => 'Method not allowed'}, status => 405);
}
sub notify ($self, $session_id, $method, $params = {}) {
return undef unless my $session = $self->sessions->{$session_id};
return undef unless my $stream = $session->stream;
$stream->write_sse({text => to_json({jsonrpc => '2.0', method => $method, params => $params})});
return 1;
}
sub notify_all ($self, $method, $params = {}) {
return undef unless $self->streaming;
my $payload = {text => to_json({jsonrpc => '2.0', method => $method, params => $params})};
for my $session (values %{$self->sessions}) {
next unless my $stream = $session->stream;
$stream->write_sse($payload);
}
return 1;
}
sub _extract_session_id ($self, $c) { return $c->req->headers->header('Mcp-Session-Id') }
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_delete ($self, $c) {
return $c->render(json => {error => 'Missing session ID'}, status => 400)
unless my $session_id = $self->_extract_session_id($c);
return $c->render(json => {error => 'Session not found'}, status => 404)
unless my $session = delete $self->sessions->{$session_id};
if (my $stream = $session->stream) { $stream->finish }
$c->render(data => '', status => 204);
}
sub _handle_get ($self, $c) {
return $c->render(json => {error => 'Missing session ID'}, status => 400)
unless my $session_id = $self->_extract_session_id($c);
return $c->render(json => {error => 'Session not found'}, status => 404)
unless my $session = $self->sessions->{$session_id};
return $c->render(json => {error => 'Stream already open'}, status => 409) if $session->stream;
$c->inactivity_timeout(0);
$c->res->headers->header('Mcp-Session-Id' => $session_id);
$session->stream($c)->touch;
$c->write_sse;
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);
$c->on(
finish => sub {
Mojo::IOLoop->remove($heartbeat_id) if $heartbeat_id;
return unless $self_weak;
return unless my $session = $self_weak->sessions->{$session_id};
return unless ($session->stream // 0) == $c;
$session->stream(undef)->touch;
}
);
}
sub _handle_initialization ($self, $c, $data) {
my $session_id = random_v4uuid;
my $result = $self->_handle($data, MCP::Server::Context->new);
if ($self->streaming) {
$self->sessions->{$session_id} = MCP::Server::Session->new(id => $session_id);
$self->_start_sweep;
}
$c->res->headers->header('Mcp-Session-Id' => $session_id);
$c->render(json => $result, status => 200);
}
sub _handle_post ($self, $c) {
my $session_id = $self->_extract_session_id($c);
return $c->render(json => {error => 'Invalid JSON'}, status => 400) unless my $data = $c->req->json;
return $c->render(json => {error => 'Invalid JSON', status => 400}) unless ref $data eq 'HASH';
if ($data->{method} && $data->{method} eq 'initialize') { $self->_handle_initialization($c, $data) }
else { $self->_handle_regular_request($c, $data, $session_id) }
}
sub _handle_regular_request ($self, $c, $data, $session_id) {
return $c->render(json => {error => 'Missing session ID'}, status => 400) unless $session_id;
if ($self->streaming) {
return $c->render(json => {error => 'Session not found'}, status => 404)
unless my $session = $self->sessions->{$session_id};
$session->touch;
}
$c->res->headers->header('Mcp-Session-Id' => $session_id);
my $context = MCP::Server::Context->new(transport => $self, session_id => $session_id, controller => $c);
return $c->render(data => '', status => 202) unless defined(my $result = $self->_handle($data, $context));
# Sync
return $c->render(json => $result, status => 200) if !blessed($result) || !$result->isa('Mojo::Promise');
# Async
$c->inactivity_timeout(0);
$c->write_sse;
$result->then(sub { $c->write_sse({text => to_json($_[0])})->finish });
}
sub _start_sweep ($self) {
return if $self->{_sweep_id};
return unless my $interval = $self->session_timeout;
weaken(my $self_weak = $self);
$self->{_sweep_id} = Mojo::IOLoop->recurring($interval => sub { $self_weak->_sweep if $self_weak });
}
sub _sweep ($self) {
return unless my $timeout = $self->session_timeout;
my $cutoff = time - $timeout;
my $sessions = $self->sessions;
for my $id (keys %$sessions) {
my $session = $sessions->{$id};
delete $sessions->{$id} if !$session->stream && $session->last_used < $cutoff;
}
}
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.
By default only C requests are handled. When L is enabled, the transport additionally supports
the server-to-client SSE stream (C) and explicit session termination (C) defined by the Streamable
HTTP transport. Note that this requires per-process state and is therefore not compatible with pre-forking web
servers.
=head1 ATTRIBUTES
L inherits all attributes from L and implements the following
new ones.
=head2 heartbeat
my $seconds = $http->heartbeat;
$http = $http->heartbeat(30);
Interval in seconds at which a keep-alive comment is sent on each open server-to-client 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 session_timeout
my $seconds = $http->session_timeout;
$http = $http->session_timeout(3600);
Idle timeout in seconds for sessions without an open server-to-client stream. Defaults to C<3600>; set to C<0> to
disable. A periodic sweep removes sessions whose last activity is older than this value, so the effective lifetime
of an idle session is up to twice the configured timeout. Only used when L is enabled.
=head2 sessions
my $sessions = $http->sessions;
$http = $http->sessions({});
Per-process registry of active L objects, keyed by session ID. Only used when L
is enabled.
=head2 streaming
my $bool = $http->streaming;
$http = $http->streaming(1);
Enable server-to-client streaming and session lifecycle management. Defaults to false. When enabled, the transport
tracks all sessions in L, accepts C requests to open a long-lived SSE stream the server can push
notifications to, and accepts C requests to terminate a session. Requests for unknown sessions are rejected
with status C<404>.
=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
my $bool = $http->notify($session_id, $method);
my $bool = $http->notify($session_id, $method, {foo => 'bar'});
Send a JSON-RPC notification to the open SSE stream of a session. Returns true on success, or C if the
session does not exist or has no open stream. Only available when L is enabled.
=head2 notify_all
my $bool = $http->notify_all($method);
my $bool = $http->notify_all($method, {foo => 'bar'});
Send a JSON-RPC notification to the open SSE stream of every active session. Returns true on success, or C
when L is disabled.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Server/Transport/Stdio.pm 0000644 0000765 0000024 00000004412 15176725323 016614 0 ustar sri staff package MCP::Server::Transport::Stdio;
use Mojo::Base 'MCP::Server::Transport', -signatures;
use MCP::Server::Context;
use Mojo::JSON qw(decode_json encode_json);
use Mojo::Log;
use Scalar::Util qw(blessed);
sub handle_requests ($self) {
my $server = $self->server;
STDOUT->autoflush(1);
while (my $input = <>) {
chomp $input;
my $request = eval { decode_json($input) };
next unless my $response = $server->handle($request, MCP::Server::Context->new(transport => $self));
if (blessed($response) && $response->isa('Mojo::Promise')) {
$response->then(sub { _print_response($_[0]) })->wait;
}
else { _print_response($response) }
}
}
sub notify ($self, $session_id, $method, $params = {}) {
_print_response({jsonrpc => '2.0', method => $method, params => $params});
return 1;
}
sub notify_all ($self, $method, $params = {}) { $self->notify(undef, $method, $params) }
sub _print_response ($response) { print encode_json($response) . "\n" }
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.
=head1 ATTRIBUTES
L inherits all attributes from L.
=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
my $bool = $stdio->notify($session_id, $method);
my $bool = $stdio->notify($session_id, $method, {foo => 'bar'});
Send a JSON-RPC notification to standard output. The C<$session_id> is ignored.
=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.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Server/Session.pm 0000644 0000765 0000024 00000002601 15176716121 015153 0 ustar sri staff package MCP::Server::Session;
use Mojo::Base -base, -signatures;
has [qw(id stream)];
has last_used => sub {time};
sub touch ($self) {
$self->last_used(time);
return $self;
}
1;
=encoding utf8
=head1 NAME
MCP::Server::Session - Session container
=head1 SYNOPSIS
use MCP::Server::Session;
my $session = MCP::Server::Session->new(id => '12345');
$session->touch;
=head1 DESCRIPTION
L is a container for per-session state.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 id
my $id = $session->id;
$session = $session->id('12345');
The session identifier.
=head2 last_used
my $time = $session->last_used;
$session = $session->last_used(time);
Epoch seconds of the last activity on this session, defaults to the time the session was created. Updated by
L.
=head2 stream
my $stream = $session->stream;
$session = $session->stream(Mojolicious::Controller->new);
The L currently serving the server-to-client SSE stream for this session, or C if
no stream is open.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 touch
$session = $session->touch;
Set L to the current time.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Server/Context.pm 0000644 0000765 0000024 00000005225 15176725323 015165 0 ustar sri staff package MCP::Server::Context;
use Mojo::Base -base, -signatures;
has [qw(controller progress_token session_id transport)];
sub notify ($self, $method, $params = {}) {
return undef unless my $transport = $self->transport;
return $transport->notify($self->session_id, $method, $params);
}
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);
}
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 ATTRIBUTES
L implements the following attributes.
=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 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 session_id
my $id = $context->session_id;
$context = $context->session_id('12345');
Identifier of the session this request belongs to.
=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 notify
my $bool = $context->notify($method);
my $bool = $context->notify($method, {foo => 'bar'});
Send a JSON-RPC notification to the client associated with the current request. Returns true on success, or
C if no notification could be delivered.
=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.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Resource.pm 0000644 0000765 0000024 00000005127 15176716121 014057 0 ustar sri staff package MCP::Resource;
use Mojo::Base 'MCP::Primitive', -signatures;
use Mojo::Util qw(b64_encode);
use Scalar::Util qw(blessed);
has code => sub { die 'Resource code not implemented' };
has description => 'Generic MCP resource';
has mime_type => 'text/plain';
has name => 'resource';
has uri => 'file://unknown';
sub binary_resource ($self, $data) {
my $result = {contents => [{uri => $self->uri, mimeType => $self->mime_type, blob => b64_encode($data, '')}]};
return $result;
}
sub call ($self, $context) {
local $self->{context} = $context;
my $result = $self->code->($self);
return $result->then(sub { $self->_type_check($_[0]) }) if blessed($result) && $result->isa('Mojo::Promise');
return $self->_type_check($result);
}
sub text_resource ($self, $text) {
my $result = {contents => [{uri => $self->uri, mimeType => $self->mime_type, text => $text}]};
return $result;
}
sub _type_check ($self, $result) {
return $result if ref $result eq 'HASH' && exists $result->{contents};
return $self->text_resource($result);
}
1;
=encoding utf8
=head1 NAME
MCP::Resource - Resource container
=head1 SYNOPSIS
use MCP::Resource;
my $resource = MCP::Resource->new;
=head1 DESCRIPTION
L is a container for resources.
=head1 ATTRIBUTES
L implements the following attributes.
=head2 code
my $code = $resource->code;
$resource = $resource->code(sub { ... });
Resource code.
=head2 description
my $description = $resource->description;
$resource = $resource->description('A brief description of the resource');
Description of the resource.
=head2 mime_type
my $mime_type = $resource->mime_type;
$resource = $resource->mime_type('text/plain');
MIME type of the resource.
=head2 name
my $name = $resource->name;
$resource = $resource->name('my_resource');
Name of the resource.
=head2 uri
my $uri = $resource->uri;
$resource = $resource->uri('file:///path/to/resource.txt');
URI of the resource.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 binary_resource
my $result = $resource->binary_resource($data);
Returns a binary resource in the expected format.
=head2 call
my $result = $resource->call($context);
Calls the resource with context, returning a result. The result can be a promise or a direct value.
=head2 text_resource
my $result = $resource->text_resource('Some text');
Returns a text resource in the expected format.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Primitive.pm 0000644 0000765 0000024 00000001747 15176725323 014250 0 ustar sri staff package MCP::Primitive;
use Mojo::Base -base, -signatures;
use MCP::Server::Context;
sub context ($self) { $self->{context} || MCP::Server::Context->new }
1;
=encoding utf8
=head1 NAME
MCP::Primitive - Primitive base class
=head1 SYNOPSIS
package MyMCPPrimitive;
use Mojo::Base 'MCP::Primitive';
1;
=head1 DESCRIPTION
L is a base class for MCP (Model Context Protocol) primitives such as L, L,
and L.
=head1 METHODS
L inherits all methods from L and implements the following new ones.
=head2 context
my $context = $primitive->context;
Returns the L for the current request. Capture this before an async boundary to keep using
its notification methods from later callbacks.
# Get controller for requests using the HTTP transport
my $c = $primitive->context->controller;
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.10/lib/MCP/Prompt.pm 0000644 0000765 0000024 00000005223 15176716121 013546 0 ustar sri staff 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};
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.10/lib/MCP/Tool.pm 0000644 0000765 0000024 00000013537 15176716121 013211 0 ustar sri staff package MCP::Tool;
use Mojo::Base 'MCP::Primitive', -signatures;
use JSON::Validator;
use Mojo::JSON qw(false to_json true);
use Mojo::Util qw(b64_encode);
use Scalar::Util qw(blessed);
has annotations => sub { {} };
has code => sub { die 'Tool code not implemented' };
has description => 'Generic MCP tool';
has input_schema => sub { {type => 'object'} };
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 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) {
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) {
unless ($self->{validator}) {
my $validator = $self->{validator} = JSON::Validator->new;
$validator->schema($self->input_schema);
}
my @errors = $self->{validator}->validate($args);
return @errors ? 1 : 0;
}
sub _type_check ($self, $result) {
return $result if ref $result eq 'HASH' && exists $result->{content};
return $self->text_result($result);
}
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.
=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.
=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.
=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