Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package perl-MCP for openSUSE:Factory checked in at 2026-05-18 17:48:00 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/perl-MCP (Old) and /work/SRC/openSUSE:Factory/.perl-MCP.new.1966 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-MCP" Mon May 18 17:48:00 2026 rev:6 rq:1353756 version:0.100.0 Changes: -------- --- /work/SRC/openSUSE:Factory/perl-MCP/perl-MCP.changes 2026-02-19 14:25:14.631362739 +0100 +++ /work/SRC/openSUSE:Factory/.perl-MCP.new.1966/perl-MCP.changes 2026-05-18 17:48:47.234212894 +0200 @@ -1,0 +2,22 @@ +Thu May 7 08:03:53 UTC 2026 - Tina Müller <[email protected]> + +- updated to 0.100.0 (0.10) + see /usr/share/doc/packages/perl-MCP/Changes + + 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. + +------------------------------------------------------------------- Old: ---- MCP-0.08.tar.gz New: ---- MCP-0.10.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-MCP.spec ++++++ --- /var/tmp/diff_new_pack.helyn7/_old 2026-05-18 17:48:47.826237357 +0200 +++ /var/tmp/diff_new_pack.helyn7/_new 2026-05-18 17:48:47.830237523 +0200 @@ -18,10 +18,10 @@ %define cpan_name MCP Name: perl-MCP -Version: 0.80.0 +Version: 0.100.0 Release: 0 -# 0.08 -> normalize -> 0.80.0 -%define cpan_version 0.08 +# 0.10 -> normalize -> 0.100.0 +%define cpan_version 0.10 License: MIT Summary: Connect Perl with AI using MCP (Model Context Protocol) URL: https://metacpan.org/release/%{cpan_name} @@ -41,9 +41,12 @@ Provides: perl(MCP) = %{version} Provides: perl(MCP::Client) Provides: perl(MCP::Constants) +Provides: perl(MCP::Primitive) Provides: perl(MCP::Prompt) Provides: perl(MCP::Resource) Provides: perl(MCP::Server) +Provides: perl(MCP::Server::Context) +Provides: perl(MCP::Server::Session) Provides: perl(MCP::Server::Transport) Provides: perl(MCP::Server::Transport::HTTP) Provides: perl(MCP::Server::Transport::Stdio) ++++++ MCP-0.08.tar.gz -> MCP-0.10.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/Changes new/MCP-0.10/Changes --- old/MCP-0.08/Changes 2026-02-17 13:14:19.000000000 +0100 +++ new/MCP-0.10/Changes 2026-05-06 22:55:47.000000000 +0200 @@ -1,4 +1,20 @@ +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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/MANIFEST new/MCP-0.10/MANIFEST --- old/MCP-0.08/MANIFEST 2026-02-17 13:15:49.000000000 +0100 +++ new/MCP-0.10/MANIFEST 2026-05-06 22:58:51.000000000 +0200 @@ -2,12 +2,16 @@ 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 @@ -26,5 +30,6 @@ 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/META.json new/MCP-0.10/META.json --- old/MCP-0.08/META.json 2026-02-17 13:15:49.000000000 +0100 +++ new/MCP-0.10/META.json 2026-05-06 22:58:51.000000000 +0200 @@ -61,6 +61,6 @@ "web" : "https://web.libera.chat/#mojo"; } }, - "version" : "0.08", + "version" : "0.10", "x_serialization_backend" : "JSON::PP version 4.16" } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/META.yml new/MCP-0.10/META.yml --- old/MCP-0.08/META.yml 2026-02-17 13:15:49.000000000 +0100 +++ new/MCP-0.10/META.yml 2026-05-06 22:58:51.000000000 +0200 @@ -33,5 +33,5 @@ homepage: https://mojolicious.org license: http://www.opensource.org/licenses/mit repository: https://github.com/mojolicious/mojo-mcp.git -version: '0.08' +version: '0.10' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/README.md new/MCP-0.10/README.md --- old/MCP-0.08/README.md 2025-12-04 15:39:51.000000000 +0100 +++ new/MCP-0.10/README.md 2026-05-06 22:55:47.000000000 +0200 @@ -13,6 +13,8 @@ * 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 @@ -51,6 +53,33 @@ 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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/examples/streaming_http.pl new/MCP-0.10/examples/streaming_http.pl --- old/MCP-0.08/examples/streaming_http.pl 1970-01-01 01:00:00.000000000 +0100 +++ new/MCP-0.10/examples/streaming_http.pl 2026-05-06 22:55:47.000000000 +0200 @@ -0,0 +1,45 @@ +# +# 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; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Client.pm new/MCP-0.10/lib/MCP/Client.pm --- old/MCP-0.08/lib/MCP/Client.pm 2025-12-04 15:39:51.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Client.pm 2026-05-06 21:53:53.000000000 +0200 @@ -28,6 +28,18 @@ 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)); @@ -179,6 +191,14 @@ 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<DELETE> request to terminate the current session on the MCP server, and clear the local +L</"session_id">. Returns true on success, or C<undef> 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'); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Primitive.pm new/MCP-0.10/lib/MCP/Primitive.pm --- old/MCP-0.08/lib/MCP/Primitive.pm 1970-01-01 01:00:00.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Primitive.pm 2026-05-06 22:55:47.000000000 +0200 @@ -0,0 +1,46 @@ +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<MCP::Primitive> is a base class for MCP (Model Context Protocol) primitives such as L<MCP::Tool>, L<MCP::Prompt>, +and L<MCP::Resource>. + +=head1 METHODS + +L<MCP::Primitive> inherits all methods from L<Mojo::Base> and implements the following new ones. + +=head2 context + + my $context = $primitive->context; + +Returns the L<MCP::Server::Context> 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<MCP>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. + +=cut diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Prompt.pm new/MCP-0.10/lib/MCP/Prompt.pm --- old/MCP-0.08/lib/MCP/Prompt.pm 2026-01-16 17:04:58.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Prompt.pm 2026-05-06 21:53:53.000000000 +0200 @@ -1,5 +1,5 @@ package MCP::Prompt; -use Mojo::Base -base, -signatures; +use Mojo::Base 'MCP::Primitive', -signatures; use Scalar::Util qw(blessed); @@ -15,8 +15,6 @@ 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; @@ -88,7 +86,7 @@ =head1 METHODS -L<MCP::Prompt> inherits all methods from L<Mojo::Base> and implements the following new ones. +L<MCP::Prompt> inherits all methods from L<MCP::Primitive> and implements the following new ones. =head2 call @@ -97,15 +95,6 @@ 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'); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Resource.pm new/MCP-0.10/lib/MCP/Resource.pm --- old/MCP-0.08/lib/MCP/Resource.pm 2025-12-05 14:06:47.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Resource.pm 2026-05-06 21:53:53.000000000 +0200 @@ -1,5 +1,5 @@ package MCP::Resource; -use Mojo::Base -base, -signatures; +use Mojo::Base 'MCP::Primitive', -signatures; use Mojo::Util qw(b64_encode); use Scalar::Util qw(blessed); @@ -22,8 +22,6 @@ 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; @@ -93,7 +91,7 @@ =head1 METHODS -L<MCP::Resource> inherits all methods from L<Mojo::Base> and implements the following new ones. +L<MCP::Resource> inherits all methods from L<MCP::Primitive> and implements the following new ones. =head2 binary_resource @@ -107,15 +105,6 @@ 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'); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server/Context.pm new/MCP-0.10/lib/MCP/Server/Context.pm --- old/MCP-0.08/lib/MCP/Server/Context.pm 1970-01-01 01:00:00.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Server/Context.pm 2026-05-06 22:55:47.000000000 +0200 @@ -0,0 +1,95 @@ +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<MCP::Server::Context> is a container for per-invocation request context. + +=head1 ATTRIBUTES + +L<MCP::Server::Context> implements the following attributes. + +=head2 controller + + my $c = $context->controller; + $context = $context->controller(Mojolicious::Controller->new); + +The L<Mojolicious::Controller> 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<undef> 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<MCP::Server::Context> inherits all methods from L<Mojo::Base> 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<undef> 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<notifications/progress> JSON-RPC notification for the progress token associated with the current request. +Returns true on success, or C<undef> if no progress token was provided by the client. + +=head1 SEE ALSO + +L<MCP>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. + +=cut diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server/Session.pm new/MCP-0.10/lib/MCP/Server/Session.pm --- old/MCP-0.08/lib/MCP/Server/Session.pm 1970-01-01 01:00:00.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Server/Session.pm 2026-05-06 21:53:53.000000000 +0200 @@ -0,0 +1,72 @@ +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<MCP::Server::Session> is a container for per-session state. + +=head1 ATTRIBUTES + +L<MCP::Server::Session> 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</"touch">. + +=head2 stream + + my $stream = $session->stream; + $session = $session->stream(Mojolicious::Controller->new); + +The L<Mojolicious::Controller> currently serving the server-to-client SSE stream for this session, or C<undef> if +no stream is open. + +=head1 METHODS + +L<MCP::Server::Session> inherits all methods from L<Mojo::Base> and implements the following new ones. + +=head2 touch + + $session = $session->touch; + +Set L</"last_used"> to the current time. + +=head1 SEE ALSO + +L<MCP>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. + +=cut diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server/Transport/HTTP.pm new/MCP-0.10/lib/MCP/Server/Transport/HTTP.pm --- old/MCP-0.08/lib/MCP/Server/Transport/HTTP.pm 2025-08-01 18:01:33.000000000 +0200 +++ new/MCP-0.10/lib/MCP/Server/Transport/HTTP.pm 2026-05-06 22:55:47.000000000 +0200 @@ -1,19 +1,48 @@ package MCP::Server::Transport::HTTP; use Mojo::Base 'MCP::Server::Transport', -signatures; -use Crypt::Misc qw(random_v4uuid); +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); +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_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) { @@ -23,9 +52,52 @@ 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, {}); + 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); } @@ -42,10 +114,15 @@ 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); - return $c->render(data => '', status => 202) - unless defined(my $result = $self->_handle($data, {session_id => $session_id, controller => $c})); + 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'); @@ -56,6 +133,23 @@ $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 @@ -75,9 +169,51 @@ L<MCP::Server::Transport::HTTP> is a transport for MCP (Model Context Protocol) server that uses HTTP as the underlying transport mechanism. +By default only C<POST> requests are handled. When L</"streaming"> is enabled, the transport additionally supports +the server-to-client SSE stream (C<GET>) and explicit session termination (C<DELETE>) 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<MCP::Server::Transport::HTTP> inherits all attributes from L<MCP::Server::Transport>. +L<MCP::Server::Transport::HTTP> inherits all attributes from L<MCP::Server::Transport> 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</"streaming"> 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</"streaming"> is enabled. + +=head2 sessions + + my $sessions = $http->sessions; + $http = $http->sessions({}); + +Per-process registry of active L<MCP::Server::Session> objects, keyed by session ID. Only used when L</"streaming"> +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</"sessions">, accepts C<GET> requests to open a long-lived SSE stream the server can push +notifications to, and accepts C<DELETE> requests to terminate a session. Requests for unknown sessions are rejected +with status C<404>. =head1 METHODS @@ -90,6 +226,28 @@ Handles an incoming HTTP request. +=head2 notifications + + my $bool = $http->notifications; + +True when L</"streaming"> 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<undef> if the +session does not exist or has no open stream. Only available when L</"streaming"> 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<undef> +when L</"streaming"> is disabled. + =head1 SEE ALSO L<MCP>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server/Transport/Stdio.pm new/MCP-0.10/lib/MCP/Server/Transport/Stdio.pm --- old/MCP-0.08/lib/MCP/Server/Transport/Stdio.pm 2025-08-01 16:24:57.000000000 +0200 +++ new/MCP-0.10/lib/MCP/Server/Transport/Stdio.pm 2026-05-06 22:55:47.000000000 +0200 @@ -1,6 +1,7 @@ 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); @@ -12,7 +13,7 @@ while (my $input = <>) { chomp $input; my $request = eval { decode_json($input) }; - next unless my $response = $server->handle($request, {}); + 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; @@ -21,6 +22,13 @@ } } +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; @@ -58,6 +66,20 @@ 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<MCP>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server/Transport.pm new/MCP-0.10/lib/MCP/Server/Transport.pm --- old/MCP-0.08/lib/MCP/Server/Transport.pm 2025-08-01 16:24:21.000000000 +0200 +++ new/MCP-0.10/lib/MCP/Server/Transport.pm 2026-05-06 21:53:53.000000000 +0200 @@ -3,6 +3,8 @@ has 'server'; +sub notifications ($self) {1} + 1; =encoding utf8 @@ -33,6 +35,16 @@ The server instance that this transport is associated with. +=head1 METHODS + +L<MCP::Server::Transport> 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<Mojolicious>, L<https://mojolicious.org>, L<https://modelcontextprotocol.io>. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Server.pm new/MCP-0.10/lib/MCP/Server.pm --- old/MCP-0.08/lib/MCP/Server.pm 2026-02-17 13:13:13.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Server.pm 2026-05-06 22:55:47.000000000 +0200 @@ -25,6 +25,9 @@ # 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); @@ -62,6 +65,11 @@ 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; @@ -74,8 +82,8 @@ return $resource; } -sub to_action ($self) { - $self->transport(my $http = MCP::Server::Transport::HTTP->new(server => $self)); +sub to_action ($self, $options = {}) { + $self->transport(my $http = MCP::Server::Transport::HTTP->new(server => $self, %$options)); return sub ($c) { $http->handle_request($c) }; } @@ -91,9 +99,11 @@ } sub _handle_initialize ($self, $params) { + my $transport = $self->transport; + my $caps = $transport && $transport->notifications ? {listChanged => true} : {}; return { protocolVersion => PROTOCOL_VERSION, - capabilities => {prompts => {}, resources => {}, tools => {}}, + capabilities => {prompts => $caps, resources => $caps, tools => $caps}, serverInfo => {name => $self->name, version => $self->version} }; } @@ -322,6 +332,13 @@ Handle a JSON-RPC request and return a response. +=head2 notify_list_changed + + my $bool = $server->notify_list_changed('tools'); + +Broadcast a C<notifications/$kind/list_changed> JSON-RPC notification to all connected clients. Returns true on +success, or C<undef> if no notification could be delivered. + =head2 prompt my $prompt = $server->prompt( @@ -348,8 +365,11 @@ =head2 to_action my $action = $server->to_action; + my $action = $server->to_action({streaming => 1}); -Convert the server to a L<Mojolicious> action. +Convert the server to a L<Mojolicious> action. Any options are passed through to the constructor of +L<MCP::Server::Transport::HTTP>; in particular, C<< streaming => 1 >> opts in to the server-to-client SSE stream +and explicit session termination. =head2 to_stdio diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP/Tool.pm new/MCP-0.10/lib/MCP/Tool.pm --- old/MCP-0.08/lib/MCP/Tool.pm 2026-02-17 13:13:13.000000000 +0100 +++ new/MCP-0.10/lib/MCP/Tool.pm 2026-05-06 21:53:53.000000000 +0200 @@ -1,5 +1,5 @@ package MCP::Tool; -use Mojo::Base -base, -signatures; +use Mojo::Base 'MCP::Primitive', -signatures; use JSON::Validator; use Mojo::JSON qw(false to_json true); @@ -27,8 +27,6 @@ return $self->_type_check($result); } -sub context ($self) { $self->{context} || {} } - sub image_result ($self, $image, $options = {}, $is_error = 0) { return { content => [{ @@ -146,7 +144,7 @@ =head1 METHODS -L<MCP::Tool> inherits all methods from L<Mojo::Base> and implements the following new ones. +L<MCP::Tool> inherits all methods from L<MCP::Primitive> and implements the following new ones. =head2 audio_result @@ -172,15 +170,6 @@ Calls the tool with the given arguments and context, returning a result. The result can be a promise or a direct value. -=head2 context - - my $context = $tool->context; - -Returns the context in which the tool is executed. - - # Get controller for requests using the HTTP transport - my $c = $tool->context->{controller}; - =head2 image_result my $result = $tool->image_result($bytes, $options, $is_error); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/lib/MCP.pm new/MCP-0.10/lib/MCP.pm --- old/MCP-0.08/lib/MCP.pm 2026-02-17 13:14:27.000000000 +0100 +++ new/MCP-0.10/lib/MCP.pm 2026-05-06 21:53:53.000000000 +0200 @@ -1,7 +1,7 @@ package MCP; use Mojo::Base -base, -signatures; -our $VERSION = '0.08'; +our $VERSION = '0.10'; 1; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/t/apps/stdio.pl new/MCP-0.10/t/apps/stdio.pl --- old/MCP-0.08/t/apps/stdio.pl 2025-08-01 00:25:30.000000000 +0200 +++ new/MCP-0.10/t/apps/stdio.pl 2026-05-06 22:55:47.000000000 +0200 @@ -23,5 +23,31 @@ 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; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/t/lib/MCPStdioTest.pm new/MCP-0.10/t/lib/MCPStdioTest.pm --- old/MCP-0.08/t/lib/MCPStdioTest.pm 2025-07-30 18:31:36.000000000 +0200 +++ new/MCP-0.10/t/lib/MCPStdioTest.pm 2026-05-06 21:53:53.000000000 +0200 @@ -15,15 +15,21 @@ 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"; - - my $stdout = $self->{stdout}; - pump $self->{run} until $self->{stdout} =~ s/^(.*)\n//; - my $input = $1; - my $res = eval { decode_json($input) }; - return $res; + return 1; } sub run ($self, @command) { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/t/lite_app.t new/MCP-0.10/t/lite_app.t --- old/MCP-0.08/t/lite_app.t 2026-02-17 13:13:13.000000000 +0100 +++ new/MCP-0.10/t/lite_app.t 2026-05-06 21:53:53.000000000 +0200 @@ -8,6 +8,7 @@ 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')); @@ -15,8 +16,15 @@ $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')); @@ -26,11 +34,14 @@ 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'; + 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 { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/t/stdio.t new/MCP-0.10/t/stdio.t --- old/MCP-0.08/t/stdio.t 2025-08-01 00:26:57.000000000 +0200 +++ new/MCP-0.10/t/stdio.t 2026-05-06 22:55:47.000000000 +0200 @@ -8,7 +8,7 @@ use MCP::Constants qw(PROTOCOL_VERSION); use Mojo::File qw(curfile); -use Mojo::JSON qw(false); +use Mojo::JSON qw(false true); use lib curfile->dirname->child('lib')->to_string; use MCPStdioTest; @@ -24,6 +24,9 @@ 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'; }; @@ -64,6 +67,49 @@ '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; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MCP-0.08/t/streaming.t new/MCP-0.10/t/streaming.t --- old/MCP-0.08/t/streaming.t 1970-01-01 01:00:00.000000000 +0100 +++ new/MCP-0.10/t/streaming.t 2026-05-06 22:55:47.000000000 +0200 @@ -0,0 +1,321 @@ +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; ++++++ _scmsync.obsinfo ++++++ --- /var/tmp/diff_new_pack.helyn7/_old 2026-05-18 17:48:48.010244961 +0200 +++ /var/tmp/diff_new_pack.helyn7/_new 2026-05-18 17:48:48.014245127 +0200 @@ -1,6 +1,6 @@ -mtime: 1771395409 -commit: 5fce262571f96f3e649b7c5fce0471e36b7911ce4d8f0b70b46e7f5dde1753a6 -url: https://src.opensuse.org/perl/perl-MCP.git -revision: 5fce262571f96f3e649b7c5fce0471e36b7911ce4d8f0b70b46e7f5dde1753a6 +mtime: 1778141034 +commit: 2743c0c65b98fe23eefe3241e65f3926ea2b56fd6924cd9044f09a4d0c0d5a98 +url: https://src.opensuse.org/perl/perl-MCP +revision: 2743c0c65b98fe23eefe3241e65f3926ea2b56fd6924cd9044f09a4d0c0d5a98 projectscmsync: https://src.opensuse.org/perl/_ObsPrj ++++++ build.specials.obscpio ++++++ ++++++ build.specials.obscpio ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/.gitignore new/.gitignore --- old/.gitignore 1970-01-01 01:00:00.000000000 +0100 +++ new/.gitignore 2026-05-07 10:03:54.000000000 +0200 @@ -0,0 +1 @@ +.osc
