[ViewVC] Annotation of: cvs/cvsroot/AnyEvent-MCP/bin/mcp-fs

#!/opt/bin/perl

=head1 NAME

mcp-fs - sandboxed filesystem and command tools

=head1 SYNOPSIS

   mcp-fs --stdio /path/to/workdir
   mcp-fs --name project --port 31741 /path/to/workdir

=head1 DESCRIPTION

Uses L<AnyEvent::MCP::Server::Simple> to expose filesystem tools and arbitrary
commands through bubblewrap. GNU find, grep, patch and sed and a compatible
Perl are detected at startup; tools requiring an unavailable utility are
omitted. Bubblewrap is required.

HTTP is the default and prints a cookie URL. The same token can be used as
a bearer token at the clean URL. C<--stdio> or
C<PERL_ANYEVENT_MCP_MULTIBROKER_PROTOCOL=stdio> selects stdin/stdout.
See L<AnyEvent::MCP/GLOBAL CONFIGURATION> for named HTTP settings.

=head1 OPTIONS

=over

=item --name NAME

Selects named server configuration and authentication. Defaults to
C<PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS>, then C<mcp-fs>.

=item --stdio

Uses stdin/stdout instead of starting an HTTP listener.

=item --host ADDRESS

Overrides the HTTP listener address.

=item --port PORT

Overrides the HTTP listener port; zero selects an available port.

=item --profile NAME

Selects the permission rule file
C<$XDG_CONFIG_HOME/anyevent-mcp/NAME.ini>, or
C<$HOME/.config/anyevent-mcp/NAME.ini>. Defaults to
C<PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS>, then C<default>.
This retains the original mcp-fs filenames and allowance rules.
The rules path is printed on stderr when starting HTTP, alongside the URL
on stdout.

=item --bwrap PATH

Selects the bubblewrap executable. Defaults to C<bwrap> in C<PATH>.

=item --runtime-path PATH

Adds a baseline runtime mount. Repeating this option replaces the default
runtime paths. These paths supply executables and libraries inside the
sandbox, independently of requested filesystem capabilities.

=item --host-export PATH

Adds a path exposed by the C<system-read> capability. Can be repeated.

=back

=head1 PERMISSIONS

L<AnyEvent::MCP::Server::Permissions> applies ordered allow, deny and ask
rules. Each tool checks permissions before starting its worker. Modern
clients advertising form elicitation can answer an input challenge; other
clients use the external helper selected by
C<PERL_ANYEVENT_MCP_PERMISSION_HELPER>.

You can edit the rule file at any time. It is reread on permission checks,
so changes apply without restarting the server. Keep it owned by your user
and private (mode 0600). See L<AnyEvent::MCP::Server::Permissions> for the
rule syntax and ordering.

Permission retries retain earlier one-time approvals within the same call.
For one worker accessing several paths, every path is checked against the
capabilities needed by that worker. Its sandbox uses the intersection of
the granted capability closures. An insufficient reduction fails before
the worker starts.

The C<host-proc> capability remains unavailable. Runtime mounts and a
read-only copy of C<AnyEvent/MCP.pm> provide sandbox machinery. Symlinks
resolve within the sandbox's granted mounts.

=head1 PATCHES

C<file-patch> uses L<AnyEvent::MCP/PATCH UTILITIES> for normalization and
validation. GNU patch runs inside the granted sandbox with fuzz zero.
Successful output replaces the original by rename after checking its
identity, size, timestamps, metadata and link count. These stat checks
do not detect every concurrent edit; they are not a filesystem transaction.

=cut
use common::sense;

use MIME::Base64 ();
use Getopt::Long ();
use Cwd ();
use POSIX ();

use JSON::XS ();
use AnyEvent ();
use AnyEvent::MCP::Server::Permissions ();
use AnyEvent::Handle ();
use AnyEvent::Log ();
use AnyEvent::Util ();

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

sub utf8enc($) {
   my $text = shift;
   utf8::encode $text;
   $text
}

sub utf8dec($) {
   my $bytes = shift;
   utf8::decode $bytes
      or die "invalid UTF-8\n";
   $bytes
}

# Resolve an executable name or path to an absolute executable file.
sub find_executable {
   my ($name) = @_;
   !ref $name and length $name and $name !~ /\0/
      or return;

   my @path = $name =~ m{/}
      ? ($name)
      : map { (length $_ ? $_ : ".") . "/$name" } split /:/, $ENV{PATH};

   for my $path (@path) {
      next unless -f $path and -x _;
      my $absolute = Cwd::abs_path $path;
      return $absolute if length $absolute;
   }

   undef
}

my %program_test = (
   find => [[qw(--version)], qr/^find \(GNU findutils\)/m],
   grep => [[qw(--version)], qr/^grep \(GNU grep\)/m],
   patch => [[qw(--version)], qr/^GNU patch /m],
   perl => [["-e", "use 5.008004"], qr/\A\z/],
   sed => [["-n", "1p", "/dev/null"], qr/\A\z/],
);

my %program;
for my $name (sort keys %program_test) {
   my ($args, $match) = @{$program_test{$name}};
   my $path = find_executable $name;
   my $output = "";
   my $ok;

   if ($path and open my $fh, "-|", $path, @$args) {
      local $/;
      $output = <$fh>;
      $ok = close $fh;
   }

   $program{$name} = $path
      if $ok and $output =~ $match;
   warn "$name: not detected or wrong version\n"
      unless $program{$name};
}

my ($find, $grep, $patch, $perl, $sed) = @program{qw(find grep patch perl sed)};

Getopt::Long::Configure qw(bundling no_ignore_case require_order);

my ($name, $profile, $stdio, $host, $port, $help);
my $bwrap = "bwrap";
my (@runtime_path, @host_export);
my $usage = "usage: $0 [--name NAME] [--stdio] [--host ADDRESS] [--port PORT] [--profile NAME] [--bwrap PATH] [--runtime-path PATH ...] [--host-export PATH ...] WORKDIR [WORKDIR ...]\n";

Getopt::Long::GetOptions
   "name=s"          => \$name,
   "stdio"           => \$stdio,
   "host=s"          => \$host,
   "port=i"          => \$port,
   "profile=s"       => \$profile,
   "help|h"          => \$help,
   "bwrap=s"         => \$bwrap,
   "runtime-path=s@" => \@runtime_path,
   "host-export=s@"  => \@host_export,
or die $usage;

if ($help) {
   print $usage;
   exit;
}

$name //= $ENV{PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS} // "mcp-fs";
$profile //= $ENV{PERL_ANYEVENT_MCP_MULTIBROKER_ALIAS} // "default";
$profile =~ /\A[A-Za-z0-9][A-Za-z0-9_.-]*\z/ and @ARGV
   or die $usage;

$bwrap = find_executable $bwrap
   // die "bubblewrap executable not found: $bwrap\n";

@runtime_path = grep -e, qw(/usr /bin /sbin /lib /lib64 /opt /etc/ld.so.cache)
   unless @runtime_path;
for my $path (@runtime_path) {
   $path =~ m{\A/} and -e $path or die "invalid runtime path '$path'\n";
}
for my $path (@host_export) {
   $path =~ m{\A/} and -e $path or die "invalid host export '$path'\n";
}

my @workdir;
for my $path (@ARGV) {
   my $workdir = Cwd::abs_path $path;
   -d $workdir or die "invalid workdir '$path'\n";
   utf8::decode $workdir
      or die "workdir is not UTF-8\n";
   push @workdir, $workdir;
}

my $home = $ENV{HOME};
$home =~ m{\A/} and -d $home
   or die "HOME must name an absolute existing directory\n";
$home = Cwd::abs_path $home
   // die "cannot resolve HOME\n";
utf8::decode $home
   or die "HOME is not a valid UTF-8 path\n";

my $config_home = $ENV{XDG_CONFIG_HOME};
if (length $config_home) {
   $config_home =~ m{\A/}
      or die "permission config directory must be absolute\n";
   utf8::decode $config_home
      or die "permission config directory is not UTF-8\n";
} else {
   $config_home = "$home/.config";
}

my %capability = (
   "workdir-read"  => [],
   "workdir-write" => ["workdir-read"],
   "system-read"   => [],
   "home-read"     => [],
   "home-write"    => ["home-read"],
   "world-read"    => [qw(workdir-read system-read home-read)],
   "world-write"   => [qw(world-read workdir-write home-write)],
   "network"       => [],
   "shared-tmp"    => [],
   "host-proc"     => [],
);

my @exec_default_capabilities = ("workdir-read");

my $umask = umask;

# Keep the existing profile filename so saved rules survive the migration.
my $permissions = AnyEvent::MCP::Server::Permissions->new (
   capabilities => \%capability,
   name         => $profile,
   file         => "$config_home/anyevent-mcp/$profile.ini",
);

# The patch worker loads the shared validator inside its sandbox.
my $mcp_module = Cwd::abs_path $INC{"AnyEvent/MCP.pm"}
   or die "cannot resolve AnyEvent::MCP runtime path\n";

# Normalize an API pathname lexically against its selected workdir.
sub fs_path {
   my ($workdir, $path) = @_;

   !ref $path and length $path and $path !~ /\0/
      or die "path must be a nonempty string without NUL\n";
   $path = "$workdir/$path" unless $path =~ m{\A/};

   my @part;

   for (split m{/+}, $path) {
      next if !length or $_ eq ".";
      if ($_ eq "..") {
         pop @part;
      } else {
         push @part, $_;
      }
   }

   "/" . join "/", @part
}

# Test pathname containment without resolving symlinks.
sub fs_inside {
   my ($path, $directory) = @_;

   $directory eq "/" or $path eq $directory or (index $path, "$directory/") == 0
}

# Map a pathname and access mode to the narrowest filesystem capability.
sub fs_path_capability {
   my ($path, $mode) = @_;

   return "workdir-$mode"
      if grep { fs_inside $path, $_ } @workdir;
   return "home-$mode" if fs_inside $path, $home;
   return "shared-tmp" if (fs_inside $path, "/tmp") or (fs_inside $path, "/var/tmp");

   "world-$mode"
}

# Offer persistent permission scopes for one concrete pathname.
sub fs_subjects {
   my ($workdir, $path) = @_;

   my $directory = $path =~ s{/[^/]*\z}{}r || "/";
   my $prefix = $directory eq "/" ? "/" : "$directory/";
   my $quote = sub {
      my $text = quotemeta $_[0];
      $text =~ s/\\(\s)/sprintf "\\x{%x}", ord $1/ge;
      $text
   };
   my $exact = $path =~ /[\r\n]|\s\z/ ? "^" . $quote->($path) . "\\z" : $path;
   my @choices = (
      { label => "exact path", subject => $exact },
      { label => "containing directory", subject => "^" . $quote->($prefix) . "[^/]*\\z" },
      { label => "directory tree", subject => "^" . $quote->($prefix) },
   );

   push @choices, { label => "workdir", subject => "^" . $quote->($workdir) . ($workdir eq "/" ? "" : "(?:/|\\z)") }
      if (fs_inside $path, $workdir);

   push @choices, { label => "all paths", subject => "^/" };

   \@choices
}

# One worker needs authority allowed for every path it will access.
sub fs_require_paths {
   my ($req, $workdir, $paths, $mode, $reason) = @_;

   my %need = map { (fs_path_capability $_, $mode) => 1 } @$paths;
   my ($have, %seen);

   for my $path (@$paths) {
      next if $seen{$path}++;
      my $grant = $req->require_permission ({
         tool         => $req->{tool},
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [sort keys %need],
         reason       => $reason // "$req->{tool} $path",
      });

      my $allowed = $permissions->closure ($grant);
      if ($have) {
         delete @$have{grep !$allowed->{$_}, keys %$have};
      } else {
         $have = $allowed;
      }
   }

   for my $capability (sort keys %need) {
      $have->{$capability}
         or die "permission reduced below $capability for $req->{tool}\n";
   }

   [sort keys %$have]
}

# Test whether the granted capability set makes this pathname writable.
sub fs_writable {
   my ($path, $have) = @_;

   $have->{"world-write"}
      or ($have->{"workdir-write"} and (grep { fs_inside $path, $_ } @workdir))
      or ($have->{"home-write"} and (fs_inside $path, $home))
      or ($have->{"shared-tmp"} and ((fs_inside $path, "/tmp") or (fs_inside $path, "/var/tmp")))
}

# Build the bubblewrap argv implementing the granted sandbox authority.
sub fs_sandbox {
   my ($workdir, $capabilities) = @_;
   my $have = $permissions->closure ($capabilities);
   die "host-proc sandbox authority is unresolved and unavailable in v1\n"
      if $have->{"host-proc"};

   my @command = ($bwrap, qw(
      --die-with-parent --new-session
      --unshare-user --unshare-pid --unshare-ipc --unshare-uts
      --unshare-cgroup-try --disable-userns --cap-drop ALL
   ));

   push @command, "--unshare-net" unless $have->{network};

   push @command, $have->{"world-write"} ? "--bind-try" : "--ro-bind-try", "/", "/"
      if $have->{"world-read"};

   my @scope_mount;

   for my $path (@runtime_path) {
      my $mount = (fs_writable $path, $have) ? "--bind-try" : "--ro-bind-try";
      push @scope_mount, $mount, $path, $path;
   }

   if ($have->{"system-read"}) {
      for my $path (@host_export) {
         my $mount = (fs_writable $path, $have) ? "--bind-try" : "--ro-bind-try";
         push @scope_mount, $mount, $path, $path;
      }
   }

   if ($have->{"home-read"}
       and (!$have->{"world-read"} or ($have->{"home-write"} and !$have->{"world-write"}))) {
      my $mount = (fs_writable $home, $have) ? "--bind-try" : "--ro-bind-try";
      push @scope_mount, $mount, $home, $home;
   }

   if ($have->{"workdir-read"}) {
      for my $path (@workdir) {
         next
            if $have->{"world-read"}
               and (!$have->{"workdir-write"} or $have->{"world-write"});
         next
            if fs_inside $path, $home
               and $have->{"home-read"}
               and (!$have->{"workdir-write"} or $have->{"home-write"});
         my $mount = (fs_writable $path, $have) ? "--bind-try" : "--ro-bind-try";
         push @scope_mount, $mount, $path, $path;
      }
   }

   # Replace special host mounts even when broad filesystem authority was asked.
   push @command, qw(--tmpfs /sys --tmpfs /run --dev /dev);
   push @command, "--proc", "/proc";

   for my $tmp (qw(/tmp /var/tmp)) {
      if ($have->{"shared-tmp"}) {
         push @command, "--bind-try", $tmp, $tmp;
      } else {
         push @command, "--tmpfs", $tmp;
      }
   }

   # Explicit mounts override the private baseline where bwrap/kernel permit it.
   push @command, @scope_mount;
   push @command, "--ro-bind", $mcp_module, "/run/anyevent-mcp.pm";

   for my $path (qw(/etc/resolv.conf /etc/hosts)) {
      my $mount = (fs_writable $path, $have) ? "--bind-try" : "--ro-bind-try";
      push @command, $mount, $path, $path;
   }

   push @command, "--remount-ro", "/"
      unless $have->{"world-write"};

   my $sandbox_path = $ENV{PATH} // "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";

   push @command,
      "--clearenv",
      "--setenv", "PATH", $sandbox_path,
      "--setenv", "LC_ALL", "C.UTF-8",
      "--setenv", "HOME", $home,
      "--chdir", $have->{"workdir-read"} ? $workdir : "/tmp",
      "--";

   @command
}

AnyEvent::detect; # proc_spawn creates child watchers after they might have died

# Spawn one process with a bidirectional stdin/stdout handle and separate stderr.
sub proc_spawn {
   my ($program, @argv) = @_;

   my ($parent, $child) = AnyEvent::Util::portable_socketpair
      or die "socketpair: $!\n";
   my ($error, $child_error) = AnyEvent::Util::portable_pipe
      or die "pipe: $!\n";

   my $pid = fork;
   defined $pid or die "fork: $!\n";

   unless ($pid) {
      open STDIN,  "<&", $child       or POSIX::_exit 126;
      open STDOUT, ">&", $child       or POSIX::_exit 126;
      open STDERR, ">&", $child_error or POSIX::_exit 126;

      close $parent;
      close $error;
      close $child;
      close $child_error;

      AnyEvent::Util::close_all_fds_except 0, 1, 2;

      exec {$program} $program, @argv;
      print STDERR "exec $program: $!\n";
      POSIX::_exit 126;
   }

   close $child;
   close $child_error;

   my $io  = AnyEvent::Handle->new (fh => $parent);
   my $err = AnyEvent::Handle->new (fh => $error);
   my $proc = { pid => $pid, done => [] };

   # Keep the watcher alive independently so a fatal I/O error still reaps.
   $proc->{child} = AE::child $pid, sub {
      my $status = $_[1];

      $proc->{status} = $status;
      delete $proc->{pid};
      delete $proc->{child};
      $_->($status) for @{delete $proc->{done}};
   };

   ($io, $err, $proc)
}

# Wrap proc_spawn in one self-owned AnyEvent::Handle. destroy releases all
# attached process state, including the self-reference that keeps it alive.
sub proc_handle {
   my (@command) = @_;

   my ($io, $err, $proc) = proc_spawn @command;

   $io->{proc}      = $proc;
   $io->{proc_err}  = $err;
   $io->{proc_self} = $io;

   $io
}

# Signal a spawned process while its pid is still owned by us.
sub proc_kill {
   my ($proc, $signal) = @_;

   my $pid = $proc->{pid} or return;

   $signal //= "KILL";
   kill $signal => $pid
}

# Run a callback once a spawned process has been reaped.
sub proc_on_exit {
   my ($proc, $done) = @_;

   return $done->($proc->{status})
      if defined $proc->{status};

   push @{$proc->{done}}, $done;
}

# Run one subprocess with bounded capture, timeout and sandbox teardown.
sub fs_run {
   my ($req, $command, $input, $timeout, $byte_limit, $line_limit, $done) = @_;

   my ($truncated, $line_truncated, $timed_out);
   my ($stdout, $stderr) = ("", "");

   my $capture = sub {
      my ($target, $data, $lines) = @_;
      return if $lines and $line_truncated;
      return unless length $data;
      my $remaining = $byte_limit - (length $stdout) - (length $stderr);
      $truncated = 1 if length $data > $remaining;
      $$target .= substr $data, 0, $remaining
         if $remaining > 0;

      if ($lines and $line_limit and ($$target =~ tr/\n//) > $line_limit) {
         my $end = -1;
         $end = index $$target, "\n", $end + 1
            for 1 .. $line_limit;
         substr $$target, $end + 1, length $$target, "";
         $truncated = $line_truncated = 1;
         return 1
      }

      0
   };

   my $io = proc_handle @$command;
   my $err = $io->{proc_err};
   my $proc = $io->{proc};
   $req->{on_cancel} = sub { proc_kill $proc };
   my $open = 2;
   my ($status, $finished, $timer);

   my $complete = sub {
      return
         if $finished or $open or !defined $status;
      $finished = 1;
      undef $timer;
      $io->destroy;
      return if $req->{finished};
      delete $req->{on_cancel};

      $done->(1, +{
         stdout    => $stdout,
         stderr    => $stderr,
         exit      => $status >> 8,
         signal    => $status & 127,
         timed_out => $timed_out ? JSON::XS::true : JSON::XS::false,
         truncated => $truncated ? JSON::XS::true : JSON::XS::false,
      });
   };

   for my $stream ([$io, \$stdout, 1], [$err, \$stderr, 0]) {
      my ($handle, $target, $lines) = @$stream;
      my $stream_done;
      my $finish = sub {
         return if $stream_done++;
         --$open;
         $complete->();
      };

      $handle->on_read (sub {
         proc_kill $proc
            if $capture->($target, $_[0]{rbuf}, $lines);
         $_[0]{rbuf} = "";
      });
      $handle->on_eof (sub {
         $finish->();
      });
      $handle->on_error (sub {
         return unless $_[1];
         proc_kill $proc;
         $capture->($target, $_[0]{rbuf}, $lines);
         $_[0]{rbuf} = "";
         $finish->();
      });
   }

   my $ok = eval {
      $io->push_write ($input) if length $input;
      $io->push_shutdown;
      1
   };
   unless ($ok) {
      proc_kill $proc;
      $io->destroy;
      die $@;
   }

   $timer = AE::timer $timeout, 0, sub {
      $timed_out = 1;
      proc_kill $proc;
   };

   proc_on_exit $proc, sub {
      $status = $_[0];
      $complete->();
   };
}

my $perl_slave = q{#perl
   binmode STDIN;
   binmode STDOUT;
   $SIG{PIPE} = "IGNORE";
   $| = 1;

   for (;;) {
      4 == read STDIN, my $buf, 4
         or last;
      my $len = unpack "N", $buf;
      $len == read STDIN, $buf, $len
         or die "short perl frame\n";

      my @result = do {
         (my $source, local @ARGV) = unpack "(w/a*)*", $buf;
         ("+", eval $source)
      };

      @result = ("-", $@)
         if $@;

      print pack "N/a*", pack "(w/a*)*", @result
         or die "stdout: $!\n"
   }
};

sub perl_frame {
   pack "N/a*", pack "(w/a*)*", @_
}

sub perl_unframe {
   my ($data) = @_;
   length $data >= 4
      or die "short perl response\n";
   my $len = unpack "N", $data;
   length $data == 4 + $len
      or die "invalid perl response length\n";

   unpack "x4 (w/a*)*", $data
}

sub perl_eval {
   my ($req, $workdir, $capabilities, $source, $args, $timeout, $limit, $done) = @_;
   my @command = ((fs_sandbox $workdir, $capabilities), $perl, "-e", $perl_slave);

   fs_run $req, \@command, (perl_frame $source, @$args), $timeout, $limit, 0, sub {
      my ($success, $result) = @_;
      return $done->(0, $result)
         unless $success;

      my (@response, $error);
      my $ok = eval {
         die "sandbox perl timed out\n" if $result->{timed_out};
         die "sandbox perl output exceeded limit\n" if $result->{truncated};
         if ($result->{exit} or $result->{signal}) {
            my $stderr = utf8dec $result->{stderr};
            die "sandbox perl failed (exit $result->{exit}, signal $result->{signal}): $stderr\n";
         }

         @response = perl_unframe $result->{stdout};
         my $status = shift @response;
         defined $status or die "missing perl response status\n";
         if ($status eq "-") {
            $error = utf8dec $response[0];
         } elsif ($status ne "+") {
            die "invalid perl response status\n";
         }
         1
      };

      return $done->(0, $@) unless $ok;
      return $done->(0, $error) if defined $error;
      $done->(1, \@response);
   };
}

# Resolve the optional workdir index to one configured workdir.
sub fs_workdir {
   my ($i) = @_;

   $i = 0 if !defined $i and @workdir == 1;

   !ref $i and $i =~ /\A[0-9]+\z/ and $i < @workdir
      or die "select a configured workdir by its zero-based index\n";

   $workdir[$i]
}

# Wrap raw text as an MCP text result.
sub fs_text_result {
   my ($text, $failed) = @_;

   my $response = {
      content => [{
         type => "text",
         text => $text,
      }],
   };

   $response->{isError} = JSON::XS::true if $failed;

   $response
}

# Wrap a Perl value as an MCP text result.
sub fs_result {
   my ($result, $failed) = @_;
   my $text = JSON::XS->new->encode ($result);
   my $response = fs_text_result $text, $failed;
   $response->{structuredContent} = $result;
   $response
}

mcp_tool workdirs =>
   "List configured workdirs and capability/runtime configuration.",
   {
      type                 => "object",
      properties           => {},
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      AE::log debug => "workdirs";

      $req->reply (fs_result +{
         workdirs                  => \@workdir,
         umask                     => sprintf ("%04o", $umask),
         runtime_paths             => \@runtime_path,
         host_exports              => \@host_export,
         capabilities              => \%capability,
         exec_default_capabilities => \@exec_default_capabilities,
         unavailable_capabilities  => ["host-proc"],
      });
   }
;

# Escape a pathname for compact line-oriented text output.
sub escape_path {
   my ($text) = @_;

   $text =~ s/\\/\\\\/g;
   $text =~ s/\n/\\n/g;
   $text
}

sub format_iec_number {
   my ($number) = @_;
   my @suffix = ("", qw(k M G T P));

   for my $suffix (@suffix) {
      return "$number$suffix" if $number < 1024 or $suffix eq "P";
      $number = int (($number + 512) / 1024);
   }
}

sub fs_find_relative {
   my ($base, $path) = @_;

   return "" if $path eq $base;
   substr $path, length ($base) + ($base eq "/" ? 0 : 1)
}

sub format_path_listing {
   my ($base, $record, $truncated) = @_;
   my (@line, $directory);

   for my $record (sort { $a->[2] cmp $b->[2] } @$record) {
      my ($type, $size, $full_path) = @$record;
      my $relative = fs_find_relative $base, $full_path;

      if ($type eq "d") {
         push @line, "/" . (escape_path $relative);
         $directory = $relative;
         next;
      }

      my ($dir, $name);

      if (!length $relative) {
         $name = $full_path =~ s{.*/}{}r;
      } else {
         ($dir, $name) = $relative =~ m{\A(?:(.*)/)?([^/]*)\z};
         $dir //= "";

         if (!defined $directory or $directory ne $dir) {
            push @line, "/" . (escape_path $dir);
            $directory = $dir;
         }
      }

      $name = escape_path $name;
      push @line, $type eq "f"
         ? (join "\t", $type, (format_iec_number $size), $name)
         : (join "\t", $type, $name);
   }

   push @line, "!truncated" if $truncated;

   my $text = join "\n", @line;
   $text .= "\n" if @line;
   $text
}

sub fs_list_find {
   my ($req, $args, $recurse) = @_;
   my $tool = $recurse ? "find" : "list";

   my $workdir = fs_workdir $args->{workdir};
   my $path = fs_path $workdir, $args->{path} // ".";
   my $limit = $args->{limit} // 200;
   $limit <= 1000
      or die "invalid limit\n";

   my $capability = fs_path_capability $path, "read";

   my $granted = $req->require_permission ({
      tool         => $tool,
      subject      => $path,
      subjects     => (fs_subjects $workdir, $path),
      capabilities => [$capability],
      reason       => $args->{reason} // "$tool $path",
   });

   if ($recurse) {
      AE::log debug => join " ", $tool, $path, (substr $args->{name}, 0, 40);
   } else {
      AE::log debug => "$tool $path";
   }

   my $find_path = utf8enc $path;
   my @command = ((fs_sandbox $workdir, $granted), $find, $find_path);

   if ($recurse) {
      my $needle = utf8enc $args->{name};
      $needle =~ s/([\\*?\[])/\\$1/g;
      push @command, "!", "-type", "d", "-name", "*$needle*";
   } else {
      push @command, "-maxdepth", "1";
   }

   push @command, "-printf", q{%y\0%s\0%p\0};

   my (@record, $seen, $truncated, $timed_out, $failure);
   my $stderr = "";
   my $io = proc_handle @command;
   my $err = $io->{proc_err};
   my $proc = $io->{proc};
   $req->{on_cancel} = sub { proc_kill $proc };
   my $open = 2;
   my ($stdout_done, $stderr_done, $status, $finished, $timer);

   my $complete = sub {
      return
         if $finished or $open or !defined $status;
      $finished = 1;
      undef $timer;
      $io->destroy;
      return if $req->{finished};
      delete $req->{on_cancel};

      my $result;
      my $ok = eval {
         die "$tool timed out\n" if $timed_out;
         die $failure if $failure;

         if (($status >> 8 or $status & 127) and !$truncated) {
            my $error = eval { utf8dec $stderr };
            $error = "non-UTF-8 error output" if $@;
            die "$tool failed (exit " . ($status >> 8) . ", signal " . ($status & 127) . "): $error\n";
         }

         $result = fs_text_result (format_path_listing $path, \@record, $truncated);
         1
      };

      if ($ok) {
         $req->reply ($result);
      } else {
         $req->error ($@);
      }
   };

   my $finish = sub {
      my ($stream_done) = @_;
      return if $$stream_done++;
      --$open;
      $complete->();
   };

   my $parse = sub {
      my ($handle) = @_;

      while (!$failure and !$truncated
             and $handle->{rbuf} =~ s/\A([^\0]*)\0([^\0]*)\0([^\0]*)\0//s) {
         my ($type, $size, $raw_path) = ($1, $2, $3);
         my $full_path = eval { utf8dec $raw_path };

         if ($@) {
            $failure = "$tool returned a non-UTF-8 pathname\n";
            proc_kill $proc;
            last;
         }

         if (++$seen > $limit) {
            $truncated = 1;
            proc_kill $proc;
            last;
         }

         push @record, [$type, $size, $full_path];
      }

      $handle->{rbuf} = "" if $failure or $truncated;
   };

   $io->on_read (sub {
      $parse->($_[0]);
   });
   $io->on_eof (sub {
      $parse->($_[0]);
      $failure ||= "incomplete $tool output\n"
         if length $_[0]{rbuf} and !$truncated;
      $finish->(\$stdout_done);
   });
   $io->on_error (sub {
      return unless $_[1];
      $failure ||= "$tool stdout: $_[2]\n"
         unless $truncated or $timed_out;
      proc_kill $proc;
      $finish->(\$stdout_done);
   });

   my $capture_stderr = sub {
      my ($handle) = @_;
      my $remaining = 65536 - length $stderr;
      $stderr .= substr $handle->{rbuf}, 0, $remaining if $remaining > 0;
      $handle->{rbuf} = "";
   };

   $err->on_read (sub {
      $capture_stderr->($_[0]);
   });
   $err->on_eof (sub {
      $capture_stderr->($_[0]);
      $finish->(\$stderr_done);
   });
   $err->on_error (sub {
      return unless $_[1];
      $capture_stderr->($_[0]);
      $failure ||= "$tool stderr: $_[2]\n"
         unless $truncated or $timed_out;
      proc_kill $proc;
      $finish->(\$stderr_done);
   });

   my $ok = eval { $io->push_shutdown; 1 };
   unless ($ok) {
      my $error = $@;
      proc_kill $proc;
      $io->destroy;
      die $error;
   }

   $timer = AE::timer 30, 0, sub {
      $timed_out = 1;
      proc_kill $proc;
   };

   proc_on_exit $proc, sub {
      $status = $_[0];
      $complete->();
   };
}

$find && mcp_tool list =>
   "List immediate filesystem entries without following symlinks. "
   . "Compact text output uses /relative-directory headers for directories, f<TAB>approx-size<TAB>name "
   . "for regular files, TYPE<TAB>name for l/p/s/b/c/? nodes, "
   . "with compact size suffixes k/M/G/T/P using IEC powers of 1024, "
   . "and !truncated when the result limit was exceeded. Backslash and newline are escaped in names.",
   {
      type                 => "object",
      properties           => {
         path   => {
            type        => "string",
            description => "Directory to list; defaults to the selected workdir.",
         },
         limit  => {
            type    => "integer",
            minimum => 1,
            maximum => 1000,
            default => 200,
         },
         workdir   => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      additionalProperties => JSON::XS::false,
   },
   sub {
      fs_list_find $_[0], $_[1], 0
   }
;

$find && mcp_tool find =>
   "Find non-directory filesystem entries recursively by literal basename substring without following symlinks. Same output format as list.",
   {
      type                 => "object",
      properties           => {
         path   => {
            type        => "string",
            description => "Path to search recursively; defaults to the selected workdir.",
         },
         name   => {
            type        => "string",
            minLength   => 1,
            description => "Literal substring of the basename to find.",
         },
         limit  => {
            type    => "integer",
            minimum => 1,
            maximum => 1000,
            default => 200,
         },
         workdir   => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["name"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      fs_list_find $_[0], $_[1], 1
   }
;

my $file_read = q{#perl
   my ($path, $offset, $length) = @ARGV;

   open my $fh, "<:raw", $path     or return 0, "open: $!";
   defined sysseek $fh, $offset, 0 or return 0, "seek: $!";
   my $n = sysread $fh, my $data, $length;
   defined $n                      or return 0, "read: $!";

   (1, $data)
};

$perl && mcp_tool file_read =>
   "Read up to 1 MiB by byte offset; returns either base64 data or an errno string.",
   {
      type                 => "object",
      properties           => {
         path     => {
            type => "string",
         },
         offset   => {
            type    => "integer",
            minimum => 0,
            default => 0,
         },
         length   => {
            type    => "integer",
            minimum => 1,
            maximum => 1<<20,
            default => 1<<16,
         },
         workdir     => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason   => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["path"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      my $offset = $args->{offset} // 0;
      my $length = $args->{length} // 65536;
      $length <= 1<<20
         or die "invalid read range\n";
      my $path = fs_path $workdir, $args->{path};

      my $capability = fs_path_capability $path, "read";

      my $granted = $req->require_permission ({
         tool         => "file-read",
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [$capability],
         reason       => $args->{reason} // "read $path",
      });

      AE::log debug => join " ", "file-read", $path, $offset, $length;

      perl_eval $req, $workdir, $granted, $file_read,
         [utf8enc $path, $offset, $length], 30, $length + 4096, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         @$result == 2
            or return $req->error ("invalid file-read response\n");
         my ($ok, $value) = @$result;
         if ($ok eq "1") {
            $req->reply (fs_result {
               data => MIME::Base64::encode_base64 ($value, ""),
            });
         } elsif ($ok eq "0") {
            $req->reply (fs_result {
               error => utf8dec $value,
            });
         } else {
            $req->error ("invalid file-read status\n");
         }
      };
   }
;

$sed && mcp_tool read_lines =>
   "Read UTF-8 text by positive line-number ranges. "
   . "Ranges are returned separately in request order; overlaps and duplicates are preserved.",
   {
      type                 => "object",
      properties           => {
         path   => {
            type => "string",
         },
         ranges => {
            type     => "array",
            description => "Inclusive line ranges, each N or N,M.",
            items    => {
               type    => "string",
               pattern => q{^[1-9][0-9]*(?:,[1-9][0-9]*)?$},
            },
            minItems => 1,
            maxItems => 20,
         },
         workdir => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["path", "ranges"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      my $path = fs_path $workdir, $args->{path};
      my @range = map {
         my ($start, $end) = /\A([1-9]\d*)(?:,([1-9]\d*))?\z/
            or die "invalid line range\n";
         $end //= $start;
         $start <= $end
            or die "invalid line range\n";
         [$_, $start, $end]
      } @{$args->{ranges}};

      my $capability = fs_path_capability $path, "read";
      my $granted = $req->require_permission ({
         tool         => "read-lines",
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [$capability],
         reason       => $args->{reason} // "read lines $path",
      });

      AE::log debug => join " ", "read-lines", $path, map $_->[0], @range;

      my (@result, $truncated);
      my $remaining = 1 << 20;
      my $next;
      $next = sub {
         unless (@range) {
            undef $next;
            my $text = "";
            for (@result) {
               my ($range, $body) = @$_;
               $text .= "[$range]\n$body";
               $text .= "\n"
                  if length $body and substr ($body, -1) ne "\n";
            }
            $text .= "!truncated\n" if $truncated;
            return $req->reply (fs_text_result $text);
         }

         my ($range, $start, $end) = @{shift @range};
         my @command = (
            (fs_sandbox $workdir, $granted),
            $sed, "-n",
            "-e", ($start == $end ? "${start}p" : "${start},${end}p"),
            "-e", "${end}q",
            utf8enc $path,
         );

         fs_run $req, \@command, "", 30, $remaining, 0, sub {
            my ($success, $value) = @_;
            return $req->error ($value)
               unless $success;

            my $body;
            my $ok = eval {
               die "read-lines timed out\n" if $value->{timed_out};
               if ($value->{exit} or $value->{signal}) {
                  my $stderr = utf8dec $value->{stderr};
                  die "read-lines failed (exit $value->{exit}, signal $value->{signal}): $stderr\n";
               }
               $body = utf8dec $value->{stdout};
               1
            };
            return $req->error ($@)
               unless $ok;

            push @result, [$range, $body];
            $remaining -= length $value->{stdout};
            if ($value->{truncated}) {
               $truncated = 1;
               @range = ();
            } elsif ($remaining <= 0 and @range) {
               $truncated = 1;
               @range = ();
            }
            $next->();
         };
      };

      $next->();
   }
;

my $file_write = q{#perl
   my ($path, $offset, $data) = @ARGV;

   use Fcntl qw(O_WRONLY O_CREAT);
   sysopen my $fh, $path, O_WRONLY | O_CREAT, 0666 or return 0, "open: $!";

   binmode $fh;
   defined sysseek $fh, $offset, 0 or return 0, "seek: $!";
   my $n = syswrite $fh, $data;
   defined $n or return 0, "write: $!";

   (1, "$n")
};

$perl && mcp_tool file_write =>
   "Write up to 1 MiB of base64 data at a byte offset without truncating; returns bytes written or an errno string.",
   {
      type                 => "object",
      properties           => {
         path    => {
            type => "string",
         },
         offset  => {
            type    => "integer",
            minimum => 0,
            default => 0,
         },
         data    => {
            type => "string",
         },
         workdir    => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason  => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["path", "data"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      my $offset = $args->{offset} // 0;
      my $data = MIME::Base64::decode_base64 $args->{data};
      MIME::Base64::encode_base64 ($data, "") eq $args->{data}
         or die "invalid base64 data\n";
      length $data <= 1048576
         or die "write data exceeds 1 MiB\n";
      my $path = fs_path $workdir, $args->{path};

      my $capability = fs_path_capability $path, "write";

      my $granted = $req->require_permission ({
         tool         => "file-write",
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [$capability],
         reason       => $args->{reason} // "write $path",
      });
      $permissions->closure ($granted)->{$capability}
         or die "permission reduced below $capability for $path\n";

      AE::log debug => join " ", "file-write", $path, $offset, length ($data);

      perl_eval $req, $workdir, $granted, $file_write,
         [utf8enc $path, $offset, $data], 30, 4096, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         @$result == 2
            or return $req->error ("invalid file-write response\n");
         my ($ok, $value) = @$result;
         if ($ok eq "1") {
            $value =~ /\A[0-9]+\z/
               or return $req->error ("invalid file-write byte count\n");
            $req->reply (fs_result {
               bytes => 0 + $value,
            });
         } elsif ($ok eq "0") {
            $req->reply (fs_result {
               error => utf8dec $value,
            });
         } else {
            $req->error ("invalid file-write status\n");
         }
      };
   }
;

my $path_op = q{#perl
   while (@ARGV) {
      my $op = shift;

      if ($op eq "unlink") {
         my $path = shift;
         unlink $path
            or die "unlink $path: $!\n";
      } elsif ($op eq "rmdir") {
         my $path = shift;
         rmdir $path
            or die "rmdir $path: $!\n";
      } elsif ($op eq "mkdir") {
         my ($path, $mode) = splice @ARGV, 0, 2;
         $mode = oct $mode;
         mkdir $path, $mode
            or die "mkdir $path: $!\n";
         chmod $mode, $path
            or die "chmod $path: $!\n";
      } elsif ($op eq "symlink") {
         my ($target, $path) = splice @ARGV, 0, 2;
         symlink $target, $path
            or die "symlink $path: $!\n";
      } elsif ($op eq "truncate") {
         my ($path, $size) = splice @ARGV, 0, 2;
         truncate $path, $size
            or die "truncate $path: $!\n";
      } elsif ($op eq "chmod") {
         my ($path, $mode) = splice @ARGV, 0, 2;
         $mode = oct $mode;
         chmod $mode, $path
            or die "chmod $path: $!\n";
      } elsif ($op eq "rename") {
         my ($path, $to) = splice @ARGV, 0, 2;
         rename $path, $to
            or die "rename $path -> $to: $!\n";
      } else {
         die "invalid path operation '$op'\n";
      }
   }

   1
};

$perl && mcp_tool path_op =>
   "Perform pathname mutations in fixed order: unlink, rmdir, mkpath, mkdir, symlink, truncate, chmod, rename. "
   . "mkpath permission-checks each missing component separately; symlink targets are link contents, not authority.",
   {
      type                 => "object",
      properties           => {
         path     => {
            type => "string",
         },
         unlink   => {
            type => "boolean",
         },
         rmdir    => {
            type => "boolean",
         },
         mkdir    => {
            description => "Create path as a directory with this final mode, overriding umask.",
            anyOf       => [
               { type => "string", pattern => q{^[0-7]+$} },
               { type => "integer", minimum => 0 },
            ],
         },
         mkpath   => {
            description => "Create missing path components with this final mode, overriding umask.",
            anyOf       => [
               { type => "string", pattern => q{^[0-7]+$} },
               { type => "integer", minimum => 0 },
            ],
         },
         symlink  => {
            type        => "string",
            minLength   => 1,
            description => "Create path as a symlink containing this target.",
         },
         truncate => {
            type    => "integer",
            minimum => 0,
         },
         chmod     => {
            anyOf => [
               { type => "string", pattern => q{^[0-7]+$} },
               { type => "integer", minimum => 0 },
            ],
         },
         rename    => {
            type        => "string",
            minLength   => 1,
            description => "Rename path to this destination.",
         },
         workdir   => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason    => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["path"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      ($args->{unlink} or $args->{rmdir}
       or grep { exists $args->{$_} } qw(mkdir mkpath symlink truncate chmod rename))
         or die "no path operation requested\n";

      my $workdir = fs_workdir $args->{workdir};
      my $path = fs_path $workdir, $args->{path};
      my $rename = exists $args->{rename}
         ? fs_path $workdir, $args->{rename}
         : undef;

      my @mkpath;
      if (exists $args->{mkpath}) {
         my $prefix = "";
         for (split m{/}, substr $path, 1) {
            $prefix .= "/$_";
            push @mkpath, $prefix
               unless -d utf8enc $prefix;
         }
      }

      my $granted = fs_require_paths $req, $workdir,
         [@mkpath, $path, (defined $rename ? $rename : ())], "write", $args->{reason};

      my @log = map {
         ($_ eq "unlink" or $_ eq "rmdir")
            ? ($args->{$_} ? $_ : ())
            : (exists $args->{$_} ? "$_=$args->{$_}" : ())
      } qw(unlink rmdir mkpath mkdir symlink truncate chmod rename);

      AE::log debug => join " ", "path-op", $path, @log;

      my @operation;
      my $raw_path = utf8enc $path;

      push @operation, unlink => $raw_path
         if $args->{unlink};
      push @operation, rmdir => $raw_path
         if $args->{rmdir};
      push @operation, mkdir => (utf8enc $_), $args->{mkpath}
         for @mkpath;
      push @operation, mkdir => $raw_path, $args->{mkdir}
         if exists $args->{mkdir};
      push @operation, symlink => (utf8enc $args->{symlink}), $raw_path
         if exists $args->{symlink};
      push @operation, truncate => $raw_path, $args->{truncate}
         if exists $args->{truncate};
      push @operation, chmod => $raw_path, $args->{chmod}
         if exists $args->{chmod};
      push @operation, rename => $raw_path, (utf8enc $rename)
         if defined $rename;

      perl_eval $req, $workdir, $granted, $path_op,
         \@operation, 30, 4096, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         @$result == 1 and $result->[0] eq "1"
            or return $req->error ("invalid path-op response\n");
         $req->reply (fs_text_result "ok\n");
      };
   }
;

my $file_patch = q{#perl
   require "/run/anyevent-mcp.pm";
   use Fcntl qw(O_RDWR O_CREAT O_EXCL);
   use Errno qw(EEXIST ENAMETOOLONG);

   my ($patch, $path, $diff, @max_offset) = @ARGV;

   my $create_tempfile = sub {
      my ($name) = @_;
      utf8::decode $name
         or return undef, "invalid UTF-8 tempfile name";

      my $slash = rindex $name, "/";
      my $dir = $slash < 0 ? "" : substr $name, 0, $slash + 1;
      my $file = substr $name, $slash + 1;

      for (;;) {
         my $pathname = "$dir$file";
         utf8::encode $pathname;

         if (sysopen my $fh, $pathname, O_RDWR | O_CREAT | O_EXCL, 0600) {
            binmode $fh;
            return $fh, $pathname
         }

         if ($! == EEXIST) {
            $file .= "~";
         } elsif ($! == ENAMETOOLONG) {
            substr $file, (length $file) * .75, 2, "~";
         } else {
            return undef, "open tempfile: $!"
         }
      }
   };

   my $run_patch = sub {
      my ($newname, $path, $diff) = @_;

      my ($errfh, $errname) = $create_tempfile->("/tmp/mcp-fs~~patch~~");
      $errfh
         or return undef, $errname;

      local $ENV{LC_ALL} = "C";
      open my $write, "|-", "sh", "-c",
         q{exec "$4" --unified --verbose --binary --batch --forward --get=0 --fuzz=0 --reject-file=- --no-backup-if-mismatch -o "$2" "$1" >"$3" 2>&1},
         "--", $path, $newname, $errname, $patch
         or return undef, "open patch pipe: $!";

      my $write_error;
      {
         print $write $diff
            or $write_error = "write patch: $!";
         close $write;
      }

      my $status = $?;

      unlink $errname
         or return undef, "unlink patch stderr: $!";
      defined sysseek $errfh, 0, 0
         or return undef, "seek patch stderr: $!";
      my $output = do { local $/; <$errfh> };
      $output = "" unless defined $output;
      $output =~ s/\s+\z//;

      return undef, $write_error
         if $write_error and !$status;

      $status, $output
   };

   my $replace_file = sub {
      my ($path, $before, $newfh, $newname) = @_;

      chown $before->[4], $before->[5], $newfh;
      chmod $before->[2], $newfh;

      my @after = lstat $path;
      @after
         or return undef, "lstat: $!";
      join ("\0", @$before[0, 1, 2, 3, 4, 5, 7, 9, 10]) eq join ("\0", @after[0, 1, 2, 3, 4, 5, 7, 9, 10])
         or return undef, "file changed while applying patch";
      my @new = stat $newfh;
      $after[3] == 1
         or return undef, "refusing to replace multiply-linked file";
      join ("\0", @after[2, 4, 5]) eq join ("\0", @new[2, 4, 5])
         or return undef, "cannot preserve file metadata";

      rename $newname, $path
         or return undef, "rename: $!";

      $new[7], undef
   };

   my @before = lstat $path;
   @before
      or return 0, "lstat: $!";
   -f _
      or return 0, "not a regular file";

   my ($newfh, $newname) = $create_tempfile->("$path~~new~~");
   $newfh
      or return 0, $newname;

   my ($status, $output) = $run_patch->($newname, $path, $diff);
   unless (defined $status) {
      unlink $newname;
      return 0, $output
   }

   unless (eval { AnyEvent::MCP::check_patch_output ($status, $output, \@max_offset); 1 }) {
      my $error = $@;
      unlink $newname;
      return 0, $error
   }

   my ($bytes, $error) = $replace_file->($path, \@before, $newfh, $newname);
   unlink $newname unless defined $bytes;
   defined $bytes
      ? (1, "$bytes")
      : (0, $error)
};

$perl && $patch && mcp_tool file_patch =>
   "Apply a unified diff to one regular file. Hunk counts are recomputed, fuzz is disabled, "
   . "whole-hunk relocation is limited per hunk by distinct old-side lines. "
   . "Pure insertion is allowed only at the beginning; elsewhere include old-side context.",
   {
      type                 => "object",
      properties           => {
         path    => { type => "string" },
         diff    => { type => "string", minLength => 1 },
         workdir => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason  => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["path", "diff"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      my $path = fs_path $workdir, $args->{path};
      my ($diff, $max_offset) = AnyEvent::MCP::normalize_udiff $args->{diff};
      $diff = utf8enc $diff;
      length $diff <= 4<<20
         or die "patch exceeds 4 MiB\n";

      my $capability = fs_path_capability $path, "write";
      my $granted = $req->require_permission ({
         tool         => "file-patch",
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [$capability],
         reason       => $args->{reason} // "patch $path",
      });
      $permissions->closure ($granted)->{$capability}
         or die "permission reduced below $capability for $path\n";

      AE::log debug => join " ", "file-patch", $path, scalar (@$max_offset), "hunks", length ($diff), "bytes";

      perl_eval $req, $workdir, $granted, $file_patch,
         [$patch, utf8enc $path, $diff, @$max_offset], 30, 65536, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         @$result == 2
            or return $req->error ("invalid file-patch response\n");
         my ($ok, $value) = @$result;

         if ($ok eq "1") {
            $value =~ /\A[0-9]+\z/
               or return $req->error ("invalid file-patch byte count\n");
            $req->reply (fs_result {
               bytes => 0 + $value,
            });
         } elsif ($ok eq "0") {
            $req->reply (fs_result {
               error => utf8dec $value,
            });
         } else {
            $req->error ("invalid file-patch status\n");
         }
      };
   }
;

$find && $grep && mcp_tool grep =>
   "Search regular files of at most 1 MiB recursively without following symlinks or descending .git. "
   . "Fixed-string matching by default; mode=pcre uses GNU grep -P. "
   . "Stops after the result limit; reports truncation and timeout separately.",
   {
      type                 => "object",
      properties           => {
         path    => {
            type        => "string",
            description => "Path to search; defaults to the selected workdir.",
         },
         pattern => {
            type      => "string",
            minLength => 1,
         },
         mode    => {
            type    => "string",
            enum    => ["fixed", "pcre"],
            default => "fixed",
         },
         limit   => {
            type        => "integer",
            minimum     => 1,
            maximum     => 1000,
            default     => 200,
            description => "Maximum number of matching lines to return.",
         },
         workdir    => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason  => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["pattern"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      my $path = fs_path $workdir, $args->{path} // ".";
      my $mode = $args->{mode} // "fixed";
      $mode eq "fixed" or $mode eq "pcre"
         or die "invalid grep mode\n";
      my $limit = $args->{limit} // 200;
      $limit <= 1000
         or die "invalid limit\n";
      my $capability = fs_path_capability $path, "read";

      my $granted = $req->require_permission ({
         tool         => "grep",
         subject      => $path,
         subjects     => (fs_subjects $workdir, $path),
         capabilities => [$capability],
         reason       => $args->{reason} // "grep $path",
      });

      AE::log debug => join " ", "grep", $path, $mode, (substr $args->{pattern}, 0, 40);

      my $find_path = utf8enc $path;
      my $pattern = utf8enc $args->{pattern};
      my @command = (
         (fs_sandbox $workdir, $granted),
         $find, $find_path,
         "-name", ".git", "-prune", "-o",
         "-type", "f",
         "-size", "-1048577c",
         "-exec",
         $grep, ($mode eq "pcre" ? "-P" : "-F"),
         "-I", "-H", "-n", "--color=never", "-e", $pattern,
         "{}", "+",
      );

      fs_run $req, \@command, "", 30, 1024 * 1024, $limit, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         my $response;
         my $ok = eval {
            my $stdout = utf8dec $result->{stdout};
            my $stderr = utf8dec $result->{stderr};

            if (($result->{exit} or $result->{signal})
                and !$result->{truncated} and !$result->{timed_out}) {
               die "grep failed (exit $result->{exit}, signal $result->{signal}): $stderr\n";
            }

            $response = {
               stdout    => $stdout,
               stderr    => $stderr,
               timed_out => $result->{timed_out},
               truncated => $result->{truncated},
            };
            1
         };
         return $req->error ($@)
            unless $ok;

         $req->reply (fs_result $response);
      };
   }
;

my $stat = q{#perl
   map {
      my @s = lstat $_;

      pack "(w/a*)*", (@s
         ? (1, (-l _ ? "link" : -d _ ? "directory" : -f _ ? "file" : "other"), @s)
         : (0, "lstat: $!"))
   } @ARGV
};

$perl && mcp_tool stat =>
   "Get lstat metadata for up to 100 paths; symlinks are not followed.",
   {
      type                 => "object",
      properties           => {
         paths  => {
            type     => "array",
            items    => {
               type => "string",
            },
            minItems => 1,
            maxItems => 100,
         },
         workdir   => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         reason => {
            type        => "string",
            description => "Reason for requesting permission.",
         },
      },
      required             => ["paths"],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      my $workdir = fs_workdir $args->{workdir};
      ARRAY:: eq ref $args->{paths} and @{$args->{paths}} and @{$args->{paths}} <= 100
         or die "stat needs 1..100 paths\n";
      my @paths = map { fs_path $workdir, $_ } @{$args->{paths}};

      my $granted = fs_require_paths $req, $workdir, \@paths, "read", $args->{reason};

      my @log = @paths;
      splice @log, 3, @log - 3, "..." if @log > 3;
      AE::log debug => join " ", "stat", @log;

      perl_eval $req, $workdir, $granted, $stat, [map { utf8enc $_ } @paths],
         30, 65536, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         @$result == @paths
            or return $req->error ("invalid stat response\n");

         my @result;
         for my $i (0 .. $#paths) {
            my ($ok, @s) = unpack "(w/a*)*", $result->[$i];

            if ($ok) {
               my $type = shift @s;
               push @result, +{
                  path  => $paths[$i],
                  type  => $type,
                  size  => 0 + $s[7],
                  mode  => (sprintf "%04o", $s[2] & 07777),
                  uid   => 0 + $s[4],
                  gid   => 0 + $s[5],
                  mtime => 0 + $s[9],
               };
            } else {
               push @result, +{
                  path  => $paths[$i],
                  error => utf8dec $s[0],
               };
            }
         }

         $req->reply (fs_result { result => \@result });
      };
   }
;

mcp_tool exec =>
   "Run arbitrary argv in bubblewrap; UTF-8 stdin is limited to 4 MiB, "
   . "stdout/stderr are decoded as UTF-8 and captured to 1 MiB combined. Capabilities are optional; "
   . "there is no command-prefix safety classification.",
   {
      type       => "object",
      properties => {
         workdir => {
            type        => "integer",
            minimum     => 0,
            description => "Configured workdir index; required when more than one workdir is configured.",
         },
         argv => {
            type     => "array",
            items    => { type => "string" },
            minItems => 1,
         },
         capabilities => {
            type        => "array",
            description => "Optional authority override from workdirs; explicit [] requests the minimal sandbox. host-proc is currently unavailable.",
            items       => {
               type => "string",
               enum => [sort keys %capability],
            },
         },
         reason => {
            type        => "string",
            description => "Useful reason for requesting arbitrary command authority.",
         },
         stdin  => { type => "string" },
         timeout => {
            type    => "integer",
            minimum => 1,
            maximum => 300,
            default => 30,
         },
      },
      required             => [qw(argv reason)],
      additionalProperties => JSON::XS::false,
   },
   sub {
      my ($req, $args) = @_;

      ARRAY:: eq ref $args->{argv} and @{$args->{argv}}
         or die "exec needs argv strings without NUL\n";
      for my $arg (@{$args->{argv}}) {
         defined $arg and !ref $arg and $arg !~ /\0/
            or die "exec needs argv strings without NUL\n";
      }
      length $args->{argv}[0] or die "exec needs an executable\n";

      my $workdir = fs_workdir $args->{workdir};
      my $capabilities = exists $args->{capabilities}
         ? $args->{capabilities}
         : \@exec_default_capabilities;
      my $requested = $permissions->closure ($capabilities);
      die "host-proc sandbox authority is unresolved and unavailable in v1\n"
         if $requested->{"host-proc"};

      my $timeout = $args->{timeout} // 30;
      $timeout <= 300
         or die "invalid timeout\n";

      my $input = $args->{stdin} // "";
      $input = utf8enc $input;
      length $input <= 4 * 1024 * 1024 or die "stdin exceeds 4 MiB\n";

      my $coder = JSON::XS->new->canonical;
      my $subject = $coder->encode ($args->{argv});
      my $executable = $coder->encode ($args->{argv}[0]);
      my $granted = $req->require_permission ({
         tool         => "exec",
         subject      => $subject,
         reason       => $args->{reason},
         capabilities => $capabilities,
         subjects     => [
            {
               label   => "exact executable and argv",
               subject => $subject,
            },
            {
               label   => "this executable, arbitrary argv",
               subject => "^\\[\Q$executable\E(?:,.*)?\\]\\z",
            },
            {
               label   => "any command",
               subject => "^",
            },
         ],
      });

      AE::log debug => "exec "
         . (substr $subject, 0, 200)
         . (length $subject > 200 ? "..." : "")
         . (length $input ? " stdin=" . length ($input) : "");

      my @command = ((fs_sandbox $workdir, $granted), @{$args->{argv}});
      fs_run $req, \@command, $input, $timeout, 1024 * 1024, 0, sub {
         my ($success, $result) = @_;
         return $req->error ($result)
            unless $success;

         my $response;
         my $ok = eval {
            $result->{$_} = utf8dec $result->{$_} for qw(stdout stderr);
            $response = fs_result $result,
               $result->{exit} || $result->{signal} || $result->{timed_out};
            1
         };

         if ($ok) {
            $req->reply ($response);
         } else {
            $req->error ($@);
         }
      };
   }
;

mcp_config
   name => $name,
   server_info => { name => "mcp-fs", version => "0" },
   permissions => $permissions,
   on_error => sub { AE::log debug => "mcp-tool $_[1]{tool}: $_[2]" },
   instructions => "Use workdirs to inspect configured workdirs and capabilities. Paths are relative to the selected workdir; workdir-read/write expose all configured workdirs. Absolute paths request home/world authority, or shared-tmp for host tmp. Symlinks resolve inside the granted sandbox mounts. Runtime paths are baseline sandbox machinery; system-read exposes configured host exports. Exec requires explicit capabilities and a useful reason.\n";

my %listen;

$listen{host} = $host if defined $host;
$listen{port} = $port if defined $port;

my $server = $stdio ? mcp_stdio : mcp_start %listen;

print STDERR "Permission rules: $permissions->{file}\n"
   if $server->isa ("AnyEvent::MCP::Server::HTTP");

AnyEvent->condvar->recv;
Revision:	1.1
Committed:	Thu Oct 8 03:54:32 2026 UTC (13 days, 11 hours ago) by root
Branch:	MAIN
Log Message:	* empty log message *