pbot/applets/pbot-vm/host/bin/vm-server

#!/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 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};
    info("Reverting vm...\n");
    execute("perl vm-exec -revert $input", 1000);
    info("Reverted.\n");
}

sub vm_check_health($input) {
    info("Checking health...\n");
    my ($ret, $result) = execute("perl vm-exec -health $input", 2);
    info("$result\n") if length $result;
    return ($ret, $result);
}

sub execute($command, $timeout = COMPILE_TIMEOUT) {
    info("execute ($command)\n", 1024);

    # to get $? from pipe
    local $SIG{CHLD} = 'DEFAULT';

    my $pid = open(my $fh, '-|', split / /, encode('UTF-8', $command));

    if (not defined $pid) {
        info("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;
    info("Server $0 accepting clients at :$port\n");
    return $server;
}

sub do_server() {
    info("Starting PBot VM Server on port " . SERVER_PORT . "\n");
    my $server = eval { server_listen(SERVER_PORT) };

    if ($@) {
        info($@);
        return;
    }

    while (my $client = $server->accept) {
        info('-' x 20 . "\n");
        my $hostinfo = gethostbyaddr($client->peeraddr);
        info("Connect from " . $client->peerhost . "\n");
        handle_client($client);
    }

    info("Shutting down server.\n");
}

sub handle_client($client) {
    my ($timed_out, $killed) = (0, 0);

    my $r = fork;

    if (not defined $r) {
        info("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;

            info("Read [" . Dumper($input) . "]\n");

            # check health
            my ($health, $health_message) = vm_check_health($input);

            if ($health == 2) {
                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) {
                info("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+$//;
            info("Ret: $ret; result: [" . Dumper($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
    info($@) if $@;

    alarm 0;
    close $client;

    info("timed out: $timed_out; killed: $killed\n");

    if ($timed_out || $killed) {
        vm_revert($input);
    }

    # child done
    info("client exit\n");
    info("=" 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();