mirror of
https://github.com/pragma-/pbot.git
synced 2024-12-24 11:42:35 +01:00
17b69f04ff
* replace heartbeat with health-check * instead of steady stream of newlines every 5s, now awaits input and responds with `vmstat` output * more reliably use host/config/vm-exec.json to get libvirt domain name for snapshot-revert, server address, serial ports, vagrant setting, etc * use iptables/nftables to disable networking * added guest/bin/disable-network-[iptables,nftables] * added guest/bin/enable-network-[iptables,nftables] * replace ugly ___OUTPUT___ texts in sh, bash, ksh, zsh languages * documentation updates and tweaks
234 lines
5.4 KiB
Perl
Executable File
234 lines
5.4 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# File: vm-server
|
|
#
|
|
# Purpose: The PBot Host Server manages the guest virtual machine state and
|
|
# listens for incoming commands from vm-client. Invokes vm-exec to send
|
|
# commands to the PBot Guest Server (guest-server).
|
|
|
|
# SPDX-FileCopyrightText: 2021-2024 Pragmatic Software <pragma78@gmail.com>
|
|
# SPDX-License-Identifier: MIT
|
|
|
|
use 5.020;
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use feature qw(signatures);
|
|
no warnings qw(experimental::signatures);
|
|
|
|
use IO::Socket;
|
|
use Net::hostent;
|
|
use IPC::Shareable;
|
|
use Time::HiRes qw/gettimeofday/;
|
|
use Encode;
|
|
|
|
use constant {
|
|
SERVER_PORT => $ENV{PBOTVM_PORT} // 9000,
|
|
COMPILE_TIMEOUT => $ENV{PBOTVM_TIMEOUT} // 10,
|
|
};
|
|
|
|
sub vm_revert($input) {
|
|
return if $ENV{PBOTVM_NOREVERT};
|
|
print "Reverting vm...\n";
|
|
execute("perl vm-exec -revert $input", 1000);
|
|
print "Reverted.\n";
|
|
}
|
|
|
|
sub vm_check_health($input) {
|
|
print "Checking health...\n";
|
|
my ($ret, $result) = execute("perl vm-exec -health $input", 2);
|
|
print "$result\n" if length $result;
|
|
return ($ret, $result);
|
|
}
|
|
|
|
sub execute($command, $timeout = COMPILE_TIMEOUT) {
|
|
print "execute ($command)\n";
|
|
|
|
# to get $? from pipe
|
|
local $SIG{CHLD} = 'DEFAULT';
|
|
|
|
my $pid = open(my $fh, '-|', split / /, encode('UTF-8', $command));
|
|
|
|
if (not defined $pid) {
|
|
print "Couldn't fork: $!\n";
|
|
return (-13, "[Fatal error]");
|
|
}
|
|
|
|
my $result = eval {
|
|
my $output = '';
|
|
local $SIG{ALRM} = sub { kill 9, $pid; die "Timed-out: $output\n"; };
|
|
alarm($timeout);
|
|
|
|
while (my $line = decode('UTF-8', <$fh>)) {
|
|
$output .= $line;
|
|
}
|
|
|
|
return $output;
|
|
};
|
|
|
|
alarm 0;
|
|
close $fh;
|
|
|
|
my $ret = $? >> 8;
|
|
|
|
if (my $exception = $@) {
|
|
# handle time-out exception
|
|
if ($exception =~ /Timed-out: (.*)/) {
|
|
return (-13, "[Timed-out] $1");
|
|
}
|
|
|
|
# propagate unhandled exception
|
|
die $exception;
|
|
}
|
|
|
|
return ($ret, $result);
|
|
}
|
|
|
|
sub server_listen($port) {
|
|
my $server = IO::Socket::INET->new (
|
|
Proto => 'tcp',
|
|
LocalPort => $port,
|
|
Listen => SOMAXCONN,
|
|
ReuseAddr => 1,
|
|
Reuse => 1,
|
|
);
|
|
die "Can't setup server: $!" unless $server;
|
|
print "Server $0 accepting clients at :$port\n";
|
|
return $server;
|
|
}
|
|
|
|
sub do_server() {
|
|
print "Starting PBot VM Server on port " . SERVER_PORT . "\n";
|
|
my $server = eval { server_listen(SERVER_PORT) };
|
|
|
|
if ($@) {
|
|
print STDERR $@;
|
|
return;
|
|
}
|
|
|
|
while (my $client = $server->accept) {
|
|
print '-' x 20, "\n";
|
|
my $hostinfo = gethostbyaddr($client->peeraddr);
|
|
print "Connect from ", $client->peerhost, " at ", scalar localtime, "\n";
|
|
handle_client($client);
|
|
}
|
|
|
|
print "Shutting down server.\n";
|
|
}
|
|
|
|
sub handle_client($client) {
|
|
my ($timed_out, $killed) = (0, 0);
|
|
|
|
my $r = fork;
|
|
|
|
if (not defined $r) {
|
|
print "Could not fork to handle client: $!\n";
|
|
print $client "Fatal error.\n";
|
|
close $client;
|
|
return;
|
|
}
|
|
|
|
if ($r > 0) {
|
|
# nothing for parent to do with client
|
|
close $client;
|
|
return;
|
|
}
|
|
|
|
$client->autoflush(1);
|
|
|
|
my $input = eval {
|
|
# give client 5 seconds to send a line
|
|
local $SIG{ALRM} = sub { die "Client I/O timed-out\n"; };
|
|
alarm 5;
|
|
|
|
my $input;
|
|
|
|
while ($input = decode('UTF-8', <$client>)) {
|
|
$input =~ s/[\r\n]+$//;
|
|
next if $input =~ m/^\s*$/;
|
|
|
|
# give client 5 more seconds
|
|
alarm 5;
|
|
|
|
print "[$$] Read [$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";
|
|
print $client "Virtual machine is offline.\n";
|
|
last;
|
|
}
|
|
|
|
if ($health == 1 || $health == -13) {
|
|
print "[$$] VM not responding to health check, ignoring compile attempt.\n";
|
|
print $client "Virtual machine is temporarily unavailable, try again soon.\n";
|
|
last;
|
|
}
|
|
|
|
if ($health != 0) {
|
|
if (length $health_message) {
|
|
print $client $health_message;
|
|
} else {
|
|
print $client "Virtual machine is misbehaving, try again soon.\n";
|
|
}
|
|
last;
|
|
}
|
|
|
|
# disable client time-out
|
|
alarm 0;
|
|
|
|
my ($ret, $result) = execute("perl vm-exec $input");
|
|
|
|
$result =~ s/\s+$//;
|
|
print "Ret: $ret; result: [$result]\n";
|
|
|
|
if ($result =~ m/\[Killed\]$/) {
|
|
$killed = 1;
|
|
$ret = -14;
|
|
}
|
|
|
|
if ($ret == -13 && $result =~ m/\[Timed-out\]/) {
|
|
$timed_out = 1;
|
|
}
|
|
|
|
print $client encode('UTF-8', $result . "\n");
|
|
last;
|
|
}
|
|
|
|
return $input;
|
|
};
|
|
|
|
# print client time-out exception
|
|
print "[$$] $@" if $@;
|
|
|
|
alarm 0;
|
|
close $client;
|
|
|
|
print "[$$] timed out: $timed_out; killed: $killed\n";
|
|
|
|
if ($timed_out || $killed) {
|
|
vm_revert($input);
|
|
}
|
|
|
|
# child done
|
|
print "[$$] client exit\n";
|
|
print "=" x 20, "\n";
|
|
exit;
|
|
}
|
|
|
|
sub main() {
|
|
binmode(STDOUT, ':utf8');
|
|
binmode(STDERR, ':utf8');
|
|
|
|
# let OS clean-up child exits
|
|
$SIG{CHLD} = 'IGNORE';
|
|
|
|
# start server
|
|
do_server();
|
|
}
|
|
|
|
main();
|