From 483a78202199b7e518b7e402fdc96248409865a3 Mon Sep 17 00:00:00 2001 From: Pragmatic Software Date: Sun, 5 Oct 2025 06:22:44 -0700 Subject: [PATCH] applets/pbot-vm: restore VSOCK functionality - restore ability to execute VM commands concurrently via VSOCK - add PID to log messages and truncate overly long messages --- applets/pbot-vm/guest/lib/Guest.pm | 78 +++++++++++++------ .../pbot-vm/guest/lib/Languages/_default.pm | 26 +++++-- applets/pbot-vm/host/bin/vm-exec | 45 ++++++++--- applets/pbot-vm/host/bin/vm-server | 60 +++++++++----- applets/pbot-vm/host/lib/InteractiveEdit.pm | 2 - .../pbot-vm/host/lib/Languages/_default.pm | 27 ++++--- lib/PBot/VERSION.pm | 4 +- 7 files changed, 166 insertions(+), 76 deletions(-) diff --git a/applets/pbot-vm/guest/lib/Guest.pm b/applets/pbot-vm/guest/lib/Guest.pm index 10a9c5ec..d0a43117 100644 --- a/applets/pbot-vm/guest/lib/Guest.pm +++ b/applets/pbot-vm/guest/lib/Guest.pm @@ -22,42 +22,63 @@ use English; use Encode; use File::Basename; use JSON::XS; +use Time::HiRes qw/gettimeofday/; +use POSIX; + use Data::Dumper; +$Data::Dumper::Useqq = 1; +$Data::Dumper::Terse = 1; +$Data::Dumper::Indent = 0; + +sub info($text, $maxlen = 255) { + my $rest; + ($text, $rest) = $text =~ m/^(.{0,$maxlen})(.*)/ms; + $rest = length $rest; + $text .= " [... $rest more]" if $rest; + $text .= "\n" if $text !~ /\n$/; + my ($sec, $usec) = gettimeofday; + my $time = strftime "%a %b %e %Y %H:%M:%S", localtime $sec; + $time .= sprintf ".%03d", $usec / 1000; + print STDERR "$$ $time :: $text"; +} sub read_input($input, $buffer, $tag) { - my $line; - - print STDERR "$tag waiting for input...\n"; + info("$tag waiting for input...\n"); my $ret = sysread($input, my $buf, 4096); if (not defined $ret) { - print STDERR "Error reading $tag: $!\n"; + info("Error reading $tag: $!\n"); return undef; } if ($ret == 0) { - print STDERR "$tag input closed.\n"; + info("$tag input closed.\n"); return 0; } - print STDERR "$tag read $ret bytes [$buf]\n"; + info("$tag read $ret [" . (Dumper $buf) . "]\n"); - if ($buf ne "\n") { - chomp $buf; - $$buffer .= $buf; + $$buffer .= $buf; + + # info("$tag buffer [" . (Dumper $$buffer) . "]\n", 8192); + + if ($$buffer !~ /\n\n/) { return undef; } - $line = $$buffer; - $$buffer = ''; + my $line; + ($line, $$buffer) = split /\n\n/, $$buffer, 2; + $line =~ s/\n//g; - print STDERR "-" x 40, "\n"; - print STDERR "$tag got [$line]\n"; + info(("-" x 40) . "\n"); + + # info("$tag got [" . (Dumper $line) . "]\n", 8192); + # info("$tag buffer [" . (Dumper $$buffer) . "]\n", 8192); my $command = eval { decode_json($line) }; if ($@) { - print STDERR "Failed to decode JSON: $@\n"; + info("Failed to decode JSON: $@\n", 1024); return { arguments => '', cmdline => 'sh prog.sh', @@ -73,8 +94,7 @@ sub read_input($input, $buffer, $tag) { $command->{arguments} //= ''; $command->{input} //= ''; - print STDERR Dumper($command), "\n"; - + info("command: " . Dumper($command), 2048); return $command; } @@ -82,14 +102,14 @@ sub process_command($command, $mod, $user, $tag) { my ($uid, $gid, $home) = (getpwnam $user)[2, 3, 7]; if (not $uid and not $gid) { - print STDERR "Could not find user $user: $!\n"; + info("Could not find user $user: $!\n"); return undef; } my $pid = fork; if (not defined $pid) { - print STDERR "process_command: fork failed: $!\n"; + info("process_command: fork failed: $!\n"); return undef; } @@ -108,9 +128,10 @@ sub process_command($command, $mod, $user, $tag) { system("chmod -R 755 $dir 1>&2"); system("chown -R $user $dir 1>&2"); system("chgrp -R $user $dir 1>&2"); - system("pkill -u $user 1>&2"); - system("date -s \@$command->{date} 1>&2"); + if (time - $command->{date} > 60) { + system("date -s \@$command->{date} 1>&2"); + } $ENV{USER} = $user; $ENV{LOGNAME} = $user; @@ -124,7 +145,7 @@ sub process_command($command, $mod, $user, $tag) { my $result = run_command($command, $mod); - print STDERR "=" x 40, "\n"; + info(("=" x 40) . "\n"); # ensure output is newline-terminated $result .= "\n" unless $result =~ /\n$/; @@ -132,7 +153,16 @@ sub process_command($command, $mod, $user, $tag) { return $result; } else { # wait for child to finish - waitpid($pid, 0); + my $kid = waitpid($pid, 0); + my $status = $?; + + if (WIFEXITED($status)) { + info("child normal exit: " . WEXITSTATUS($status) . "\n"); + } + + if (WIFSIGNALED($status)) { + info("child signaled exit: " . WTERMSIG($status) . "\n"); + } # clean up persistent factoid storage if ($command->{'persist-key'}) { @@ -141,8 +171,8 @@ sub process_command($command, $mod, $user, $tag) { system ("rm -rf \"/home/$user/$command->{'persist-key'}\""); } - # kill any left-over processes started by $user - system("pkill -u $user"); + # kill any left-over processes started by user + system("pkill -P $pid"); system("rm -rf /home/$user/$pid"); return 0; } diff --git a/applets/pbot-vm/guest/lib/Languages/_default.pm b/applets/pbot-vm/guest/lib/Languages/_default.pm index 1c834f32..75d7173e 100755 --- a/applets/pbot-vm/guest/lib/Languages/_default.pm +++ b/applets/pbot-vm/guest/lib/Languages/_default.pm @@ -8,15 +8,34 @@ package _default; use warnings; use strict; +use feature qw/signatures/; +no warnings qw/experimental::signatures/; + use IPC::Run qw/run timeout/; use Encode; use SplitLine; +use Time::HiRes qw/gettimeofday/; +use POSIX; + use Data::Dumper; $Data::Dumper::Terse = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Useqq = 1; +$Data::Dumper::Indent = 0; + +sub info($text, $maxlen = 255) { + my $rest; + ($text, $rest) = $text =~ m/^(.{0,$maxlen})(.*)/ms; + $rest = length $rest; + $text .= " [... $rest more]" if $rest; + $text .= "\n" if $text !~ /\n$/; + my ($sec, $usec) = gettimeofday; + my $time = strftime "%a %b %e %Y %H:%M:%S", localtime $sec; + $time .= sprintf ".%03d", $usec / 1000; + print STDERR "$$ $time :: $text"; +} sub new { my ($class, %conf) = @_; @@ -82,7 +101,7 @@ sub execute { $stdin = encode('UTF-8', $stdin); @cmdline = map { encode('UTF-8', $_) } @cmdline; - print STDERR "execute ($timeout) [$stdin] @cmdline\n"; + info("execute ($timeout) [$stdin] @cmdline\n"); my ($exitval, $stdout, $stderr) = eval { my ($stdout, $stderr); @@ -96,10 +115,7 @@ sub execute { ($exitval, $stdout, $stderr) = (-1, '', $exception); } - $Data::Dumper::Indent = 0; - print STDERR "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n"; - $Data::Dumper::Indent = 1; - + info("exitval $exitval stderr [" . Dumper($stderr) . "] stdout [" . Dumper($stdout) . "]\n"); return ($exitval, $stdout, $stderr); } diff --git a/applets/pbot-vm/host/bin/vm-exec b/applets/pbot-vm/host/bin/vm-exec index 3361fcf1..b6707b24 100755 --- a/applets/pbot-vm/host/bin/vm-exec +++ b/applets/pbot-vm/host/bin/vm-exec @@ -38,14 +38,34 @@ use File::Basename; use JSON::XS; use IPC::Open2; use IO::Socket; +use Socket qw/IPPROTO_TCP TCP_NODELAY/; +use Time::HiRes qw/gettimeofday/; +use POSIX; + +use Data::Dumper; +$Data::Dumper::Useqq = 1; +$Data::Dumper::Terse = 1; +$Data::Dumper::Indent = 0; use FindBin qw($RealBin); use lib "$RealBin/../lib"; +sub info($text, $maxlen = 255) { + my $rest; + ($text, $rest) = $text =~ m/^(.{0,$maxlen})(.*)/ms; + $rest = length $rest; + $text .= " [... $rest more]" if $rest; + $text .= "\n" if $text !~ /\n$/; + my ($sec, $usec) = gettimeofday; + my $time = strftime "%a %b %e %Y %H:%M:%S", localtime $sec; + $time .= sprintf ".%03d", $usec / 1000; + print STDERR "[$$] $time :: $text"; +} + sub connect_vsock($context) { return undef if not $context->{'vm-cid'}; - print STDERR "Connecting to remote VM socket CID $context->{'vm-cid'} port $context->{'vm-vport'}\n"; + info("Connecting to remote VM socket CID $context->{'vm-cid'} port $context->{'vm-vport'}\n"); my $command = "socat - VSOCK-CONNECT:$context->{'vm-cid'}:$context->{'vm-vport'}"; @@ -55,12 +75,12 @@ sub connect_vsock($context) { }; if ($@) { - print STDERR "Failed to connect to VM socket: $@\n"; + info("Failed to connect to VM socket: $@\n"); return undef; } if (not defined $pid) { - print STDERR "Failed to connect to VM socket: $!\n"; + info("Failed to connect to VM socket: $!\n"); return undef; } @@ -68,7 +88,7 @@ sub connect_vsock($context) { } sub connect_serial($context) { - print STDERR "Connecting to remote VM serial port $context->{'vm-serial'}\n"; + info("Connecting to remote VM serial port $context->{'vm-serial'}\n"); my $vm = IO::Socket::INET->new( PeerAddr => $context->{'vm-addr'}, @@ -77,6 +97,9 @@ sub connect_serial($context) { Type => SOCK_STREAM ); + $vm->autoflush(1); + $vm->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1); + # return same $vm handle for ($input, $output) return ($vm, $vm); } @@ -96,7 +119,7 @@ sub connect_vm($context) { die "Could not create connection to VM: $!"; } - print STDERR "Connected to VM.\n"; + info("Connected to VM.\n"); return ($input, $output); } @@ -123,14 +146,14 @@ sub make_context_from_args(@args_in) { # set extracted leading options foreach my $opt (keys %opts) { - print STDERR "Setting option `$opt`.\n"; + info("Setting option `$opt`.\n"); $context->{$opt} = 1; } # parse options specific to vm-exec while ($context->{code} =~ s/^-(lang|revert|health|vm-domain|vm-health|vm-cid|vm-vport|vm-serial|vm)=([^ ]+)\s*//) { my ($option, $value) = ($1, $2); - print STDERR "Overriding `$option` to `$value`.\n"; + info("Overriding `$option` to `$value`.\n"); $context->{$option} = lc $value; } @@ -264,7 +287,7 @@ sub main() { configure_context($context, $config); if ($context->{revert} && $context->{health}) { - print STDERR "-health and -revert cannot be used together; aborting.\n"; + info("-health and -revert cannot be used together; aborting.\n"); exit 0; } @@ -274,7 +297,7 @@ sub main() { $context->{'vm-domain'} = $config->{aliases}->{$context->{'vm-domain'}}; } - print STDERR "REVERT $context->{'vm-domain'}\n"; + info("REVERT $context->{'vm-domain'}\n"); if ($context->{'vm-vagrant'}) { system("virsh -c qemu:///system snapshot-revert $context->{'vm-domain'} 1"); @@ -295,7 +318,7 @@ sub main() { ); if (not defined $health) { - print STDERR "Unable to connect to health $context->{'vm-addr'} $context->{'vm-health'}\n"; + info("Unable to connect to health $context->{'vm-addr'} $context->{'vm-health'}\n"); exit 2; } @@ -313,7 +336,7 @@ sub main() { }; if ($@) { - print STDERR "Failed to get health: $@\n"; + info("Failed to get health: $@\n"); exit 1; } diff --git a/applets/pbot-vm/host/bin/vm-server b/applets/pbot-vm/host/bin/vm-server index e88a09a5..a489cb0d 100755 --- a/applets/pbot-vm/host/bin/vm-server +++ b/applets/pbot-vm/host/bin/vm-server @@ -22,28 +22,46 @@ use Net::hostent; use IPC::Shareable; use Time::HiRes qw/gettimeofday/; use Encode; +use POSIX; + +use Data::Dumper; +$Data::Dumper::Useqq = 1; +$Data::Dumper::Terse = 1; +$Data::Dumper::Indent = 0; use constant { SERVER_PORT => $ENV{PBOTVM_PORT} // 9000, COMPILE_TIMEOUT => $ENV{PBOTVM_TIMEOUT} // 10, }; +sub info($text, $maxlen = 255) { + my $rest; + ($text, $rest) = $text =~ m/^(.{0,$maxlen})(.*)/ms; + $rest = length $rest; + $text .= " [... $rest more]" if $rest; + $text .= "\n" if $text !~ /\n$/; + my ($sec, $usec) = gettimeofday; + my $time = strftime "%a %b %e %Y %H:%M:%S", localtime $sec; + $time .= sprintf ".%03d", $usec / 1000; + print STDERR "[$$] $time :: $text"; +} + sub vm_revert($input) { return if $ENV{PBOTVM_NOREVERT}; - print "Reverting vm...\n"; + info("Reverting vm...\n"); execute("perl vm-exec -revert $input", 1000); - print "Reverted.\n"; + info("Reverted.\n"); } sub vm_check_health($input) { - print "Checking health...\n"; + info("Checking health...\n"); my ($ret, $result) = execute("perl vm-exec -health $input", 2); - print "$result\n" if length $result; + info("$result\n") if length $result; return ($ret, $result); } sub execute($command, $timeout = COMPILE_TIMEOUT) { - print "execute ($command)\n"; + info("execute ($command)\n", 1024); # to get $? from pipe local $SIG{CHLD} = 'DEFAULT'; @@ -51,7 +69,7 @@ sub execute($command, $timeout = COMPILE_TIMEOUT) { my $pid = open(my $fh, '-|', split / /, encode('UTF-8', $command)); if (not defined $pid) { - print "Couldn't fork: $!\n"; + info("Couldn't fork: $!\n"); return (-13, "[Fatal error]"); } @@ -94,27 +112,27 @@ sub server_listen($port) { Reuse => 1, ); die "Can't setup server: $!" unless $server; - print "Server $0 accepting clients at :$port\n"; + info("Server $0 accepting clients at :$port\n"); return $server; } sub do_server() { - print "Starting PBot VM Server on port " . SERVER_PORT . "\n"; + info("Starting PBot VM Server on port " . SERVER_PORT . "\n"); my $server = eval { server_listen(SERVER_PORT) }; if ($@) { - print STDERR $@; + info($@); return; } while (my $client = $server->accept) { - print '-' x 20, "\n"; + info('-' x 20 . "\n"); my $hostinfo = gethostbyaddr($client->peeraddr); - print "Connect from ", $client->peerhost, " at ", scalar localtime, "\n"; + info("Connect from " . $client->peerhost . "\n"); handle_client($client); } - print "Shutting down server.\n"; + info("Shutting down server.\n"); } sub handle_client($client) { @@ -123,7 +141,7 @@ sub handle_client($client) { my $r = fork; if (not defined $r) { - print "Could not fork to handle client: $!\n"; + info("Could not fork to handle client: $!\n"); print $client "Fatal error.\n"; close $client; return; @@ -151,19 +169,19 @@ sub handle_client($client) { # give client 5 more seconds alarm 5; - print "[$$] Read [$input]\n"; + info("Read [" . Dumper($input) . "]\n"); # check health my ($health, $health_message) = vm_check_health($input); if ($health == 2) { - print "[$$] Unable to connect to VM health check, ignoring compile attempt.\n"; + info("Unable to connect to VM health check, ignoring compile attempt.\n"); print $client "Virtual machine is offline.\n"; last; } if ($health == 1 || $health == -13) { - print "[$$] VM not responding to health check, ignoring compile attempt.\n"; + info("VM not responding to health check, ignoring compile attempt.\n"); print $client "Virtual machine is temporarily unavailable, try again soon.\n"; last; } @@ -183,7 +201,7 @@ sub handle_client($client) { my ($ret, $result) = execute("perl vm-exec $input"); $result =~ s/\s+$//; - print "Ret: $ret; result: [$result]\n"; + info("Ret: $ret; result: [" . Dumper($result) . "]\n"); if ($result =~ m/\[Killed\]$/) { $killed = 1; @@ -202,20 +220,20 @@ sub handle_client($client) { }; # print client time-out exception - print "[$$] $@" if $@; + info($@) if $@; alarm 0; close $client; - print "[$$] timed out: $timed_out; killed: $killed\n"; + info("timed out: $timed_out; killed: $killed\n"); if ($timed_out || $killed) { vm_revert($input); } # child done - print "[$$] client exit\n"; - print "=" x 20, "\n"; + info("client exit\n"); + info("=" x 20 . "\n"); exit; } diff --git a/applets/pbot-vm/host/lib/InteractiveEdit.pm b/applets/pbot-vm/host/lib/InteractiveEdit.pm index 89830701..7f83bec8 100644 --- a/applets/pbot-vm/host/lib/InteractiveEdit.pm +++ b/applets/pbot-vm/host/lib/InteractiveEdit.pm @@ -21,8 +21,6 @@ our @EXPORT = qw(interactive_edit); sub interactive_edit($self) { my $code = $self->{code}; - print " code: [$code]\n" if $self->{debug}; - my $subcode = $code; while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} diff --git a/applets/pbot-vm/host/lib/Languages/_default.pm b/applets/pbot-vm/host/lib/Languages/_default.pm index e1fc5abe..dfae119f 100755 --- a/applets/pbot-vm/host/lib/Languages/_default.pm +++ b/applets/pbot-vm/host/lib/Languages/_default.pm @@ -21,6 +21,7 @@ use POSIX; use Data::Dumper; $Data::Dumper::Useqq = 1; +$Data::Dumper::Terse = 1; use FindBin qw($RealBin); @@ -140,7 +141,7 @@ sub preprocess_code($self, %opts) { unless($self->{got_run} and $self->{copy_code}) { $self->info("---- preprocess\n"); - $self->info("$self->{nick} $self->{channel}: [$self->{arguments}] $self->{cmdline_options}\n$self->{code}\n",0); + $self->info("$self->{nick} $self->{channel}: [$self->{arguments}] $self->{cmdline_options}\n$self->{code}\n", 0, 8192); } # replace \n outside of quotes with literal newline @@ -257,7 +258,7 @@ sub execute { } $self->info("---- executing\n"); - $self->info("$cmdline\n$stdin\n$pretty_code\n", 0); + $self->info("$cmdline\n$stdin\n$pretty_code\n", 0, 8192); my $compile_in = { lang => $self->{lang}, @@ -283,14 +284,14 @@ sub execute { my @lines = unpack("(A$chunk_size)*", $compile_json); push @lines, ''; - $self->debug("Lines:\n" . (Dumper(\@lines))) if $self->{debug} > 1; + $self->info("Lines:\n" . Dumper(\@lines) . "\n", 1, 8192) if $self->{debug} > 1; foreach my $line (@lines) { $line .= "\n"; my $length = length $line; my $sent = 0; - $self->debug("writing [$line]\n") if $self->{debug} > 1; + $self->debug("writing [" . (Dumper $line) . "]\n") if $self->{debug} > 1; while ($sent < $length) { my $ret = syswrite($input, $line, $chunk_size + 1, $sent); @@ -333,9 +334,7 @@ sub execute { } close $input; - $self->{output} = $result; - return $result; } @@ -492,22 +491,28 @@ sub show_output($self) { close $fh; } -sub debug($self, $text, $timestamp = 1) { +sub debug($self, $text, $timestamp = 1, $maxlen = 255) { return if not $self->{debug}; - $self->info($text, $timestamp); + $self->info($text, $timestamp, $maxlen); } -sub info($self, $text, $timestamp = 1) { +sub info($self, $text, $timestamp = 1, $maxlen = 255) { if (not exists $self->{logh}) { open $self->{logh}, '>>:encoding(UTF-8)', "$RealBin/../log.txt" or die "Could not open log file: $!"; } + my $rest; + ($text, $rest) = $text =~ m/^(.{0,$maxlen})(.*)/ms; + $rest = length $rest; + $text .= " [... $rest more]" if $rest; + $text .= "\n" if $text !~ /\n$/; + if ($timestamp) { my ($sec, $usec) = gettimeofday; my $time = strftime "%a %b %e %Y %H:%M:%S", localtime $sec; $time .= sprintf ".%03d", $usec / 1000; - print STDERR "$time :: $text"; - print { $self->{logh} } "$time :: $text"; + print STDERR "[$$] $time :: $text"; + print { $self->{logh} } "[$$] $time :: $text"; } else { print STDERR $text; print { $self->{logh} } $text; diff --git a/lib/PBot/VERSION.pm b/lib/PBot/VERSION.pm index ce4d2b6a..3253eb29 100644 --- a/lib/PBot/VERSION.pm +++ b/lib/PBot/VERSION.pm @@ -25,8 +25,8 @@ use PBot::Imports; # These are set by the /misc/update_version script use constant { BUILD_NAME => "PBot", - BUILD_REVISION => 4898, - BUILD_DATE => "2025-09-28", + BUILD_REVISION => 4900, + BUILD_DATE => "2025-10-05", }; sub initialize {}