lib/AnyEvent/MCP.pm

=head1 NAME

AnyEvent::MCP - Model Context Protocol client/server support

=head1 SYNOPSIS

   use AnyEvent::MCP::Server::Simple;

   mcp_tool ...
   mcp_start;

or use the object interface directly:

   use AnyEvent::MCP::Server;

   my $server = AnyEvent::MCP::Server->new (...);

=head1 DESCRIPTION

AnyEvent::MCP provides event-driven Model Context Protocol client and server
support.

The usual way to implement a small MCP server is
L<AnyEvent::MCP::Server::Simple>, which provides a function-based interface and
creates the underlying server objects when a transport such as stdio or HTTP is
started.

The lower-level object interfaces are intended for applications that need to
manage MCP connections, servers or reusable tool registries directly.

=head2 MODULES

=over 4

=item L<AnyEvent::MCP::Server::Simple>

Function-based interface for implementing ordinary MCP servers.

=item L<AnyEvent::MCP::Server>

Object-oriented MCP server interface.

=item L<AnyEvent::MCP::Client>

Object-oriented MCP client interface.

=item L<AnyEvent::MCP::Server::Toolset>

Reusable registry of MCP tool declarations.

=item L<AnyEvent::MCP::Server::Permissions>

Permission and capability handling for MCP servers.

=back

C<mcp-multibroker> combines downstream HTTP and stdio servers under tool-name
prefixes. It uses the same client, server and permission helper facilities,
including modern input forwarding and local permission prompts for legacy
callers. Run C<mcp-multibroker --help> for command-line syntax; its manual
describes authentication and configuration.

The interfaces are still being designed; this documentation is intentionally
only an overview for now.

=head1 GLOBAL CONFIGURATION

The shared per-user configuration is C<$XDG_CONFIG_HOME/anyevent-mcp/global.ini>,
or C<$HOME/.config/anyevent-mcp/global.ini> when XDG_CONFIG_HOME is unset.
L<AnyEvent::MCP::Config> loads and holds it; loading this module does not access
configuration files.

The file is UTF-8 and uses sections with single-line C<key = value> pairs.
Values are unquoted strings. Blank lines and whole-line comments beginning
with C<#> or C<;> are ignored; inline comment characters remain part of the
value. Later occurrences of a key replace earlier ones in the same section.

   [global]
   secret = ...128 hexadecimal digits...

   [server example]
   port = 31740
   url = https://example.net:31740/{cookie}/

   [mcp-fs]
   utility = /path/to/utility

Section names are unrestricted. Application-specific sections, including
exports, utility paths and user settings, are documented by their applications.

C<[global]> holds C<secret>, a 64-byte master key encoded as 128 hexadecimal
digits. The file must be owned by the current user, with no group or other
permissions. A missing secret is generated automatically on first configuration
access and saved when possible. Existing secrets are never replaced implicitly.
An invalid secret is an error.

If saving fails, Config warns and retains the secret in memory. Credentials
then remain stable only for that process; other processes cannot derive the
same credentials. If randomness is unavailable, supply a securely generated
secret in the file.

C<[server NAME]> holds named-server settings. Its C<url> is a complete template;
C<{cookie}> is replaced with the cookie derived for that server and optional
username. Scheme, host, port and cookie placement are explicit in the template.
HTTP servers with an explicit C<name> load C<host>, C<port>, C<path>,
C<url_host>, C<url_scheme>, C<cookie>, C<bearer> and C<users> from this section
as defaults. C<users> is a comma-separated allowlist whose Basic passwords
are derived for the named server. An explicit password hash can instead be
passed to the constructor. C<url> is a template for the utility program; it
does not set the listener's address.

C<mcp_start> chooses an application name and supplies cookie/bearer
authentication by default. Explicit authentication settings replace this
default. Stdio startup does not access global configuration.

C<[client NAME]> supplies HTTP client defaults: C<url>, C<bearer>, C<username>,
C<password> and C<timeout>. Clients consult it only when explicitly given a
C<name>. An unnamed client or HTTP server does not read global configuration.
Explicit constructor arguments take precedence over named defaults.

=head1 ENVIRONMENT

Project-specific environment variables use the C<PERL_ANYEVENT_MCP_> prefix.
C<PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL=stdio> selects stdio in Simple.
C<PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS> supplies the default application name.
C<PERL_ANYEVENT_MCP_PERMISSION_HELPER> selects the external asking executable.
Standard C<HOME> and C<XDG_CONFIG_HOME> keep their standard names.

=head1 FUNCTIONS

=head2 $bytes = AnyEvent::MCP::random_bytes $length

Returns exactly C<$length> random bytes. Tries C</dev/urandom>, then an external
C<openssl rand> command. No additional random-number module is required.
Dies if neither source supplies the requested bytes successfully.
C<$length> must be a nonnegative integer; zero returns an empty string.

=head2 ($diff, $max_offset) = AnyEvent::MCP::normalize_udiff $diff

Normalizes a relaxed, single-file unified diff into ordinary unified diff
syntax. Returns the normalized C<$diff> and an array reference C<$max_offset>
containing the permitted whole-hunk relocation for each hunk, in order.
Dies on malformed hunks or when no hunks are found.

=head3 Input format

In a hunk header, only the old start C<-N> matters. It is the old-file line
of the first hunk body line, including context, not necessarily the first
changed line. Counts and the new-file position are ignored and recomputed.
Both ordinary headers and the abbreviated form are accepted:

   @@ -42,99 +123,99 @@
   @@ -42 @@

Optional text after the closing C<@@> is preserved. File headers and other
text before the first hunk are preserved; a diff must describe one file.

Hunk body lines use the usual prefixes: a space for unchanged context,
C<-> for removed lines and C<+> for added lines. The
C<\ No newline at end of file> marker is preserved and counts neither side.
Trailing empty lines outside the final hunk are discarded.

Pure insertion is permitted only at the beginning, using old start zero.
An insertion elsewhere needs old-side context. Empty hunks are rejected.
New positions include the cumulative line-count changes of preceding hunks.

=head3 Applying the result

This function does not apply the patch, check file contents or guard against
concurrent edits. The caller must supply those checks.

Context must match exactly: apply with fuzz zero. For each hunk,
C<$max_offset> permits relocation by at most the number of distinct old-side
lines minus one, or zero for a pure insertion. Repeated old-side lines do
not increase this allowance. The applier must enforce these limits; an
unrestricted search for matching context can select the wrong occurrence.

For live Vim buffers, also require the expected changedtick to match.
File-based users need an equivalent check before replacing the file.

To work around GNU patch's handling of asymmetric context, the first context
line of each hunk is rewritten as an identity removal/addition. The line
contents and old/new line counts are unchanged. This is normalization for
the patch applier, not a relaxation of context matching.

=head2 $parsed = AnyEvent::MCP::parse_patch_output $output

Parses C<LC_ALL=C> GNU patch C<--verbose> output without judging whether
the application is acceptable. C<$parsed> has two fields:

=over 4

=item hunks => [$hunk...]

Hunk records in output order. Each record contains C<hunk> (the one-based
number), C<success>, C<line> (the reported application line), C<fuzz> and
the signed C<offset>. Omitted fuzz and offset are zero. Failed and ignored
hunks have false C<success>.

=item unparsed => [$line...]

Lines not recognized as hunk results or GNU patch's verbose framing.
The parser preserves them for callers to interpret or reject.

=back

Use verbose output: ordinary patch output omits exact-position successes,
so it cannot account for every hunk.

=head2 $hunks = AnyEvent::MCP::check_patch_output $status, $output, [$max_offset...]

Parses C<$output> and validates a complete application. C<$status> is the
raw process wait status, as returned by C<waitpid> or
C<AnyEvent::Util::run_cmd>, not just the exit code.

Requires status zero, no unrecognized output, exactly the expected hunks
in numbered order, successful application, fuzz zero and each signed offset
within its corresponding absolute limit. C<[$max_offset...]> is the array
reference returned by C<normalize_udiff>. At least one hunk is required.

Returns the parsed hunk array reference on success; otherwise dies with a
diagnostic. This is also suitable for callers running patch inside their
own sandbox.

=head2 $cv = AnyEvent::MCP::apply_udiff $input, $output, $diff

Asynchronously applies the relaxed C<$diff> to the input file C<$input>,
writing a separate output file C<$output>. C<$diff> must contain bytes;
callers working with characters must encode them for the file themselves.

Normalizes the diff, runs GNU patch using C<AnyEvent::Util::run_cmd>, and
validates its verbose output with C<check_patch_output>. The command uses
batch/forward mode, binary mode and fuzz zero. No shell is involved.

C<$output> must not exist. It is reserved with mode 0600; patch runs in its
directory so incidental temporary files stay there. Input and output paths
are made absolute before starting the command. These must be trusted paths
in a directory controlled by the caller.

Returns a condition variable. Its C<recv> returns the validated hunk array
reference, or throws on command/application failure. Setup failures throw
synchronously. Failed or partial output is removed. C<$input> is unchanged.

The caller owns committing the successful output and removing it when no
longer needed. Freshness checks, metadata preservation, atomic replacement
and application-specific permissions also belong to the caller.

=cut

package AnyEvent::MCP;

use common::sense;
use Digest::SHA ();

our $VERSION = '0.0';

sub random_bytes($) {
   my ($length) = @_;

   die "Invalid random byte count\n"
      unless defined $length && $length =~ /\A[0-9]+\z/;
   return "" unless $length;

   my $bytes = "";

   if (open my $fh, "<", "/dev/urandom") {
      binmode $fh;
      while (length $bytes < $length) {
         read ($fh, $bytes, $length - length ($bytes), length $bytes)
            or last;
      }
      close $fh;

      return $bytes if length $bytes == $length;
   }

   if (open my $fh, "-|", "openssl", "rand", $length) {
      binmode $fh;
      local $/;
      $bytes = <$fh>;
      my $success = close $fh;

      return $bytes
         if $success && defined $bytes && length $bytes == $length;
   }

   die "Cannot obtain $length random bytes from /dev/urandom or openssl rand\n";
}

sub hkdf_sha512_expand($$$) {
   my ($prk, $info, $l) = @_;

   64 == length $prk
      or die "hkdf_sha512_expand: prk length mist be 64 octets";

   my $t   = "";
   my $okm = "";
   my $i   = 0;

   do {
      $t = Digest::SHA::hmac_sha512 $t . $info . chr ++$i, $prk;
      $okm .= $t;
   } while $l > length $okm;

   substr $okm, 0, $l
}

sub normalize_udiff {
   my $diff = shift;
   my @line = split /\n/, $diff, -1;
   my $delta = 0;
   my $hunks = 0;
   my @max_offset;

   pop @line while @line and !length $line[-1];

   for (my $i = 0; $i < @line; ++$i) {
      next unless $line[$i] =~ /^@@ /;

      $line[$i] =~ /^@@ -(\d+)(?:,\d+)?(?: \+\d+(?:,\d+)?)? @@(.*)$/
         or die "normalize_udiff: bad hunk header '$line[$i]'\n";

      my ($old_start, $suffix) = ($1, $2);
      my ($old_count, $new_count) = (0, 0);
      my %old_line;
      my $j = $i + 1;

      # GNU patch mishandles hunks with more prefix than suffix context.
      # Make the first context line an identity change without losing it.
      # see https://unix.stackexchange.com/questions/414542/does-patch-work-with-asymmetric-context
      splice @line, $i + 1, 1, "-$1", "+$1"
         if $line[$i + 1] =~ /^ (.*)\z/;

      for (; $j < @line; ++$j) {
         last if $line[$j] =~ /^@@ /;

         my $tag = substr $line[$j], 0, 1;

         if ($tag eq " ") {
            ++$old_count;
            ++$new_count;
            $old_line{substr $line[$j], 1} = 1;
         } elsif ($tag eq "-") {
            ++$old_count;
            $old_line{substr $line[$j], 1} = 1;
         } elsif ($tag eq "+") {
            ++$new_count;
         } elsif ($line[$j] eq "\\ No newline at end of file") {
            # Marker belongs to the preceding body line and counts neither side.
         } else {
            die "normalize_udiff: bad hunk line '$line[$j]'\n";
         }
      }

      $old_count or $new_count
         or die "normalize_udiff: empty hunk at old line $old_start\n";

      $old_count or !$old_start
         or die "normalize_udiff: hunk " . ($hunks + 1)
              . " needs old-side context for insertion after old line $old_start\n";

      my $new_start = $old_start + $delta;
      ++$new_start unless $old_count;
      --$new_start unless $new_count;

      $new_start >= 0
         or die "normalize_udiff: invalid new line $new_start\n";

      $line[$i] = sprintf "@@ -%d,%d +%d,%d @@%s",
         $old_start, $old_count, $new_start, $new_count, $suffix;

      $delta += $new_count - $old_count;
      ++$hunks;
      my $max_offset = keys %old_line;
      --$max_offset
         if $max_offset;
      push @max_offset, $max_offset;
      $i = $j - 1;
   }

   $hunks
      or die "normalize_udiff: no hunks\n";

   (join ("\n", @line, ""), \@max_offset)
}

sub parse_patch_output {
   my ($output) = @_;
   my (@hunks, @unparsed);

   for (split /\n/, $output) {
      if (/^Hunk #(\d+) (succeeded|FAILED|ignored) at (-?\d+)(?: with fuzz (\d+))?(?: \(offset (-?\d+) lines?\))?\.\z/) {
         push @hunks, {
            hunk    => 0 + $1,
            success => $2 eq "succeeded",
            line    => 0 + $3,
            fuzz    => 0 + $4,
            offset  => 0 + $5,
         };
      } elsif (!length
         || /^Hmm\.\.\. +Looks like a unified diff to me\.\.\.\z/
         || /^The text leading up to this was:\z/
         || /^-+\z/ || /^\|/
         || /^patching file / || /^checking file /
         || /^Using Plan [AB]\.\.\.\z/ || /^done\z/) {
         # GNU patch --verbose framing, not hunk results.
      } else {
         push @unparsed, $_;
      }
   }

   { hunks => \@hunks, unparsed => \@unparsed }
}

sub check_patch_output {
   my ($status, $output, $max_offset) = @_;
   my $parsed = parse_patch_output $output;
   my $hunks = $parsed->{hunks};

   die "patch failed (wait status $status):\n$output"
      if $status;
   die "patch: unrecognized output:\n" . (join "\n", @{$parsed->{unparsed}}) . "\n"
      if @{$parsed->{unparsed}};
   die "patch: expected " . @$max_offset . " hunks, got " . @$hunks . "\n"
      unless @$hunks == @$max_offset && @$hunks;

   for my $i (0 .. $#$hunks) {
      my $hunk = $hunks->[$i];

      die "patch: unexpected hunk number $hunk->{hunk}\n"
         unless $hunk->{hunk} == $i + 1;
      die "patch: hunk $hunk->{hunk} failed\n"
         unless $hunk->{success};
      die "patch: hunk $hunk->{hunk} used fuzz $hunk->{fuzz}\n"
         if $hunk->{fuzz};
      die "patch: hunk $hunk->{hunk} offset $hunk->{offset} exceeds $max_offset->[$i]\n"
         if abs $hunk->{offset} > $max_offset->[$i];
   }

   $hunks
}

sub apply_udiff {
   my ($input, $output, $diff) = @_;
   my ($normalized, $max_offset) = normalize_udiff $diff;

   require AnyEvent::Util;
   require File::Spec;
   require File::Basename;
   require Fcntl;

   $input  = File::Spec->rel2abs ($input);
   $output = File::Spec->rel2abs ($output);
   my $directory = File::Basename::dirname ($output);

   sysopen my $fh, $output, Fcntl::O_WRONLY () | Fcntl::O_CREAT () | Fcntl::O_EXCL (), 0600
      or die "$output: $!\n";
   close $fh or do { my $error = $!; unlink $output; die "$output: $error\n" };

   my $cv = AE::cv ();
   my $log;
   my $process = eval {
      AnyEvent::Util::run_cmd ([
         "patch", "--verbose", "--batch", "--forward", "--binary", "--fuzz=0",
         "--no-backup-if-mismatch", "--reject-file=-", "--output=$output", "--", $input,
      ],
         "<" => \$normalized,
         ">" => \$log,
         close_all => 1,
         on_prepare => sub {
            $ENV{LC_ALL} = "C";
            chdir $directory or die "$directory: $!\n";
            defined POSIX::dup2 (1, 2) or die "dup2: $!\n";
         },
      );
   };

   if ($@) {
      my $error = $@;
      unlink $output;
      die $error;
   }

   $process->cb (sub {
      my $hunks;
      eval { $hunks = check_patch_output $_[0]->recv, $log, $max_offset; 1 } or do {
         my $error = $@;
         unlink $output;
         $cv->croak ($error);
         return;
      };

      $cv->send ($hunks);
   });

   $cv
}

sub _clean_text($) {
   my ($text) = @_;

   my ($prefix) = (join "\n", grep /\S/, split /\n/, $text)
      =~ /\A([ \t]*)[^\n]*(?:\n\1[^\n]*)*\z/;

   $text =~ s/^\Q$prefix\E//mg;
   $text =~ s/\A\s+//;
   $text =~ s/\s+\z//;
   $text
}

package AnyEvent::MCP::Base;

sub new {
   my ($class, %kv) = @_;
   bless \%kv, $class
}

sub event {
   my ($self, $event, @args) = @_;
   ($self->{"on_$event"} or return)->($self, @args)
}

=head1 SEE ALSO

L<AnyEvent>, L<https://modelcontextprotocol.io/>

=head1 AUTHOR

The main author of this module is OpenAI ChatGPT.

Additional guidance received by:

   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/

=cut

1

Revision:	1.5
Committed:	Thu Oct 8 01:37:31 2026 UTC (5 weeks, 2 days ago) by root
Branch:	MAIN
Changes since 1.4:	+301 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::MCP - Model Context Protocol client/server support
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::MCP::Server::Simple;
8
9			mcp_tool ...
10	root	1.3	mcp_start;
11	root	1.1
12			or use the object interface directly:
13
14			use AnyEvent::MCP::Server;
15
16			my $server = AnyEvent::MCP::Server->new (...);
17
18			=head1 DESCRIPTION
19
20			AnyEvent::MCP provides event-driven Model Context Protocol client and server
21			support.
22
23			The usual way to implement a small MCP server is
24			L<AnyEvent::MCP::Server::Simple>, which provides a function-based interface and
25			creates the underlying server objects when a transport such as stdio or HTTP is
26			started.
27
28			The lower-level object interfaces are intended for applications that need to
29			manage MCP connections, servers or reusable tool registries directly.
30
31			=head2 MODULES
32
33			=over 4
34
35			=item L<AnyEvent::MCP::Server::Simple>
36
37			Function-based interface for implementing ordinary MCP servers.
38
39			=item L<AnyEvent::MCP::Server>
40
41			Object-oriented MCP server interface.
42
43			=item L<AnyEvent::MCP::Client>
44
45			Object-oriented MCP client interface.
46
47			=item L<AnyEvent::MCP::Server::Toolset>
48
49			Reusable registry of MCP tool declarations.
50
51			=item L<AnyEvent::MCP::Server::Permissions>
52
53			Permission and capability handling for MCP servers.
54
55			=back
56
57	root	1.4	C<mcp-multibroker> combines downstream HTTP and stdio servers under tool-name
58			prefixes. It uses the same client, server and permission helper facilities,
59			including modern input forwarding and local permission prompts for legacy
60			callers. Run C<mcp-multibroker --help> for command-line syntax; its manual
61			describes authentication and configuration.
62
63	root	1.1	The interfaces are still being designed; this documentation is intentionally
64			only an overview for now.
65
66	root	1.2	=head1 GLOBAL CONFIGURATION
67
68			The shared per-user configuration is C<$XDG_CONFIG_HOME/anyevent-mcp/global.ini>,
69			or C<$HOME/.config/anyevent-mcp/global.ini> when XDG_CONFIG_HOME is unset.
70			L<AnyEvent::MCP::Config> loads and holds it; loading this module does not access
71			configuration files.
72
73			The file is UTF-8 and uses sections with single-line C<key = value> pairs.
74			Values are unquoted strings. Blank lines and whole-line comments beginning
75			with C<#> or C<;> are ignored; inline comment characters remain part of the
76			value. Later occurrences of a key replace earlier ones in the same section.
77
78			[global]
79			secret = ...128 hexadecimal digits...
80
81			[server example]
82	root	1.3	port = 31740
83			url = https://example.net:31740/{cookie}/
84	root	1.2
85			[mcp-fs]
86			utility = /path/to/utility
87
88			Section names are unrestricted. Application-specific sections, including
89			exports, utility paths and user settings, are documented by their applications.
90
91			C<[global]> holds C<secret>, a 64-byte master key encoded as 128 hexadecimal
92			digits. The file must be owned by the current user, with no group or other
93			permissions. A missing secret is generated automatically on first configuration
94			access and saved when possible. Existing secrets are never replaced implicitly.
95			An invalid secret is an error.
96
97			If saving fails, Config warns and retains the secret in memory. Credentials
98			then remain stable only for that process; other processes cannot derive the
99			same credentials. If randomness is unavailable, supply a securely generated
100			secret in the file.
101
102			C<[server NAME]> holds named-server settings. Its C<url> is a complete template;
103			C<{cookie}> is replaced with the cookie derived for that server and optional
104			username. Scheme, host, port and cookie placement are explicit in the template.
105	root	1.3	HTTP servers with an explicit C<name> load C<host>, C<port>, C<path>,
106			C<url_host>, C<url_scheme>, C<cookie>, C<bearer> and C<users> from this section
107			as defaults. C<users> is a comma-separated allowlist whose Basic passwords
108			are derived for the named server. An explicit password hash can instead be
109			passed to the constructor. C<url> is a template for the utility program; it
110			does not set the listener's address.
111
112			C<mcp_start> chooses an application name and supplies cookie/bearer
113			authentication by default. Explicit authentication settings replace this
114			default. Stdio startup does not access global configuration.
115
116			C<[client NAME]> supplies HTTP client defaults: C<url>, C<bearer>, C<username>,
117			C<password> and C<timeout>. Clients consult it only when explicitly given a
118			C<name>. An unnamed client or HTTP server does not read global configuration.
119			Explicit constructor arguments take precedence over named defaults.
120
121			=head1 ENVIRONMENT
122
123			Project-specific environment variables use the C<PERL_ANYEVENT_MCP_> prefix.
124			C<PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL=stdio> selects stdio in Simple.
125			C<PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS> supplies the default application name.
126			C<PERL_ANYEVENT_MCP_PERMISSION_HELPER> selects the external asking executable.
127			Standard C<HOME> and C<XDG_CONFIG_HOME> keep their standard names.
128	root	1.2
129			=head1 FUNCTIONS
130
131			=head2 $bytes = AnyEvent::MCP::random_bytes $length
132
133			Returns exactly C<$length> random bytes. Tries C</dev/urandom>, then an external
134			C<openssl rand> command. No additional random-number module is required.
135			Dies if neither source supplies the requested bytes successfully.
136			C<$length> must be a nonnegative integer; zero returns an empty string.
137
138	root	1.5	=head2 ($diff, $max_offset) = AnyEvent::MCP::normalize_udiff $diff
139
140			Normalizes a relaxed, single-file unified diff into ordinary unified diff
141			syntax. Returns the normalized C<$diff> and an array reference C<$max_offset>
142			containing the permitted whole-hunk relocation for each hunk, in order.
143			Dies on malformed hunks or when no hunks are found.
144
145			=head3 Input format
146
147			In a hunk header, only the old start C<-N> matters. It is the old-file line
148			of the first hunk body line, including context, not necessarily the first
149			changed line. Counts and the new-file position are ignored and recomputed.
150			Both ordinary headers and the abbreviated form are accepted:
151
152			@@ -42,99 +123,99 @@
153			@@ -42 @@
154
155			Optional text after the closing C<@@> is preserved. File headers and other
156			text before the first hunk are preserved; a diff must describe one file.
157
158			Hunk body lines use the usual prefixes: a space for unchanged context,
159			C<-> for removed lines and C<+> for added lines. The
160			C<\ No newline at end of file> marker is preserved and counts neither side.
161			Trailing empty lines outside the final hunk are discarded.
162
163			Pure insertion is permitted only at the beginning, using old start zero.
164			An insertion elsewhere needs old-side context. Empty hunks are rejected.
165			New positions include the cumulative line-count changes of preceding hunks.
166
167			=head3 Applying the result
168
169			This function does not apply the patch, check file contents or guard against
170			concurrent edits. The caller must supply those checks.
171
172			Context must match exactly: apply with fuzz zero. For each hunk,
173			C<$max_offset> permits relocation by at most the number of distinct old-side
174			lines minus one, or zero for a pure insertion. Repeated old-side lines do
175			not increase this allowance. The applier must enforce these limits; an
176			unrestricted search for matching context can select the wrong occurrence.
177
178			For live Vim buffers, also require the expected changedtick to match.
179			File-based users need an equivalent check before replacing the file.
180
181			To work around GNU patch's handling of asymmetric context, the first context
182			line of each hunk is rewritten as an identity removal/addition. The line
183			contents and old/new line counts are unchanged. This is normalization for
184			the patch applier, not a relaxation of context matching.
185
186			=head2 $parsed = AnyEvent::MCP::parse_patch_output $output
187
188			Parses C<LC_ALL=C> GNU patch C<--verbose> output without judging whether
189			the application is acceptable. C<$parsed> has two fields:
190
191			=over 4
192
193			=item hunks => [$hunk...]
194
195			Hunk records in output order. Each record contains C<hunk> (the one-based
196			number), C<success>, C<line> (the reported application line), C<fuzz> and
197			the signed C<offset>. Omitted fuzz and offset are zero. Failed and ignored
198			hunks have false C<success>.
199
200			=item unparsed => [$line...]
201
202			Lines not recognized as hunk results or GNU patch's verbose framing.
203			The parser preserves them for callers to interpret or reject.
204
205			=back
206
207			Use verbose output: ordinary patch output omits exact-position successes,
208			so it cannot account for every hunk.
209
210			=head2 $hunks = AnyEvent::MCP::check_patch_output $status, $output, [$max_offset...]
211
212			Parses C<$output> and validates a complete application. C<$status> is the
213			raw process wait status, as returned by C<waitpid> or
214			C<AnyEvent::Util::run_cmd>, not just the exit code.
215
216			Requires status zero, no unrecognized output, exactly the expected hunks
217			in numbered order, successful application, fuzz zero and each signed offset
218			within its corresponding absolute limit. C<[$max_offset...]> is the array
219			reference returned by C<normalize_udiff>. At least one hunk is required.
220
221			Returns the parsed hunk array reference on success; otherwise dies with a
222			diagnostic. This is also suitable for callers running patch inside their
223			own sandbox.
224
225			=head2 $cv = AnyEvent::MCP::apply_udiff $input, $output, $diff
226
227			Asynchronously applies the relaxed C<$diff> to the input file C<$input>,
228			writing a separate output file C<$output>. C<$diff> must contain bytes;
229			callers working with characters must encode them for the file themselves.
230
231			Normalizes the diff, runs GNU patch using C<AnyEvent::Util::run_cmd>, and
232			validates its verbose output with C<check_patch_output>. The command uses
233			batch/forward mode, binary mode and fuzz zero. No shell is involved.
234
235			C<$output> must not exist. It is reserved with mode 0600; patch runs in its
236			directory so incidental temporary files stay there. Input and output paths
237			are made absolute before starting the command. These must be trusted paths
238			in a directory controlled by the caller.
239
240			Returns a condition variable. Its C<recv> returns the validated hunk array
241			reference, or throws on command/application failure. Setup failures throw
242			synchronously. Failed or partial output is removed. C<$input> is unchanged.
243
244			The caller owns committing the successful output and removing it when no
245			longer needed. Freshness checks, metadata preservation, atomic replacement
246			and application-specific permissions also belong to the caller.
247
248	root	1.1	=cut
249
250			package AnyEvent::MCP;
251
252			use common::sense;
253			use Digest::SHA ();
254
255			our $VERSION = '0.0';
256
257	root	1.2	sub random_bytes($) {
258			my ($length) = @_;
259
260			die "Invalid random byte count\n"
261			unless defined $length && $length =~ /\A[0-9]+\z/;
262			return "" unless $length;
263
264			my $bytes = "";
265
266			if (open my $fh, "<", "/dev/urandom") {
267			binmode $fh;
268			while (length $bytes < $length) {
269			read ($fh, $bytes, $length - length ($bytes), length $bytes)
270			or last;
271			}
272			close $fh;
273
274			return $bytes if length $bytes == $length;
275			}
276
277			if (open my $fh, "-\|", "openssl", "rand", $length) {
278			binmode $fh;
279			local $/;
280			$bytes = <$fh>;
281			my $success = close $fh;
282
283			return $bytes
284			if $success && defined $bytes && length $bytes == $length;
285			}
286
287			die "Cannot obtain $length random bytes from /dev/urandom or openssl rand\n";
288			}
289
290	root	1.1	sub hkdf_sha512_expand($$$) {
291			my ($prk, $info, $l) = @_;
292
293	root	1.2	64 == length $prk
294			or die "hkdf_sha512_expand: prk length mist be 64 octets";
295
296	root	1.1	my $t = "";
297			my $okm = "";
298			my $i = 0;
299
300			do {
301			$t = Digest::SHA::hmac_sha512 $t . $info . chr ++$i, $prk;
302			$okm .= $t;
303			} while $l > length $okm;
304
305			substr $okm, 0, $l
306			}
307
308	root	1.5	sub normalize_udiff {
309			my $diff = shift;
310			my @line = split /\n/, $diff, -1;
311			my $delta = 0;
312			my $hunks = 0;
313			my @max_offset;
314
315			pop @line while @line and !length $line[-1];
316
317			for (my $i = 0; $i < @line; ++$i) {
318			next unless $line[$i] =~ /^@@ /;
319
320			$line[$i] =~ /^@@ -(\d+)(?:,\d+)?(?: \+\d+(?:,\d+)?)? @@(.*)$/
321			or die "normalize_udiff: bad hunk header '$line[$i]'\n";
322
323			my ($old_start, $suffix) = ($1, $2);
324			my ($old_count, $new_count) = (0, 0);
325			my %old_line;
326			my $j = $i + 1;
327
328			# GNU patch mishandles hunks with more prefix than suffix context.
329			# Make the first context line an identity change without losing it.
330			# see https://unix.stackexchange.com/questions/414542/does-patch-work-with-asymmetric-context
331			splice @line, $i + 1, 1, "-$1", "+$1"
332			if $line[$i + 1] =~ /^ (.*)\z/;
333
334			for (; $j < @line; ++$j) {
335			last if $line[$j] =~ /^@@ /;
336
337			my $tag = substr $line[$j], 0, 1;
338
339			if ($tag eq " ") {
340			++$old_count;
341			++$new_count;
342			$old_line{substr $line[$j], 1} = 1;
343			} elsif ($tag eq "-") {
344			++$old_count;
345			$old_line{substr $line[$j], 1} = 1;
346			} elsif ($tag eq "+") {
347			++$new_count;
348			} elsif ($line[$j] eq "\\ No newline at end of file") {
349			# Marker belongs to the preceding body line and counts neither side.
350			} else {
351			die "normalize_udiff: bad hunk line '$line[$j]'\n";
352			}
353			}
354
355			$old_count or $new_count
356			or die "normalize_udiff: empty hunk at old line $old_start\n";
357
358			$old_count or !$old_start
359			or die "normalize_udiff: hunk " . ($hunks + 1)
360			. " needs old-side context for insertion after old line $old_start\n";
361
362			my $new_start = $old_start + $delta;
363			++$new_start unless $old_count;
364			--$new_start unless $new_count;
365
366			$new_start >= 0
367			or die "normalize_udiff: invalid new line $new_start\n";
368
369			$line[$i] = sprintf "@@ -%d,%d +%d,%d @@%s",
370			$old_start, $old_count, $new_start, $new_count, $suffix;
371
372			$delta += $new_count - $old_count;
373			++$hunks;
374			my $max_offset = keys %old_line;
375			--$max_offset
376			if $max_offset;
377			push @max_offset, $max_offset;
378			$i = $j - 1;
379			}
380
381			$hunks
382			or die "normalize_udiff: no hunks\n";
383
384			(join ("\n", @line, ""), \@max_offset)
385			}
386
387			sub parse_patch_output {
388			my ($output) = @_;
389			my (@hunks, @unparsed);
390
391			for (split /\n/, $output) {
392			if (/^Hunk #(\d+) (succeeded\|FAILED\|ignored) at (-?\d+)(?: with fuzz (\d+))?(?: \(offset (-?\d+) lines?\))?\.\z/) {
393			push @hunks, {
394			hunk => 0 + $1,
395			success => $2 eq "succeeded",
396			line => 0 + $3,
397			fuzz => 0 + $4,
398			offset => 0 + $5,
399			};
400			} elsif (!length
401			\|\| /^Hmm\.\.\. +Looks like a unified diff to me\.\.\.\z/
402			\|\| /^The text leading up to this was:\z/
403			\|\| /^-+\z/ \|\| /^\\|/
404			\|\| /^patching file / \|\| /^checking file /
405			\|\| /^Using Plan [AB]\.\.\.\z/ \|\| /^done\z/) {
406			# GNU patch --verbose framing, not hunk results.
407			} else {
408			push @unparsed, $_;
409			}
410			}
411
412			{ hunks => \@hunks, unparsed => \@unparsed }
413			}
414
415			sub check_patch_output {
416			my ($status, $output, $max_offset) = @_;
417			my $parsed = parse_patch_output $output;
418			my $hunks = $parsed->{hunks};
419
420			die "patch failed (wait status $status):\n$output"
421			if $status;
422			die "patch: unrecognized output:\n" . (join "\n", @{$parsed->{unparsed}}) . "\n"
423			if @{$parsed->{unparsed}};
424			die "patch: expected " . @$max_offset . " hunks, got " . @$hunks . "\n"
425			unless @$hunks == @$max_offset && @$hunks;
426
427			for my $i (0 .. $#$hunks) {
428			my $hunk = $hunks->[$i];
429
430			die "patch: unexpected hunk number $hunk->{hunk}\n"
431			unless $hunk->{hunk} == $i + 1;
432			die "patch: hunk $hunk->{hunk} failed\n"
433			unless $hunk->{success};
434			die "patch: hunk $hunk->{hunk} used fuzz $hunk->{fuzz}\n"
435			if $hunk->{fuzz};
436			die "patch: hunk $hunk->{hunk} offset $hunk->{offset} exceeds $max_offset->[$i]\n"
437			if abs $hunk->{offset} > $max_offset->[$i];
438			}
439
440			$hunks
441			}
442
443			sub apply_udiff {
444			my ($input, $output, $diff) = @_;
445			my ($normalized, $max_offset) = normalize_udiff $diff;
446
447			require AnyEvent::Util;
448			require File::Spec;
449			require File::Basename;
450			require Fcntl;
451
452			$input = File::Spec->rel2abs ($input);
453			$output = File::Spec->rel2abs ($output);
454			my $directory = File::Basename::dirname ($output);
455
456			sysopen my $fh, $output, Fcntl::O_WRONLY () \| Fcntl::O_CREAT () \| Fcntl::O_EXCL (), 0600
457			or die "$output: $!\n";
458			close $fh or do { my $error = $!; unlink $output; die "$output: $error\n" };
459
460			my $cv = AE::cv ();
461			my $log;
462			my $process = eval {
463			AnyEvent::Util::run_cmd ([
464			"patch", "--verbose", "--batch", "--forward", "--binary", "--fuzz=0",
465			"--no-backup-if-mismatch", "--reject-file=-", "--output=$output", "--", $input,
466			],
467			"<" => \$normalized,
468			">" => \$log,
469			close_all => 1,
470			on_prepare => sub {
471			$ENV{LC_ALL} = "C";
472			chdir $directory or die "$directory: $!\n";
473			defined POSIX::dup2 (1, 2) or die "dup2: $!\n";
474			},
475			);
476			};
477
478			if ($@) {
479			my $error = $@;
480			unlink $output;
481			die $error;
482			}
483
484			$process->cb (sub {
485			my $hunks;
486			eval { $hunks = check_patch_output $_[0]->recv, $log, $max_offset; 1 } or do {
487			my $error = $@;
488			unlink $output;
489			$cv->croak ($error);
490			return;
491			};
492
493			$cv->send ($hunks);
494			});
495
496			$cv
497			}
498
499	root	1.1	sub _clean_text($) {
500			my ($text) = @_;
501
502			my ($prefix) = (join "\n", grep /\S/, split /\n/, $text)
503			=~ /\A([ \t])[^\n](?:\n\1[^\n])\z/;
504
505			$text =~ s/^\Q$prefix\E//mg;
506			$text =~ s/\A\s+//;
507			$text =~ s/\s+\z//;
508			$text
509			}
510
511			package AnyEvent::MCP::Base;
512
513			sub new {
514			my ($class, %kv) = @_;
515			bless \%kv, $class
516			}
517
518			sub event {
519			my ($self, $event, @args) = @_;
520			($self->{"on_$event"} or return)->($self, @args)
521			}
522
523			=head1 SEE ALSO
524
525			L<AnyEvent>, L<https://modelcontextprotocol.io/>
526
527			=head1 AUTHOR
528
529			The main author of this module is OpenAI ChatGPT.
530
531			Additional guidance received by:
532
533			Marc Lehmann <schmorp@schmorp.de>
534			http://home.schmorp.de/
535
536			=cut
537
538			1
539