3
0
mirror of https://github.com/pragma-/pbot.git synced 2024-12-23 11:12:42 +01:00

compiler_vm: make guest debugging output less verbose

This commit is contained in:
Pragmatic Software 2022-02-06 11:33:21 -08:00
parent f0dbf8c33a
commit 46fdd01ccd
3 changed files with 182 additions and 180 deletions

View File

@ -11,6 +11,7 @@ use English;
use Encode;
use File::Basename;
use JSON::XS;
use Data::Dumper;
my $USERNAME = 'vm'; # variable for easier string interpolation
@ -22,12 +23,12 @@ use constant {
OUTPUT => '/dev/stdout',
};
my $USE_LOCAL = $ENV{'CC_LOCAL'} // 0;
use lib MOD_DIR;
my %languages;
my $USE_LOCAL = $ENV{'CC_LOCAL'};
sub load_modules {
my @files = glob MOD_DIR . "/*.pm";
foreach my $mod (@files){
@ -42,7 +43,7 @@ sub load_modules {
sub run_server {
my ($input, $output, $heartbeat);
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
if (not $USE_LOCAL) {
# set serial to 115200 baud instead of 9600
system('stty -F ' . SERIAL . ' 115200');
@ -65,15 +66,14 @@ sub run_server {
my $pid = fork;
die "Fork failed: $!" if not defined $pid;
if($pid == 0) {
my $buffer = "";
my $length = 4096;
if ($pid == 0) {
my $buffer = '';
my $line;
my $total_read = 0;
while (1) {
print "Waiting for input...\n";
my $ret = sysread($input, my $buf, $length);
my $ret = sysread($input, my $buf, 16384);
if (not defined $ret) {
print "Error reading: $!\n";
@ -83,7 +83,7 @@ sub run_server {
$total_read += $ret;
if ($ret == 0) {
print "input ded?\n";
print "Input closed; exiting...\n";
print "got buffer [$buffer]\n";
exit;
}
@ -92,30 +92,26 @@ sub run_server {
print "read $ret bytes [$total_read so far] [$buf]\n";
$buffer.= $buf;
if ($buffer =~ s/\s*:end:\s*$//m) {
$line = $buffer;
$buffer = "";
$total_read = 0;
} else {
next;
}
next if $buffer !~ s/\s*:end:\s*$//m;
$line = $buffer;
chomp $line;
$buffer = '';
$total_read = 0;
$line = encode('UTF-8', $line);
print "-" x 40, "\n";
print "Got [$line]\n";
$line = encode('UTF-8', $line);
my $compile_in = decode_json($line);
$compile_in->{arguments} //= '';
$compile_in->{input} //= '';
print "Attempting compile [$compile_in->{lang}] ...\n";
use Data::Dumper;
print Dumper $compile_in;
$compile_in->{arguments} //= '';
$compile_in->{input} //= '';
my $pid = fork;
if (not defined $pid) {
@ -125,6 +121,7 @@ sub run_server {
if ($pid == 0) {
my ($uid, $gid, $home) = (getpwnam $USERNAME)[2, 3, 7];
if (not $uid and not $gid) {
print "Could not find user $USERNAME: $!\n";
exit;
@ -153,15 +150,19 @@ sub run_server {
$EGID = "$gid $gid";
$EUID = $UID = $uid;
chdir("/home/$USERNAME");
my $result = interpret(%$compile_in);
$GID = 0;
$UID = 0;
my $compile_out = { result => $result };
my $json = encode_json($compile_out);
print "Done compiling; result: [$result] [$json]\n";
print "Done compiling: $json\n";
print $output "result:$json\n";
print $output "result:end\n";
@ -175,9 +176,12 @@ sub run_server {
exit;
} else {
waitpid $pid, 0;
# kill any left-over processes started by $USERNAME
system("pkill -u $USERNAME");
}
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
if (not $USE_LOCAL) {
print "=" x 40, "\n";
next;
} else {
@ -201,18 +205,12 @@ sub interpret {
$h{lang} = '_default' if not exists $languages{$h{lang}};
chdir("/home/$USERNAME");
my $mod = $h{lang}->new(%h);
$mod->preprocess;
# print "after preprocess: ", Dumper $mod, "\n";
$mod->postprocess if not $mod->{error} and not $mod->{done};
# print "after postprocess: ", Dumper $mod, "\n";
if (exists $mod->{no_output} or not length $mod->{output}) {
if ($h{factoid}) {
$mod->{output} = "";

View File

@ -12,10 +12,8 @@ use parent '_default';
sub preprocess {
my $self = shift;
my $input = $self->{input};
$input = "" if not defined $input;
my $input = $self->{input} // '';
print "writing input [$input]\n";
open(my $fh, '>', '.input');
print $fh "$input\n";
close $fh;

View File

@ -9,85 +9,91 @@ use warnings;
use strict;
use IPC::Run qw/run timeout/;
use Data::Dumper;
$Data::Dumper::Terse = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Useqq = 1;
sub new {
my ($class, %conf) = @_;
my $self = bless {}, $class;
my ($class, %conf) = @_;
my $self = bless {}, $class;
$self->{debug} = $conf{debug} // 0;
$self->{sourcefile} = $conf{sourcefile};
$self->{execfile} = $conf{execfile};
$self->{code} = $conf{code};
$self->{cmdline} = $conf{cmdline};
$self->{input} = $conf{input};
$self->{date} = $conf{date};
$self->{arguments} = $conf{arguments};
$self->{factoid} = $conf{factoid};
$self->{'persist-key'} = $conf{'persist-key'};
$self->{debug} = $conf{debug} // 0;
$self->{sourcefile} = $conf{sourcefile};
$self->{execfile} = $conf{execfile};
$self->{code} = $conf{code};
$self->{cmdline} = $conf{cmdline};
$self->{input} = $conf{input};
$self->{date} = $conf{date};
$self->{arguments} = $conf{arguments};
$self->{factoid} = $conf{factoid};
$self->{'persist-key'} = $conf{'persist-key'};
$self->initialize(%conf);
return $self;
$self->initialize(%conf);
return $self;
}
sub initialize {
my ($self, %conf) = @_;
my ($self, %conf) = @_;
}
sub preprocess {
my $self = shift;
my $self = shift;
open(my $fh, '>', $self->{sourcefile}) or die $!;
binmode($fh, ':utf8');
print $fh $self->{code} . "\n";
close $fh;
open(my $fh, '>', $self->{sourcefile}) or die $!;
binmode($fh, ':utf8');
print $fh $self->{code} . "\n";
close $fh;
print "Executing [$self->{cmdline}] with args [$self->{arguments}]\n";
my $quoted_args = '';
my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
if (length $self->{arguments}) {
my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
my $quoted_args = '';
foreach my $arg (@args) {
$arg =~ s/'/'"'"'/g;
$quoted_args .= "'$arg' ";
}
}
foreach my $arg (@args) {
$arg =~ s/'/'"'"'/g;
$quoted_args .= "'$arg' ";
}
$self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
$self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
$self->{output} = $stderr;
$self->{output} .= ' ' if length $self->{output};
$self->{output} .= $stdout;
$self->{error} = $retval;
$self->{output} = $stderr;
$self->{output} .= ' ' if length $self->{output};
$self->{output} .= $stdout;
$self->{error} = $retval;
}
sub postprocess {
my $self = shift;
}
sub postprocess {}
sub execute {
my ($self, $timeout, $stdin, @cmdline) = @_;
my ($self, $timeout, $stdin, @cmdline) = @_;
$stdin //= '';
print "execute($timeout) [$stdin] ", Dumper \@cmdline, "\n";
$stdin //= '';
print "execute ($timeout) [$stdin] @cmdline\n";
my ($exitval, $stdout, $stderr) = eval {
my ($stdout, $stderr);
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
my $exitval = $? >> 8;
return ($exitval, $stdout, $stderr);
};
if (my $exception = $@) {
$exception = "[Timed-out]" if $exception =~ m/timeout on timer/;
($exitval, $stdout, $stderr) = (-1, '', $exception);
}
$Data::Dumper::Indent = 0;
print "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n";
$Data::Dumper::Indent = 1;
my ($exitval, $stdout, $stderr) = eval {
my ($stdout, $stderr);
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
my $exitval = $? >> 8;
return ($exitval, $stdout, $stderr);
};
if ($@) {
my $error = $@;
$error = "[Timed-out]" if $error =~ m/timeout on timer/;
($exitval, $stdout, $stderr) = (-1, '', $error);
}
print "exitval $exitval stdout [$stdout]\nstderr [$stderr]\n";
return ($exitval, $stdout, $stderr);
}
# splits line into quoted arguments while preserving quotes.
@ -96,111 +102,111 @@ sub execute {
# handles unbalanced quotes gracefully by treating them as
# part of the argument they were found within.
sub split_line {
my ($self, $line, %opts) = @_;
my ($self, $line, %opts) = @_;
my %default_opts = (
strip_quotes => 0,
keep_spaces => 0,
preserve_escapes => 1,
);
my %default_opts = (
strip_quotes => 0,
keep_spaces => 0,
preserve_escapes => 1,
);
%opts = (%default_opts, %opts);
%opts = (%default_opts, %opts);
my @chars = split //, $line;
my @chars = split //, $line;
my @args;
my $escaped = 0;
my $quote;
my $token = '';
my $ch = ' ';
my $last_ch;
my $next_ch;
my $i = 0;
my $pos;
my $ignore_quote = 0;
my $spaces = 0;
my @args;
my $escaped = 0;
my $quote;
my $token = '';
my $ch = ' ';
my $last_ch;
my $next_ch;
my $i = 0;
my $pos;
my $ignore_quote = 0;
my $spaces = 0;
while (1) {
$last_ch = $ch;
while (1) {
$last_ch = $ch;
if ($i >= @chars) {
if (defined $quote) {
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
$i = $pos;
$ignore_quote = 1;
$quote = undef;
$last_ch = ' ';
$token = '';
} else {
# add final token and exit
push @args, $token if length $token;
last;
}
}
if ($i >= @chars) {
if (defined $quote) {
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
$i = $pos;
$ignore_quote = 1;
$quote = undef;
$last_ch = ' ';
$token = '';
} else {
# add final token and exit
push @args, $token if length $token;
last;
}
}
$ch = $chars[$i++];
$next_ch = $chars[$i];
$ch = $chars[$i++];
$next_ch = $chars[$i];
$spaces = 0 if $ch ne ' ';
$spaces = 0 if $ch ne ' ';
if ($escaped) {
if ($opts{preserve_escapes}) {
$token .= "\\$ch";
} else {
$token .= $ch;
}
$escaped = 0;
next;
}
if ($ch eq '\\') {
$escaped = 1;
next;
}
if (defined $quote) {
if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
# closing quote
$token .= $ch unless $opts{strip_quotes};
push @args, $token;
$quote = undef;
$token = '';
} else {
# still within quoted argument
$token .= $ch;
}
next;
}
if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
if ($ignore_quote) {
# treat unbalanced quote as part of this argument
$token .= $ch;
$ignore_quote = 0;
} else {
# begin potential quoted argument
$pos = $i - 1;
$quote = $ch;
$token .= $ch unless $opts{strip_quotes};
}
next;
}
if ($ch eq ' ') {
if (++$spaces > 1 and $opts{keep_spaces}) {
$token .= $ch;
next;
} else {
push @args, $token if length $token;
$token = '';
next;
}
}
if ($escaped) {
if ($opts{preserve_escapes}) {
$token .= "\\$ch";
} else {
$token .= $ch;
}
$escaped = 0;
next;
}
if ($ch eq '\\') {
$escaped = 1;
next;
}
if (defined $quote) {
if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
# closing quote
$token .= $ch unless $opts{strip_quotes};
push @args, $token;
$quote = undef;
$token = '';
} else {
# still within quoted argument
$token .= $ch;
}
next;
}
if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
if ($ignore_quote) {
# treat unbalanced quote as part of this argument
$token .= $ch;
$ignore_quote = 0;
} else {
# begin potential quoted argument
$pos = $i - 1;
$quote = $ch;
$token .= $ch unless $opts{strip_quotes};
}
next;
}
if ($ch eq ' ') {
if (++$spaces > 1 and $opts{keep_spaces}) {
$token .= $ch;
next;
} else {
push @args, $token if length $token;
$token = '';
next;
}
}
$token .= $ch;
}
return @args;
return @args;
}
1;