diff --git a/applets/compiler_vm/guest/bin/accept-vsock-client b/applets/compiler_vm/guest/bin/accept-vsock-client new file mode 100755 index 00000000..f0b6a704 --- /dev/null +++ b/applets/compiler_vm/guest/bin/accept-vsock-client @@ -0,0 +1,69 @@ +#!/usr/bin/env perl + +# File: accept-vsock-client +# +# Purpose: Accepts and handles a client connecting over Linux VM socket. + +# SPDX-FileCopyrightText: 2022 Pragmatic Software +# SPDX-License-Identifier: MIT + +use 5.020; + +use warnings; +use strict; + +use feature qw/signatures/; +no warnings qw(experimental::signatures); + +use constant { + USERNAME => 'vm', + MOD_DIR => '/usr/local/share/pbot-vm/', +}; + +use lib MOD_DIR; + +use Guest; + +sub accept_client() { + print STDERR "VSOCK accepted new connection.\n"; + + my $buffer = ''; + + while (1) { + my $command = Guest::read_input(*STDIN, \$buffer, 'VSOCK'); + + if (not defined $command) { + # recoverable error or waiting for more input + next; + } + + if (not $command) { + # unrecoverable error or input closed + exit 1; + } + + last; + } + + eval { require "Languages/$command->{lang}.pm" }; + + if ($@) { + require 'Languages/_default.pm'; + $command->{lang} = '_default'; + } + + my $mod = $command->{lang}->new(%$command); + + my $result = Guest::process_command($command, $mod, USERNAME, 'VSOCK'); + + if (not defined $result) { + $result = "[Fatal error]"; + } + + if ($result) { + Guest::send_output(*STDOUT, $result, 'VSOCK'); + exit; # exit child process + } +} + +accept_client(); diff --git a/applets/compiler_vm/guest/bin/guest-server b/applets/compiler_vm/guest/bin/guest-server index 0904c98e..cb534f84 100755 --- a/applets/compiler_vm/guest/bin/guest-server +++ b/applets/compiler_vm/guest/bin/guest-server @@ -16,208 +16,165 @@ use strict; use feature qw/signatures/; no warnings qw(experimental::signatures); -use English; -use Encode; -use File::Basename; -use JSON::XS; -use Data::Dumper; - -my $USERNAME = 'vm'; # variable for easier string interpolation - use constant { - MOD_DIR => '/usr/local/share/pbot-vm/Languages', + USERNAME => 'vm', + MOD_DIR => '/usr/local/share/pbot-vm/', SERIAL => '/dev/ttyS1', HEARTBEAT => '/dev/ttyS2', INPUT => '/dev/stdin', OUTPUT => '/dev/stdout', + VPORT => $ENV{PBOTVM_VPORT} // 5555, }; use lib MOD_DIR; +use lib MOD_DIR . "Languages"; + +use Guest; + +use File::Basename; +use IPC::Shareable; my %languages; sub load_modules() { - my @files = glob MOD_DIR . "/*.pm"; + my @files = glob MOD_DIR . "Languages/*.pm"; + foreach my $mod (@files){ print "Loading module $mod\n"; + my $filename = basename($mod); + require $filename; + $filename =~ s/\.pm$//; + $languages{$filename} = 1; } } -sub do_server($input, $output) { +sub vsock_server() { + print "Starting VSOCK server on PID $$\n"; + + system("socat VSOCK-LISTEN:".VPORT.",reuseaddr,fork EXEC:accept-vsock-client"); + + print "VSOCK server shutdown.\n"; + exit; # exit child process +} + +sub serial_server() { + print "Starting serial server on PID $$\n"; + + # set serial to 115200 baud instead of 9600 + system('stty -F '.SERIAL.' 115200'); + + open(my $input, '<', SERIAL) or die $!; + open(my $output, '>', SERIAL) or die $!; + + tie my $running, 'IPC::Shareable', { key => 'running' }; + my $buffer = ''; - my $line; - my $total_read = 0; - while (1) { - print "Waiting for input...\n"; - my $ret = sysread($input, my $buf, 16384); + while ($running) { + my $command = Guest::read_input($input, \$buffer, 'Serial'); - if (not defined $ret) { - print "Error reading: $!\n"; + if (not defined $command) { + # recoverable error while reading, try again next; } - if ($ret == 0) { - print "Input closed; exiting...\n"; + if ($command == 0) { + # serial closed, exit child process exit; } - $total_read += $ret; + if (not exists $languages{$command->{lang}}) { + $command->{lang} = '_default'; + } - chomp $buf; - print "read $ret bytes [$total_read so far] [$buf]\n"; + my $mod = $command->{lang}->new(%$command); - $buffer .= $buf; + my $result = Guest::process_command($command, $mod, USERNAME, 'Serial'); - next if $buffer !~ s/\s*:end:\s*$//m; + if (not defined $result) { + $result = "[Fatal error]"; + } - $line = $buffer; - chomp $line; - - $buffer = ''; - $total_read = 0; - - $line = encode('UTF-8', $line); - - print "-" x 40, "\n"; - print "Got [$line]\n"; - - my $command = decode_json($line); - $command->{arguments} //= ''; - $command->{input} //= ''; - - print Dumper $command; - handle_command($command, $output); + if ($result) { + Guest::send_output($output, $result, 'Serial'); + exit; # exit child process + } } } -sub handle_command($command, $output) { - local $SIG{CHLD} = 'IGNORE'; - +sub do_server() { my $pid = fork; if (not defined $pid) { - print "fork failed: $!\n"; - next; + print STDERR "Could not fork server: $!\n"; + die; } 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; - } - - if ($command->{'persist-key'}) { - system ("rm -rf \"/home/$USERNAME/$command->{'persist-key'}\""); - system("mount /dev/vdb1 /root/factdata"); - system("mkdir -p \"/root/factdata/$command->{'persist-key'}\""); - system("cp -R -p \"/root/factdata/$command->{'persist-key'}\" \"/home/$USERNAME/$command->{'persist-key'}\""); - } - - system("chmod -R 755 /home/$USERNAME"); - system("chown -R $USERNAME /home/$USERNAME"); - system("chgrp -R $USERNAME /home/$USERNAME"); - system("rm -rf /home/$USERNAME/prog*"); - system("pkill -u $USERNAME"); - - system("date -s \@$command->{date}"); - - $ENV{USER} = $USERNAME; - $ENV{LOGNAME} = $USERNAME; - $ENV{HOME} = $home; - - $GID = $gid; - $EGID = "$gid $gid"; - $EUID = $UID = $uid; - - chdir("/home/$USERNAME"); - - my $result = run_command(%$command); - - $GID = 0; - $UID = 0; - - my $compile_out = { result => $result }; - - my $json = encode_json($compile_out); - - print "Done compiling: $json\n"; - - print $output "result:$json\n"; - print $output "result:end\n"; - - if ($command->{'persist-key'}) { - system("cp -R -p \"/home/$USERNAME/$command->{'persist-key'}\" \"/root/factdata/$command->{'persist-key'}\""); - system("umount /root/factdata"); - system ("rm -rf \"/home/$USERNAME/$command->{'persist-key'}\""); - } - - print "=" x 40, "\n"; - - # kill any left-over processes started by $USERNAME - system("pkill -u $USERNAME"); - print "after pkill???\n"; - exit; + vsock_server(); + } else { + serial_server(); } } -sub run_command(%command) { - $command{lang} = '_default' if not exists $languages{$command{lang}}; +sub do_heartbeat() { + open(my $heartbeat, '>', HEARTBEAT) or die $!; - my $mod = $command{lang}->new(%command); + tie my $running, 'IPC::Shareable', { key => 'running' }; - local $SIG{CHLD} = 'DEFAULT'; + print "Heart beating on PID $$...\n"; - $mod->preprocess; - $mod->postprocess if not $mod->{error} and not $mod->{done}; - - if (exists $mod->{no_output} or not length $mod->{output}) { - if ($command{factoid}) { - $mod->{output} = ''; - } else { - $mod->{output} .= "\n" if length $mod->{output}; - - if (not $mod->{error}) { - $mod->{output} .= "Success (no output).\n"; - } else { - $mod->{output} .= "Exit code $mod->{error}.\n"; - } - } - } - - return $mod->{output}; -} - -sub do_heartbeat($heartbeat) { - while (1) { + while ($running) { print $heartbeat "\n"; sleep 5; } + + print "Heart beat stopped.\n"; + exit; # exit child process +} + +sub install_signal_handlers() { + use POSIX qw(:signal_h :errno_h :sys_wait_h); + + $SIG{CHLD} = \&REAPER; + + sub REAPER { + my $pid = waitpid(-1, &WNOHANG); + + if ($pid == -1) { + # no child waiting. Ignore it. + } elsif (WIFEXITED($?)) { + print "Process $pid exited.\n"; + } + + $SIG{CHLD} = \&REAPER; # in case of unreliable signals + } } sub main() { + print "Starting PBot VM Guest server on PID $$\n"; + load_modules(); - # set serial to 115200 baud instead of 9600 - system('stty -F ' . SERIAL . ' 115200'); + install_signal_handlers(); - open(my $input, '<', SERIAL) or die $!; - open(my $output, '>', SERIAL) or die $!; - open(my $heartbeat, '>', HEARTBEAT) or die $!; + tie my $running, 'IPC::Shareable', { key => 'running', create => 1, destroy => 1 }; + + $running = 1; my $pid = fork // die "Fork failed: $!"; if ($pid == 0) { - do_server($input, $output); + do_heartbeat(); } else { - do_heartbeat($heartbeat); + do_server(); } + + print "PBot VM Guest server shutdown.\n"; } main(); diff --git a/applets/compiler_vm/guest/bin/setup-guest b/applets/compiler_vm/guest/bin/setup-guest index afb23bfd..e373b2ac 100755 --- a/applets/compiler_vm/guest/bin/setup-guest +++ b/applets/compiler_vm/guest/bin/setup-guest @@ -11,9 +11,9 @@ # copy executable scripts cp guest/bin/* /usr/local/bin -# language support +# lib and language support mkdir -p /usr/local/share/pbot-vm/ -cp -r guest/lib/Languages/ /usr/local/share/pbot-vm/ +cp -r guest/lib/* /usr/local/share/pbot-vm/ # C support and GDB integration cp guest/include/prelude.h /usr/include diff --git a/applets/compiler_vm/guest/lib/Guest.pm b/applets/compiler_vm/guest/lib/Guest.pm new file mode 100644 index 00000000..2669848f --- /dev/null +++ b/applets/compiler_vm/guest/lib/Guest.pm @@ -0,0 +1,165 @@ +#!/usr/bin/env perl + +# File: Guest.pm +# +# Purpose: Collection of functions to interface with the PBot VM Guest and +# execute VM commands. + +# SPDX-FileCopyrightText: 2022 Pragmatic Software +# SPDX-License-Identifier: MIT + +package Guest; + +use 5.020; + +use warnings; +use strict; + +use feature qw/signatures/; +no warnings qw(experimental::signatures); + +use English; +use Encode; +use File::Basename; +use JSON::XS; +use IPC::Shareable; +use Data::Dumper; + +sub read_input($input, $buffer, $tag) { + my $line; + my $total_read = 0; + + print STDERR "$tag waiting for input...\n"; + my $ret = sysread($input, my $buf, 16384); + + if (not defined $ret) { + print STDERR "Error reading $tag: $!\n"; + return undef; + } + + if ($ret == 0) { + print STDERR "$tag input closed.\n"; + return 0; + } + + $total_read += $ret; + + print STDERR "$tag read $ret bytes [$total_read total] [$buf]\n"; + + $$buffer .= $buf; + + return undef if $$buffer !~ s/\s*:end:\s*$//m; + + $line = $$buffer; + chomp $line; + + $$buffer = ''; + $total_read = 0; + + $line = encode('UTF-8', $line); + + print STDERR "-" x 40, "\n"; + print STDERR "$tag got [$line]\n"; + + my $command = decode_json($line); + $command->{arguments} //= ''; + $command->{input} //= ''; + + print STDERR Dumper($command), "\n"; + + return $command; +} + +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"; + return undef; + } + + my $pid = fork; + + if (not defined $pid) { + print STDERR "process_command: fork failed: $!\n"; + return undef; + } + + if ($pid == 0) { + if ($command->{'persist-key'}) { + system ("rm -rf \"/home/$user/$command->{'persist-key'}\" 1>&2"); + system("mount /dev/vdb1 /root/factdata 1>&2"); + system("mkdir -p \"/root/factdata/$command->{'persist-key'}\" 1>&2"); + system("cp -R -p \"/root/factdata/$command->{'persist-key'}\" \"/home/$user/$command->{'persist-key'}\" 1>&2"); + } + + system("chmod -R 755 /home/$user 1>&2"); + system("chown -R $user /home/$user 1>&2"); + system("chgrp -R $user /home/$user 1>&2"); + system("rm -rf /home/$user/prog* 1>&2"); + system("pkill -u $user 1>&2"); + + system("date -s \@$command->{date} 1>&2"); + + $ENV{USER} = $user; + $ENV{LOGNAME} = $user; + $ENV{HOME} = $home; + + chdir("/home/$user"); + + $GID = $gid; + $EGID = "$gid $gid"; + $EUID = $UID = $uid; + + my $result = run_command($command, $mod); + + print STDERR "=" x 40, "\n"; + + return $result; + } else { + # wait for child to finish + waitpid($pid, 0); + + # clean up persistent factoid storage + if ($command->{'persist-key'}) { + system("cp -R -p \"/home/$user/$command->{'persist-key'}\" \"/root/factdata/$command->{'persist-key'}\""); + system("umount /root/factdata"); + system ("rm -rf \"/home/$user/$command->{'persist-key'}\""); + } + + # kill any left-over processes started by $user + system("pkill -u $user"); + return 0; + } +} + +sub run_command($command, $mod) { + local $SIG{CHLD} = 'DEFAULT'; + + $mod->preprocess; + $mod->postprocess if not $mod->{error} and not $mod->{done}; + + if (exists $mod->{no_output} or not length $mod->{output}) { + if ($command->{factoid}) { + $mod->{output} = ''; + } else { + $mod->{output} .= "\n" if length $mod->{output}; + + if (not $mod->{error}) { + $mod->{output} .= "Success (no output).\n"; + } else { + $mod->{output} .= "Exit code $mod->{error}.\n"; + } + } + } + + return $mod->{output}; +} + +sub send_output($output, $result, $tag) { + my $json = encode_json({ result => $result }); + print $output "result:$json\n"; + print $output "result:end\n"; +} + +1; diff --git a/applets/compiler_vm/guest/lib/Languages/_c_base.pm b/applets/compiler_vm/guest/lib/Languages/_c_base.pm index 8e1de548..39179db8 100755 --- a/applets/compiler_vm/guest/lib/Languages/_c_base.pm +++ b/applets/compiler_vm/guest/lib/Languages/_c_base.pm @@ -28,7 +28,7 @@ sub preprocess { print $fh $code . "\n"; close $fh; - print "Executing [$self->{cmdline}] without print_last_statement\n"; + print STDERR "Executing [$self->{cmdline}] without print_last_statement\n"; my ($retval, $stdout, $stderr) = $self->execute(60, undef, @cmd); $self->{output} = $stderr; $self->{output} .= ' ' if length $self->{output}; @@ -41,7 +41,7 @@ sub preprocess { print $fh $self->{code} . "\n"; close $fh; - print "Executing [$self->{cmdline}] with print_last_statement\n"; + print STDERR "Executing [$self->{cmdline}] with print_last_statement\n"; $self->execute(60, undef, @cmd); } } else { @@ -49,7 +49,7 @@ sub preprocess { print $fh $self->{code} . "\n"; close $fh; - print "Executing [$self->{cmdline}]\n"; + print STDERR "Executing [$self->{cmdline}]\n"; my ($retval, $stdout, $stderr) = $self->execute(60, undef, @cmd); $self->{output} = $stderr; $self->{output} .= ' ' if length $self->{output}; @@ -73,7 +73,7 @@ sub postprocess { $self->{output} = "[$self->{output}]\n"; } - print "Executing gdb\n"; + print STDERR "Executing gdb\n"; my ($exitval, $stdout, $stderr); my $ulimits = "ulimit -f 2000; ulimit -t 8; ulimit -u 200"; diff --git a/applets/compiler_vm/guest/lib/Languages/_default.pm b/applets/compiler_vm/guest/lib/Languages/_default.pm index 294a30c1..042f37b2 100755 --- a/applets/compiler_vm/guest/lib/Languages/_default.pm +++ b/applets/compiler_vm/guest/lib/Languages/_default.pm @@ -75,7 +75,7 @@ sub execute { $stdin //= ''; - print "execute ($timeout) [$stdin] @cmdline\n"; + print STDERR "execute ($timeout) [$stdin] @cmdline\n"; my ($exitval, $stdout, $stderr) = eval { my ($stdout, $stderr); @@ -90,7 +90,7 @@ sub execute { } $Data::Dumper::Indent = 0; - print "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n"; + print STDERR "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n"; $Data::Dumper::Indent = 1; return ($exitval, $stdout, $stderr); diff --git a/applets/compiler_vm/guest/lib/Languages/java.pm b/applets/compiler_vm/guest/lib/Languages/java.pm index b5c365a6..b56cac01 100755 --- a/applets/compiler_vm/guest/lib/Languages/java.pm +++ b/applets/compiler_vm/guest/lib/Languages/java.pm @@ -28,7 +28,6 @@ sub postprocess { $self->{output} = "[$self->{output}]\n"; } - print "Executing java\n"; my $input_quoted = quotemeta $self->{input}; $input_quoted =~ s/\\"/"'\\"'"/g; my ($retval, $result) = $self->execute(60, "bash -c \"date -s \@$self->{date}; ulimit -t 5; echo $input_quoted | java prog $self->{arguments} > .output\""); diff --git a/applets/compiler_vm/host/bin/vm-exec b/applets/compiler_vm/host/bin/vm-exec index 713aa53f..0cde638b 100755 --- a/applets/compiler_vm/host/bin/vm-exec +++ b/applets/compiler_vm/host/bin/vm-exec @@ -21,7 +21,9 @@ use FindBin qw($RealBin); use lib "$RealBin/../lib"; use constant { - SERIAL_PORT => $ENV{PBOTVM_SERIAL} // 5555, + SERIAL => $ENV{PBOTVM_SERIAL} // 5555, + CID => $ENV{PBOTVM_CID} // 7, + VPORT => $ENV{PBOTVM_VPORT} // 5555, }; my $json = join ' ', @ARGV; @@ -41,10 +43,12 @@ if (not exists $data->{code}) { } # set any missing fields to default values -$data->{nick} //= 'vm'; -$data->{channel} //= 'vm'; -$data->{lang} //= 'c11'; -$data->{'vm-port'} //= SERIAL_PORT; +$data->{nick} //= 'vm'; +$data->{channel} //= 'vm'; +$data->{lang} //= 'c11'; +$data->{'vm-serial'} //= SERIAL; +$data->{'vm-cid'} //= CID; +$data->{'vm-vport'} //= VPORT; # parse -lang option if ($data->{code} =~ s/^-lang=([^ ]+)\s+//) { diff --git a/applets/compiler_vm/host/bin/vm-server b/applets/compiler_vm/host/bin/vm-server index 720a4bb2..f1be6a40 100755 --- a/applets/compiler_vm/host/bin/vm-server +++ b/applets/compiler_vm/host/bin/vm-server @@ -196,7 +196,7 @@ sub handle_client($client, $heartbeat) { if (time - $heartbeat > 5) { print "[$$] Lost heartbeat, ignoring compile attempt.\n"; - print $client "Recovering from previous snippet, try again soon.\n"; + print $client "Virtual machine is resetting, try again soon.\n"; last; } diff --git a/applets/compiler_vm/host/devices/add-all b/applets/compiler_vm/host/devices/add-all new file mode 100755 index 00000000..b32c11f2 --- /dev/null +++ b/applets/compiler_vm/host/devices/add-all @@ -0,0 +1,10 @@ +#!/bin/sh + +for script in add-* +do + if [ $script = 'add-all' ]; then + continue + fi + + ./$script +done diff --git a/applets/compiler_vm/host/devices/add-vsock b/applets/compiler_vm/host/devices/add-vsock new file mode 100755 index 00000000..80f5acc1 --- /dev/null +++ b/applets/compiler_vm/host/devices/add-vsock @@ -0,0 +1,14 @@ +#!/bin/sh + +DOMAIN="${PBOTVM_DOMAIN:-pbot-vm}" +CID="${PBOTVM_CID:-7}" + +cat > vsock.xml < + + +EOF + +virsh attach-device --config $DOMAIN vsock.xml + +rm vsock.xml diff --git a/applets/compiler_vm/host/lib/Languages/_default.pm b/applets/compiler_vm/host/lib/Languages/_default.pm index e4eba9a2..cf22ddac 100755 --- a/applets/compiler_vm/host/lib/Languages/_default.pm +++ b/applets/compiler_vm/host/lib/Languages/_default.pm @@ -36,7 +36,9 @@ sub new { $self->{arguments} = $conf{arguments} // ''; $self->{factoid} = $conf{factoid}; $self->{'persist-key'} = $conf{'persist-key'}; - $self->{'vm-port'} = $conf{'vm-port'}; + $self->{'vm-serial'} = $conf{'vm-serial'}; + $self->{'vm-cid'} = $conf{'vm-cid'}; + $self->{'vm-vport'} = $conf{'vm-vport'}; $self->{default_options} = ''; $self->{cmdline} = 'echo Hello, world!'; @@ -91,13 +93,13 @@ sub preprocess_code { foreach my $ch (@chars) { given ($ch) { when ('\\') { - if($escaped == 0) { + if ($escaped == 0) { $escaped = 1; next; } } - if($state == NORMAL) { + if ($state == NORMAL) { when ($_ eq '"' and not $escaped) { $state = DOUBLE_QUOTED; } @@ -112,13 +114,13 @@ sub preprocess_code { } } - if($state == DOUBLE_QUOTED) { + if ($state == DOUBLE_QUOTED) { when ($_ eq '"' and not $escaped) { $state = NORMAL; } } - if($state == SINGLE_QUOTED) { + if ($state == SINGLE_QUOTED) { when ($_ eq "'" and not $escaped) { $state = NORMAL; } @@ -151,10 +153,10 @@ sub postprocess_output { my $boutput = ""; my $active_position = 0; $self->{output} =~ s/\n$//; - while($self->{output} =~ /(.)/gms) { + while ($self->{output} =~ /(.)/gms) { my $c = $1; - if($c eq "\b") { - if(--$active_position <= 0) { + if ($c eq "\b") { + if (--$active_position <= 0) { $active_position = 0; } next; @@ -237,19 +239,19 @@ sub show_output { exit 0; } - if($self->{channel} =~ m/^#/ and length $output > 22 and open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.last-output") { + if ($self->{channel} =~ m/^#/ and length $output > 22 and open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.last-output") { my $last_output; my $time = ; - if(gettimeofday - $time > 60 * 4) { + if (gettimeofday - $time > 60 * 4) { close LOG; } else { - while(my $line = ) { + while (my $line = ) { $last_output .= $line; } close LOG; - if((not $self->{factoid}) and defined $last_output and $last_output eq $output) { + if ((not $self->{factoid}) and defined $last_output and $last_output eq $output) { print "Same output.\n"; exit 0; } @@ -279,7 +281,7 @@ sub paste_ixio { my %post = ('f:1' => $text); my $response = $ua->post("http://ix.io", \%post); - if(not $response->is_success) { + if (not $response->is_success) { return "error pasting: " . $response->status_line; } @@ -306,7 +308,7 @@ sub paste_0x0 { Content_Type => 'form-data' ); - if(not $response->is_success) { + if (not $response->is_success) { return "error pasting: " . $response->status_line; } @@ -316,22 +318,72 @@ sub paste_0x0 { return $result; } +sub connect_vsock { + my ($self) = @_; + + return undef if not $self->{'vm-cid'}; + + print STDERR "Connecting to remote VM socket CID $self->{'vm-cid'} port $self->{'vm-vport'}\n"; + + my $command = "socat - VSOCK-CONNECT:$self->{'vm-cid'}:$self->{'vm-vport'}"; + + my ($pid, $input, $output) = eval { + my $pid = open2(my $output, my $input, $command); + return ($pid, $input, $output); + }; + + if ($@) { + print STDERR "Failed to connect to VM socket: $@\n"; + return undef; + } + + if (not defined $pid) { + print STDERR "Failed to connect to VM socket: $!\n"; + return undef; + } + + return ($input, $output); +} + +sub connect_serial { + my ($self) = @_; + + print STDERR "Connecting to remote VM serial port $self->{'vm-serial'}\n"; + + my $vm = IO::Socket::INET->new( + PeerAddr => '127.0.0.1', + PeerPort => $self->{'vm-serial'}, + Proto => 'tcp', + Type => SOCK_STREAM + ); + + # return same $vm handle for ($input, $output) + return ($vm, $vm); +} + sub execute { my ($self) = @_; - my ($vm, $vm_output, $pid); + my ($input, $output, $pid); - delete $self->{local}; - if(exists $self->{local} and $self->{local} != 0) { + if (defined $self->{local} and $self->{local} != 0) { print "Using local machine instead of virtual machine\n"; - $pid = open2($vm_output, $vm, './compiler_vm_server.pl') || die "repl failed: $@\n"; # XXX + $pid = open2($output, $input, './compiler_vm_server.pl') || die "repl failed: $@\n"; # XXX adapt vm-exec into local-exec print "Started fake-vm, pid: $pid\n"; } else { - print STDERR "Connecting to remote VM port $self->{'vm-port'}\n"; - $vm = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $self->{'vm-port'}, Proto => 'tcp', Type => SOCK_STREAM); - die "Could not create connection to VM: $!" unless $vm; + # attempt preferred VSOCK connection + ($input, $output) = $self->connect_vsock(); + + # fallback to serial + if (not defined $input) { + ($input, $output) = $self->connect_serial(); + } + + if (not defined $input) { + die "Could not create connection to VM: $!"; + } + print STDERR "Connected to VM.\n"; - $vm_output = $vm; } my $date = time; @@ -414,38 +466,38 @@ sub execute { while ($chunks_sent < $length) { my $chunk = substr $compile_json, $chunks_sent, $chunk_size; - #print LOG "Sending chunk [$chunk]\n"; + $chunks_sent += length $chunk; - my $ret = syswrite($vm, $chunk); + my $ret = syswrite($input, $chunk); if (not defined $ret) { + print STDERR "Error sending: $!\n"; print LOG "Error sending: $!\n"; last; } if ($ret == 0) { + print STDERR "Sent 0 bytes. Sleep 1 sec and try again\n"; print LOG "Sent 0 bytes. Sleep 1 sec and try again\n"; sleep 1; next; } $sent += $ret; - print LOG "Sent $ret bytes, so far $sent ...\n"; } - #print LOG "Done sending!\n"; close LOG; my $result = ""; my $got_result = 0; - while(my $line = <$vm_output>) { + while (my $line = <$output>) { utf8::decode($line); $line =~ s/[\r\n]+$//; last if $line =~ /^result:end$/; - if($line =~ /^result:/) { + if ($line =~ /^result:/) { $line =~ s/^result://; my $compile_out = decode_json($line); $result .= "$compile_out->{result}\n"; @@ -453,12 +505,12 @@ sub execute { next; } - if($got_result) { + if ($got_result) { $result .= "$line\n"; } } - close $vm; + close $input; waitpid($pid, 0) if defined $pid; $self->{output} = $result; @@ -555,10 +607,10 @@ sub process_interactive_edit { while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} my $copy_code; - if($subcode =~ s/^\s*copy\s+(\S+)\s*//) { + if ($subcode =~ s/^\s*copy\s+(\S+)\s*//) { my $copy = $1; - if(open LOG, "< $RealBin/../history/$copy-$self->{lang}.hist") { + if (open LOG, "< $RealBin/../history/$copy-$self->{lang}.hist") { $copy_code = ; close LOG; goto COPY_ERROR if not $copy_code;; @@ -579,12 +631,12 @@ sub process_interactive_edit { $self->{copy_code} = 1; } - if($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { + if ($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { $self->{channel} = $1; } - if(open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.hist") { - while(my $line = ) { + if (open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.hist") { + while (my $line = ) { chomp $line; push @last_code, $line; } @@ -593,8 +645,8 @@ sub process_interactive_edit { unshift @last_code, $copy_code if defined $copy_code; - if($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { - if(defined $last_code[0]) { + if ($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { + if (defined $last_code[0]) { print "$last_code[0]\n"; } else { print "No recent code to show.\n" @@ -610,9 +662,9 @@ sub process_interactive_edit { my $got_undo = 0; my $last_keyword; - while($subcode =~ s/^\s*(and)?\s*undo//) { + while ($subcode =~ s/^\s*(and)?\s*undo//) { splice @last_code, 0, 1; - if(not defined $last_code[0]) { + if (not defined $last_code[0]) { print "No more undos remaining.\n"; exit 0; } else { @@ -622,17 +674,17 @@ sub process_interactive_edit { } } - while(1) { + while (1) { $got_sub = 0; $subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword; - if($subcode =~ m/^\s*(?:and\s+)?diff\b/i) { + if ($subcode =~ m/^\s*(?:and\s+)?diff\b/i) { $got_diff = 1; last; } - if($subcode =~ m/^\s*(?:and\s+)?(again|run|paste)\b/i) { + if ($subcode =~ m/^\s*(?:and\s+)?(again|run|paste)\b/i) { $self->{got_run} = lc $1; $self->{only_show} = 0; if ($prevchange) { @@ -643,7 +695,7 @@ sub process_interactive_edit { } } - if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { + if ($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { $last_keyword = 'remove'; my $modifier = 'first'; @@ -656,7 +708,7 @@ sub process_interactive_edit { my $text; - if(defined $e) { + if (defined $e) { $text = $e; $text =~ s/^'//; $text =~ s/'$//; @@ -668,7 +720,7 @@ sub process_interactive_edit { next; } - if($subcode =~ s/^\s*(and)?\s*prepend '//) { + if ($subcode =~ s/^\s*(and)?\s*prepend '//) { $last_keyword = 'prepend'; $subcode = "'$subcode"; @@ -676,7 +728,7 @@ sub process_interactive_edit { my $text; - if(defined $e) { + if (defined $e) { $text = $e; $text =~ s/^'//; $text =~ s/'$//; @@ -685,7 +737,7 @@ sub process_interactive_edit { $got_sub = 1; $got_changes = 1; - if(not defined $prevchange) { + if (not defined $prevchange) { print "No recent code to prepend to.\n"; exit 0; } @@ -700,7 +752,7 @@ sub process_interactive_edit { next; } - if($subcode =~ s/^\s*(and)?\s*append '//) { + if ($subcode =~ s/^\s*(and)?\s*append '//) { $last_keyword = 'append'; $subcode = "'$subcode"; @@ -708,7 +760,7 @@ sub process_interactive_edit { my $text; - if(defined $e) { + if (defined $e) { $text = $e; $text =~ s/^'//; $text =~ s/'$//; @@ -717,7 +769,7 @@ sub process_interactive_edit { $got_sub = 1; $got_changes = 1; - if(not defined $prevchange) { + if (not defined $prevchange) { print "No recent code to append to.\n"; exit 0; } @@ -732,7 +784,7 @@ sub process_interactive_edit { next; } - if($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { + if ($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { $last_keyword = 'replace'; $got_sub = 1; my $modifier = 'first'; @@ -745,7 +797,7 @@ sub process_interactive_edit { my ($from, $to); my ($e, $r) = extract_delimited($subcode, "'"); - if(defined $e) { + if (defined $e) { $from = $e; $from =~ s/^'//; $from =~ s/'$//; @@ -760,7 +812,7 @@ sub process_interactive_edit { ($e, $r) = extract_delimited($subcode, "'"); - if(defined $e) { + if (defined $e) { $to = $e; $to =~ s/^'//; $to =~ s/'$//; @@ -795,7 +847,7 @@ sub process_interactive_edit { next; } - if($subcode =~ m/^\s*(and)?\s*s\/.*\//) { + if ($subcode =~ m/^\s*(and)?\s*s\/.*\//) { $last_keyword = undef; $got_sub = 1; $subcode =~ s/^\s*(and)?\s*s//; @@ -803,7 +855,7 @@ sub process_interactive_edit { my ($regex, $to); my ($e, $r) = extract_delimited($subcode, '/'); - if(defined $e) { + if (defined $e) { $regex = $e; $regex =~ s/^\///; $regex =~ s/\/$//; @@ -815,7 +867,7 @@ sub process_interactive_edit { ($e, $r) = extract_delimited($subcode, '/'); - if(defined $e) { + if (defined $e) { $to = $e; $to =~ s/^\///; $to =~ s/\/$//; @@ -828,11 +880,11 @@ sub process_interactive_edit { my $suffix; $suffix = $1 if $subcode =~ s/^([^ ]+)//; - if(length $suffix and $suffix =~ m/[^gi]/) { + if (length $suffix and $suffix =~ m/[^gi]/) { print "Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n"; exit 0; } - if(defined $prevchange) { + if (defined $prevchange) { $code = $prevchange; } else { print "No recent code to change.\n"; @@ -842,29 +894,29 @@ sub process_interactive_edit { my $ret = eval { my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after); - if(not length $suffix) { + if (not length $suffix) { $ret = $code =~ s|$regex|$to|; ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); $before = $`; $after = $'; - } elsif($suffix =~ /^i$/) { + } elsif ($suffix =~ /^i$/) { $ret = $code =~ s|$regex|$to|i; ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); $before = $`; $after = $'; - } elsif($suffix =~ /^g$/) { + } elsif ($suffix =~ /^g$/) { $ret = $code =~ s|$regex|$to|g; ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); $before = $`; $after = $'; - } elsif($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { + } elsif ($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { $ret = $code =~ s|$regex|$to|gi; ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); $before = $`; $after = $'; } - if($ret) { + if ($ret) { $code =~ s/\$1/$a/g; $code =~ s/\$2/$b/g; $code =~ s/\$3/$c/g; @@ -881,7 +933,7 @@ sub process_interactive_edit { return $ret; }; - if($@) { + if ($@) { my $error = $@; $error =~ s/ at .* line \d+\.\s*$//; print "$error\n"; @@ -916,13 +968,13 @@ sub process_interactive_edit { my $to = $replacement->{'to'}; my $modifier = $replacement->{'modifier'}; - if(defined $previous_from) { - if($previous_from eq $from and $previous_modifier =~ /^\d+$/) { + if (defined $previous_from) { + if ($previous_from eq $from and $previous_modifier =~ /^\d+$/) { $modifier -= $modifier - $previous_modifier; } } - if(defined $prevchange) { + if (defined $prevchange) { $code = $prevchange; } else { print "No recent code to change.\n"; @@ -936,45 +988,45 @@ sub process_interactive_edit { $first_char = $1 if $from =~ m/^(.)/; $last_char = $1 if $from =~ m/(.)$/; - if($first_char =~ /\W/) { + if ($first_char =~ /\W/) { $first_bound = '.?'; } else { $first_bound = '\b'; } - if($last_char =~ /\W/) { + if ($last_char =~ /\W/) { $last_bound = '.?'; } else { $last_bound = '\b'; } - if($modifier eq 'all') { - if($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { + if ($modifier eq 'all') { + if ($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { $got_change = 1; } - } elsif($modifier eq 'last') { - if($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { + } elsif ($modifier eq 'last') { + if ($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { $got_change = 1; } } else { my $count = 0; my $unescaped = $from; $unescaped =~ s/\\//g; - if($code =~ s/($first_bound)$from($last_bound)/if(++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { + if ($code =~ s/($first_bound)$from($last_bound)/if (++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { $got_change = 1; } } return $got_change; }; - if($@) { + if ($@) { my $error = $@; $error =~ s/ at .* line \d+\.\s*$//; print "$error\n"; exit 0; } - if($ret) { + if ($ret) { $got_sub = 1; $got_changes = 1; } @@ -984,7 +1036,7 @@ sub process_interactive_edit { $previous_modifier = $modifier; } - if(not $got_changes) { + if (not $got_changes) { print "No replacements made.\n"; exit 0; } @@ -1003,7 +1055,7 @@ sub process_interactive_edit { } unless (($self->{got_run} or $got_diff) and not $got_changes) { - if($unshift_last_code) { + if ($unshift_last_code) { unshift @last_code, $code; } @@ -1011,7 +1063,7 @@ sub process_interactive_edit { my $i = 0; foreach my $line (@last_code) { - last if(++$i > $self->{max_history}); + last if (++$i > $self->{max_history}); print LOG "$line\n"; } @@ -1019,13 +1071,13 @@ sub process_interactive_edit { } if ($got_diff) { - if($#last_code < 1) { + if ($#last_code < 1) { print "Not enough recent code to diff.\n" } else { use Text::WordDiff; my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' }); - if($diff !~ /(?:|)/) { + if ($diff !~ /(?:|)/) { $diff = "No difference."; } else { $diff =~ s/(.*?)(\s+)<\/del>/$1<\/del>$2/g; diff --git a/doc/VirtualMachine.md b/doc/VirtualMachine.md index 8ab31b49..7f5229f0 100644 --- a/doc/VirtualMachine.md +++ b/doc/VirtualMachine.md @@ -19,6 +19,20 @@ Some quick terminology: The commands below will be prefixed with `host$` or `guest$` to reflect where the command should be executed. +Many commands can be configured with environment variables. If a variable is +not defined, a sensible default value will be used. + +Environment variable | Default value | Description +--- | --- | --- +PBOTVM_DOMAIN | `pbot-vm` | The libvirt domain identifier +PBOTVM_SERVER | `9000` | `vm-server` port for incoming `vm-client` commands +PBOTVM_SERIAL | `5555` | TCP port for serial communication +PBOTVM_HEART | `5556` | TCP port for serial heartbeats +PBOTVM_CID | `7` | Context ID for VM socket (if using VSOCK) +PBOTVM_VPORT | `5555` | VM socket service port (if using VSOCK) +PBOTVM_TIMEOUT | `10` | Duration before command times out (in seconds) +PBOTVM_NOREVERT | not set | If set then the VM will not revert to previous snapshot + ## Initial virtual machine set-up These steps need to be done only once during the first-time set-up. @@ -105,7 +119,7 @@ of choice. * Click `Partition disks`. Don't change anything. Click `Done`. * Click `Root account`. Click `Enable root account`. Set a password. Click `Done`. - * Click `User creation`. Create a new user. Skip Fullname and set Username to `vm`. Untick `Add to wheel` or `Set as administrator`. Untick `Require password`. + * Click `User creation`. Create a new user. Skip Fullname and set Username to `vm`. Untick `Add to wheel` or `Set as administrator`. Untick `Require password`. Click `Done`. * Wait until `Software selection` is done processing and is no longer greyed out. Click it. Change install from `Server` to `Minimal`. Click `Done`. * Click `Begin installation`. @@ -135,6 +149,65 @@ If you later want to change the serial ports or the TCP ports, execute the comma `virsh edit pbot-vm` on the host. This will open the `pbot-vm` XML configuration in your default system editor. Find the `` tags and edit their attributes. +#### Set up virtio-vsock +VM sockets (AF_VSOCK) are a Linux-specific feature (at the time of this writing). They +are the preferred way for PBot to communicate with the PBot VM Guest server. Serial communication +has several limitations. See https://vmsplice.net/~stefan/stefanha-kvm-forum-2015.pdf for an excellent +overview. + +To use VM sockets with QEMU and virtio-vsock, you need: + +* a Linux hypervisor with kernel 4.8+ +* a Linux virtual machine on that hypervisor with kernel 4.8+ +* QEMU 2.8+ on the hypervisor, running the virtual machine +* [socat](http://www.dest-unreach.org/socat/) version 1.7.4+ + +If you do not meet these requirements, the PBot VM will fallback to using serial communication. You may +explicitly disable VM sockets by setting `PBOTVM_CID=0`. You can skip reading the rest of this section. + +If you do want to use VM sockets, read on. + +First, ensure the `vhost_vsock` Linux kernel module is loaded on the host: + + host$ lsmod | grep vsock + vhost_vsock 24576 1 + vsock 45056 2 vmw_vsock_virtio_transport_common,vhost_vsock + vhost 53248 2 vhost_vsock,vhost_net + +If the module is not loaded, load it with: + + host$ sudo modprobe vhost_vsock + +Once the module is loaded, you should have the following character devices: + + host$ ls -l /dev/vhost-vsock + crw------- 1 root root 10, 53 May 4 11:55 /dev/vhost-vsock + host$ ls -l /dev/vsock + crw-rw-rw- 1 root root 10, 54 May 4 11:55 /dev/vsock + +A VM sockets address is comprised of a context ID (CID) and a port; just like an IP address and TCP/UDP port. +The CID is represented using an unsigned 32-bit integer. It identifies a given machine as either a hypervisor +or a virtual machine. Several addresses are reserved, including 0, 1, and the maximum value for a 32-bit +integer: 0xffffffff. The hypervisor is always assigned a CID of 2, and VMs can be assigned any CID between 3 +and 0xffffffff — 1. + +We must attach a `vhost-vsock-pci` device to the guest to enable VM sockets communication. +Each VM on a hypervisor must have a unique context ID (CID). Each service within the VM must +have a unique port. The PBot VM Guest defaults to `7` for the CID and `5555` for the port. + +While still in the `applets/compiler_vm/host/devices` directory, run the `add-vsock` script: + + host$ ./add-vsock + +or to configure a different CID: + + host$ PBOTVM_CID=42 ./add-vsock + +In the VM guest (once it reboots), there should be a `/dev/vsock` device: + + guest$ ls -l /dev/vsock + crw-rw-rw- 1 root root 10, 55 May 4 13:21 /dev/vsock + #### Reboot virtual machine Once the Linux installation completes inside the virtual machine, click the `Reboot` button in the installer window. Login as `root` when the virtual machine boots back up. @@ -145,6 +218,10 @@ in the virtual machine. Use the `dnf search` command or your distribution's docu to find packages. I will soon make available a script to install all package necessary for all languages supported by PBot. +To make use of VM sockets, install the `socat` package: + + guest$ dnf install socat + For the C programming language you will need at least these: guest$ dnf install libubsan libasan gdb gcc clang @@ -153,10 +230,10 @@ For the C programming language you will need at least these: Now we need to install Perl on the guest. This allows us to run the PBot VM Guest server script. - guest$ dnf install perl-interpreter perl-lib perl-IPC-Run perl-JSON-XS perl-English + guest$ dnf install perl-interpreter perl-lib perl-IPC-Run perl-JSON-XS perl-English perl-IPC-Shareable That installs the minium packages for the Perl interpreter (note we used `perl-interpreter` instead of `perl`), -as well as the Perl `lib`, `IPC::Run`, `JSON::XS` and `English` modules. +as well as a few Perl modules. #### Install PBot VM Guest Next we install the PBot VM Guest server script that fosters communication between the virtual machine guest @@ -237,18 +314,8 @@ This will start a TCP server on port `9000`. It will listen for incoming command pass them along to the virtual machine's TCP serial port `5555`. It will also monitor the heartbeat port `5556` to ensure the PBot VM Guest server is alive. -You may override any of the defaults by setting environment variables. - -Environment variable | Default value | Description ---- | --- | --- -PBOTVM_DOMAIN | `pbot-vm` | The libvirt domain identifier -PBOTVM_SERVER | `9000` | `vm-server` port for incoming `vm-client` commands -PBOTVM_SERIAL | `5555` | TCP port for serial communication -PBOTVM_HEART | `5556` | TCP port for heartbeats -PBOTVM_TIMEOUT | `10` | Duration before command times out (in seconds) -PBOTVM_NOREVERT | not set | If set then the VM will not revert to previous snapshot - -For example, to use `other-vm` with a longer `30` second timeout, on different serial and heartbeat ports: +You may override any of the defaults by setting environment variables. For example, to +use `other-vm` with a longer `30` second timeout, on different serial and heartbeat ports: host$ PBOTVM_DOMAIN="other-vm" PBOTVM_SERVER=9001 PBOTVM_SERIAL=7777 PBOTVM_HEART=7778 PBOTVM_TIMEOUT=30 ./vm-server