MCP-0.08/ 0000755 0000765 0000024 00000000000 15145055765 010555 5 ustar sri staff MCP-0.08/LICENSE 0000644 0000765 0000024 00000002073 15031727753 011561 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.08/Changes 0000644 0000765 0000024 00000002303 15145055633 012040 0 ustar sri staff
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.08/MANIFEST 0000644 0000765 0000024 00000001250 15145055765 011704 0 ustar sri staff .perltidyrc
Changes
examples/echo_http.pl
examples/echo_stdio.pl
lib/MCP.pm
lib/MCP/Client.pm
lib/MCP/Constants.pm
lib/MCP/Prompt.pm
lib/MCP/Resource.pm
lib/MCP/Server.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
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
MCP-0.08/t/ 0000755 0000765 0000024 00000000000 15145055765 011020 5 ustar sri staff MCP-0.08/t/pod.t 0000644 0000765 0000024 00000000431 15043143763 011756 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.08/t/session_specific_app.t 0000644 0000765 0000024 00000013163 15132461025 015363 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.08/t/lib/ 0000755 0000765 0000024 00000000000 15145055765 011566 5 ustar sri staff MCP-0.08/t/lib/MCPStdioTest.pm 0000644 0000765 0000024 00000002062 15042444350 014372 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 request ($self, $method, $params) {
$self->{timeout}->start(60);
$self->{stdin} .= encode_json($self->client->build_request($method, $params)) . "\n";
my $stdout = $self->{stdout};
pump $self->{run} until $self->{stdout} =~ s/^(.*)\n//;
my $input = $1;
my $res = eval { decode_json($input) };
return $res;
}
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.08/t/stdio.t 0000644 0000765 0000024 00000005603 15042766661 012333 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);
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';
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';
};
ok $test->stop, 'process stopped';
done_testing;
MCP-0.08/t/pod_coverage.t 0000644 0000765 0000024 00000000446 15043143757 013642 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.08/t/apps/ 0000755 0000765 0000024 00000000000 15145055765 011763 5 ustar sri staff MCP-0.08/t/apps/mojolicious.png 0000644 0000765 0000024 00000007772 15043171466 015034 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.08/t/apps/empty.wav 0000644 0000765 0000024 00000000116 15114316467 013631 0 ustar sri staff RIFFF WAVEfmt D LIST INFOISFT
Lavf62.3.100 data MCP-0.08/t/apps/stdio.pl 0000644 0000765 0000024 00000001446 15042766532 013444 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->to_stdio;
MCP-0.08/t/apps/lite_app.pl 0000644 0000765 0000024 00000013372 15145055531 014112 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.08/t/lite_app.t 0000644 0000765 0000024 00000036524 15145055531 013003 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);
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 'MCP endpoint' => sub {
$t->get_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 $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.08/README.md 0000644 0000765 0000024 00000004634 15114316467 012036 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
* 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.
## 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.08/examples/ 0000755 0000765 0000024 00000000000 15145055765 012373 5 ustar sri staff MCP-0.08/examples/echo_stdio.pl 0000644 0000765 0000024 00000001417 15054060316 015036 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.08/examples/echo_http.pl 0000644 0000765 0000024 00000001553 15114316140 014670 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.08/META.yml 0000644 0000765 0000024 00000001727 15145055765 012035 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.08'
x_serialization_backend: 'CPAN::Meta::YAML version 0.020'
MCP-0.08/lib/ 0000755 0000765 0000024 00000000000 15145055765 011323 5 ustar sri staff MCP-0.08/lib/MCP/ 0000755 0000765 0000024 00000000000 15145055765 011742 5 ustar sri staff MCP-0.08/lib/MCP/Server.pm 0000644 0000765 0000024 00000024350 15145055531 013541 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})) {
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 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) {
$self->transport(my $http = MCP::Server::Transport::HTTP->new(server => $self));
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) {
return {
protocolVersion => PROTOCOL_VERSION,
capabilities => {prompts => {}, resources => {}, tools => {}},
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 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;
Convert the server to a L action.
=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.08/lib/MCP/Constants.pm 0000644 0000765 0000024 00000002333 15114322113 014231 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.08/lib/MCP/Client.pm 0000644 0000765 0000024 00000015026 15114316467 013515 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 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 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.08/lib/MCP/Server/ 0000755 0000765 0000024 00000000000 15145055765 013210 5 ustar sri staff MCP-0.08/lib/MCP/Server/Transport.pm 0000644 0000765 0000024 00000001321 15043147025 015523 0 ustar sri staff package MCP::Server::Transport;
use Mojo::Base -base, -signatures;
has 'server';
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 SEE ALSO
L, L, L.
=cut
MCP-0.08/lib/MCP/Server/Transport/ 0000755 0000765 0000024 00000000000 15145055765 015204 5 ustar sri staff MCP-0.08/lib/MCP/Server/Transport/HTTP.pm 0000644 0000765 0000024 00000005653 15043162335 016317 0 ustar sri staff package MCP::Server::Transport::HTTP;
use Mojo::Base 'MCP::Server::Transport', -signatures;
use Crypt::Misc qw(random_v4uuid);
use Mojo::JSON qw(to_json true);
use Mojo::Util qw(dumper);
use Scalar::Util qw(blessed);
use constant DEBUG => $ENV{MCP_DEBUG} || 0;
sub handle_request ($self, $c) {
my $method = $c->req->method;
return $self->_handle_post($c) if $method eq 'POST';
return $c->render(json => {error => 'Method not allowed'}, status => 405);
}
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_initialization ($self, $c, $data) {
my $session_id = random_v4uuid;
my $result = $self->_handle($data, {});
$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;
$c->res->headers->header('Mcp-Session-Id' => $session_id);
return $c->render(data => '', status => 202)
unless defined(my $result = $self->_handle($data, {session_id => $session_id, controller => $c}));
# 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 });
}
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.
=head1 ATTRIBUTES
L inherits all attributes from L.
=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.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.08/lib/MCP/Server/Transport/Stdio.pm 0000644 0000765 0000024 00000003125 15043147071 016612 0 ustar sri staff package MCP::Server::Transport::Stdio;
use Mojo::Base 'MCP::Server::Transport', -signatures;
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, {});
if (blessed($response) && $response->isa('Mojo::Promise')) {
$response->then(sub { _print_response($_[0]) })->wait;
}
else { _print_response($response) }
}
}
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.
=head1 SEE ALSO
L, L, L.
=cut
MCP-0.08/lib/MCP/Resource.pm 0000644 0000765 0000024 00000005512 15114554347 014066 0 ustar sri staff package MCP::Resource;
use Mojo::Base -base, -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 context ($self) { $self->{context} || {} }
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 context
my $context = $resource->context;
Returns the context in which the resouce is executed.
# Get controller for requests using the HTTP transport
my $c = $resource->context->{controller};
=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.08/lib/MCP/Prompt.pm 0000644 0000765 0000024 00000005601 15132460652 013552 0 ustar sri staff package MCP::Prompt;
use Mojo::Base -base, -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 context ($self) { $self->{context} || {} }
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 context
my $context = $prompt->context;
Returns the context in which the prompt is executed.
# Get controller for requests using the HTTP transport
my $c = $prompt->context->{controller};
=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.08/lib/MCP/Tool.pm 0000644 0000765 0000024 00000014107 15145055531 013207 0 ustar sri staff package MCP::Tool;
use Mojo::Base -base, -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 context ($self) { $self->{context} || {} }
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