isotovideo

#!/usr/bin/perl -w
# Copyright © 2009-2013 Bernhard M. Wiedemann
# Copyright © 2012-2016 SUSE LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, see <http://www.gnu.org/licenses/>.
#

=head1 SYNOPSIS

isotovideo [OPTIONS] [TEST PARAMETER]

Parses vars.json and tests the given assets/ISOs.

=head1 OPTIONS

=over 4

=item B<-d, --debug>

Enable direct output to STDERR instead of autoinst-log.txt

=item B<-v, --version>

Show the current program version and test API version

=item B<-h, -?, --help>

Show this help.

=head1 TEST PARAMETER

All additional command line arguments specified in the C<key=value> format are
parsed as test parameters which take precedence over the settings in the
vars.json file. Lower case key names are transformed into upper case
automatically for convenience.

=cut

use strict;

my $installprefix;    # $bmwqemu::scriptdir

BEGIN {
    # the following line is modified during make install
    $installprefix = undef;

    my ($wd) = $0 =~ m-(.*)/-;
    $wd ||= '.';
    $installprefix ||= $wd;
    unshift @INC, "$installprefix";
}

# this shall be an integer increased by every change of the API
# either to the worker or the tests
our $INTERFACE = 12;

use bmwqemu;
use needle;
use autotest;
use commands;
use distribution;
use testapi 'diag';
use Getopt::Long;
require IPC::System::Simple;
use autodie ':all';
no autodie 'kill';
use Cwd;
use POSIX qw(:sys_wait_h _exit);
use Carp 'cluck';
use Time::HiRes qw(gettimeofday tv_interval sleep time);
use File::Spec;
use File::Path;
Getopt::Long::Configure("no_ignore_case");

my %options;
# global exit status
my $r = 1;

sub usage {
    my ($return_code) = @_;
    $r = $return_code;
    eval { use Pod::Usage; pod2usage($return_code); };
    if ($@) {
        die "cannot display help, install perl(Pod::Usage)\n";
    }
}

sub _get_version_string {
    my $thisversion = qx{git rev-parse HEAD};
    chomp $thisversion;
    return "Current version is $thisversion [interface v$INTERFACE]";
}

sub version {
    print _get_version_string() . "\n";
    exit 0;
}

GetOptions(\%options, 'debug|d', 'help|h|?', 'version|v') or usage(1);
usage(0)  if $options{help};
version() if $options{version};

diag(_get_version_string());

# enable debug default when started from a tty
$bmwqemu::direct_output = $options{debug};

# whether tests completed (or we bailed due to a failed 'fatal' test)
my $completed = 0;

select(STDERR);
$| = 1;
select(STDOUT);    # default
$| = 1;

$bmwqemu::scriptdir = $installprefix;
bmwqemu::init();

for my $arg (@ARGV) {
    if ($arg =~ /^([[:alnum:]_\[\]\.]+)=(.+)/) {
        my $key = uc $1;
        $bmwqemu::vars{$key} = $2;
        diag("Setting forced test parameter $key -> $2");
    }
}

# Sanity checks
die "CASEDIR environment variable not set, unknown test case directory" if !defined $bmwqemu::vars{CASEDIR};
die "No scripts in $bmwqemu::vars{CASEDIR}" if !-e "$bmwqemu::vars{CASEDIR}";

my $cpid;
my $testpid;
my $cfd;

my $loop = 1;

sub kill_commands {
    return unless $cpid;
    # create a copy as cpid is overwritten by SIGCHLD
    my $pid = $cpid;
    if (kill('TERM', $pid)) {
        diag "awaiting death of commands process";
        my $ret = waitpid($pid, 0);
        diag "commands process exited: $ret";
    }
    $cpid = 0;
}

sub kill_autotest {
    return unless $testpid;
    # create a copy as cpid is overwritten by SIGCHLD
    my $pid = $testpid;
    if (kill('TERM', $pid)) {
        diag "awaiting death of testpid $pid";
        my $ret = waitpid($pid, 0);
        diag "test process exited: $ret";
    }
    $testpid = 0;
}

sub kill_backend {
    if (defined $bmwqemu::backend && $bmwqemu::backend->{backend_pid}) {
        # save the pid in a scalar - signal handlers will reset it
        my $bpid = $bmwqemu::backend->{backend_pid};
        diag "killing backend process $bpid";
        kill('-TERM', $bpid);
        waitpid($bpid, 0);
        diag("done with backend process");
        $bmwqemu::backend->{backend_pid} = 0;
    }
}

sub signalhandler {

    my ($sig) = @_;
    diag("signalhandler got $sig - loop $loop");
    if ($loop) {
        $loop = 0;
        return;
    }
    kill_backend;
    kill_commands;
    kill_autotest;
    _exit(1);
}

sub signalhandler_chld {

    while ((my $child = waitpid(-1, WNOHANG)) > 0) {
        if ($child == $cpid) {
            diag("commands webserver died");
            $loop = 0;
            $cpid = 0;
            next;
        }
        if ($bmwqemu::backend->{backend_pid} && $child == $bmwqemu::backend->{backend_pid}) {
            diag("backend $child died");
            $bmwqemu::backend->{backend_pid} = 0;
            $loop = 0;
            next;
        }
        if ($child == $testpid) {
            diag("tests died");
            $testpid = 0;
            $loop    = 0;
            next;
        }
        diag("unknown child $child died");
    }
}

our $test_git_hash;
our $needles_git_hash;

sub init_backend {
    my ($name) = @_;
    $bmwqemu::vars{BACKEND} ||= "qemu";

    # make sure the needles are initialized
    my $needles_dir = $bmwqemu::vars{PRODUCTDIR} . '/needles';
    needle::init($needles_dir);
    $needles_git_hash = calculate_git_hash($needles_dir);
    $bmwqemu::vars{NEEDLES_GIT_HASH} = $needles_git_hash;

    $bmwqemu::backend = backend::driver->new($bmwqemu::vars{BACKEND});
    return $bmwqemu::backend;
}

sub calculate_git_hash {
    my ($git_repo_dir) = @_;
    my $dir = getcwd;
    chdir($git_repo_dir);
    chomp(my $git_hash = qx{git rev-parse HEAD});
    $git_hash ||= "UNKNOWN";
    chdir($dir);
    diag "git hash in $git_repo_dir: $git_hash";
    return $git_hash;
}

$SIG{TERM} = \&signalhandler;
$SIG{INT}  = \&signalhandler;
$SIG{HUP}  = \&signalhandler;
$SIG{CHLD} = \&signalhandler_chld;

# make sure all commands coming from the backend will not be in the
# developers's locale - but a defined english one. This is SUSE's
# default locale
$ENV{LC_ALL} = 'en_US.UTF-8';
$ENV{LANG}   = 'en_US.UTF-8';

# Try to load the main.pm from one of the following in this order:
#  - product dir
#  - casedir
#
# This allows further structuring the test distribution collections with
# multiple distributions or flavors in one repository.
$bmwqemu::vars{PRODUCTDIR} ||= $bmwqemu::vars{CASEDIR};

# as we are about to load the test modules store the git hash that has been
# used. If it is not a git repo fail silently, i.e. store an empty variable

$test_git_hash = calculate_git_hash($bmwqemu::vars{CASEDIR});
# TODO find a better place to store hash in than vars.json, see
# https://github.com/os-autoinst/os-autoinst/pull/393#discussion_r50143013
$bmwqemu::vars{TEST_GIT_HASH} = $test_git_hash;

# start the command fork before we get into the backend, the command child
# is not supposed to talk to the backend directly
($cpid, $cfd) = commands::start_server($bmwqemu::vars{QEMUPORT} + 1);

# set a default distribution if the tests don't have one
$testapi::distri = distribution->new;

# add lib of the test distributions - but only for main.pm not to pollute
# further dependencies (the tests get it through autotest)
my @oldINC = @INC;
unshift @INC, $bmwqemu::vars{CASEDIR} . '/lib';
require $bmwqemu::vars{PRODUCTDIR} . "/main.pm";
@INC = @oldINC;

if ($bmwqemu::vars{_EXIT_AFTER_SCHEDULE}) {
    diag 'Early exit has been requested with _EXIT_AFTER_SCHEDULE. Only evaluating test schedule.';
    exit 0;
}

testapi::init();

# init part
bmwqemu::save_vars();

my $testfd;
($testpid, $testfd) = autotest::start_process();

init_backend();

open(my $fd, ">", "os-autoinst.pid");
print $fd "$$\n";
close $fd;

if (!$bmwqemu::backend->_send_json({cmd => 'alive'})) {
    # might throw an exception
    $bmwqemu::backend->start_vm();
}

if ($ENV{RUN_VNCVIEWER}) {
    system("vncviewer -shared localhost:" . $bmwqemu::vars{VNC} . " -viewonly &");
}
if ($ENV{RUN_DEBUGVIEWER}) {
    system("$bmwqemu::scriptdir/debugviewer/debugviewer qemuscreenshot/last.png &");
}

use IO::Select;

my $s = IO::Select->new();
$s->add($testfd);
$s->add($cfd);
$s->add($bmwqemu::backend->{from_child});

# now we have everything, give the tests a go
$testfd->write("GO\n");

my $interactive = 0;
my $needinput   = 0;

my $current_test_name;

# timeout for the select (only set for check_screens)
my $timeout = undef;

# do not wait for timeout if set
my $no_wait = undef;

# marks a running check_screen
our $tags = undef;

# set to the socket we have to send replies to when the backend is done
my $backend_requester = undef;

my ($last_check_seconds, $last_check_microseconds) = gettimeofday;
sub _calc_check_delta {
    # an estimate of eternity
    my $delta = 100;
    if ($last_check_seconds) {
        $delta = tv_interval([$last_check_seconds, $last_check_microseconds], [gettimeofday]);
    }
    if ($delta > 0) {
        # sleep the remains of one second
        $timeout = 1 - $delta;
        $timeout = 0 if $timeout < 0;
    }
    else {
        $timeout = 0;
    }
    return $delta;
}

sub check_asserted_screen {
    my ($force_timeout, $no_wait) = @_;

    if ($no_wait) {
        # prevent CPU overload by waiting at least a little bit
        $timeout = 0.1;
    }
    else {
        _calc_check_delta;
        # come back later, avoid too often called function
        return if $timeout > 0.05;
    }
    ($last_check_seconds, $last_check_microseconds) = gettimeofday;
    my $rsp = $bmwqemu::backend->_send_json({cmd => 'check_asserted_screen'}) || {};
    # the test needs that information
    $rsp->{tags} = $tags;
    if ($rsp->{found}) {
        myjsonrpc::send_json($testfd, {ret => $rsp});
        $tags = $timeout = undef;
    }
    elsif ($rsp->{timeout}) {
        if ($interactive && !$force_timeout) {
            # now get fancy
            $bmwqemu::backend->_send_json({cmd => 'freeze_vm'});
            $rsp->{saveresult} = 1;
            myjsonrpc::send_json($testfd, {ret => $rsp});
            $needinput = 1;
        }
        else {
            myjsonrpc::send_json($testfd, {ret => $rsp});
            $tags = undef;
        }
        $timeout = undef;
    }
    else {
        _calc_check_delta unless $no_wait;
    }
}

$r = 0;

while ($loop) {
    my ($reads, $writes, $exceps) = IO::Select::select($s, undef, $s, $timeout);
    for my $r (@$reads) {
        my $rsp = myjsonrpc::read_json($r);
        if (!defined $rsp) {
            diag sprintf("THERE IS NOTHING TO READ %d %d %d", fileno($r), fileno($testfd), fileno($cfd));
            $r    = 1;
            $loop = 0;
            last;
        }
        if ($r == $bmwqemu::backend->{from_child}) {
            myjsonrpc::send_json($backend_requester, {ret => $rsp->{rsp}});
            $backend_requester = undef;
            next;
        }
        if ($rsp->{cmd} =~ m/^backend_(.*)/) {
            die "we need to implement a backend queue" if $backend_requester;
            $backend_requester = $r;
            my $cmd = $1;
            delete $rsp->{cmd};
            myjsonrpc::send_json($bmwqemu::backend->{to_child}, {cmd => $cmd, arguments => $rsp});
            next;
        }
        if ($rsp->{cmd} eq 'set_current_test') {
            $bmwqemu::backend->_send_json({cmd => 'set_serial_offset'});
            $current_test_name = $rsp->{name};
            myjsonrpc::send_json($r, {ret => 1});
            next;
        }
        if ($rsp->{cmd} eq 'tests_done') {
            $r         = $rsp->{died};
            $completed = $rsp->{completed};
            CORE::close($testfd);
            $testfd = undef;
            kill_autotest;
            $loop = 0;
            next;
        }
        if ($rsp->{cmd} eq 'check_screen') {
            $no_wait = $rsp->{no_wait} // 0;

            $tags = $bmwqemu::backend->_send_json(
                {
                    cmd       => 'set_tags_to_assert',
                    arguments => {
                        mustmatch => $rsp->{mustmatch},
                        timeout   => $rsp->{timeout},
                        check     => $rsp->{check}}})->{tags};
            next;
        }

        ##### HTTP commands
        if ($rsp->{cmd} eq 'status') {
            my $result = {tags => $tags, running => $current_test_name};
            $result->{interactive} = $interactive;
            $result->{needinput}   = $needinput;
            myjsonrpc::send_json($r, $result);
            next;
        }

        if ($rsp->{cmd} eq 'version') {
            my $result = {test_git_hash => $test_git_hash, needles_git_hash => $needles_git_hash, version => $INTERFACE};
            myjsonrpc::send_json($r, $result);
            next;
        }

        if ($rsp->{cmd} eq 'interactive') {
            # interactive is boolean
            $interactive = $rsp->{params}->{state} ? 1 : 0;
            if (!$interactive && $needinput) {
                # need to continue the VM
                $bmwqemu::backend->_send_json({cmd => 'retry_assert_screen'});
                $needinput = 0;
                $timeout   = .1;
                check_asserted_screen(1, $no_wait);
            }
            myjsonrpc::send_json($r, {interactive => $interactive});
            next;
        }

        if ($rsp->{cmd} eq 'stop_waitforneedle') {
            $bmwqemu::backend->_send_json({cmd => 'reduce_deadline'});
            myjsonrpc::send_json($r, {ret => 0});
            next;
        }
        if ($rsp->{cmd} eq 'continue_waitforneedle' || $rsp->{cmd} eq 'reload_needles') {
            $needinput = 0;
            $timeout   = .1;
            my $reload = $rsp->{cmd} eq 'reload_needles';
            # tell backend to retry
            $bmwqemu::backend->_send_json({cmd => 'retry_assert_screen', arguments => {reload_needles => $reload}});
            # that's enough for the webui to know
            myjsonrpc::send_json($r, {ret => 0});
            check_asserted_screen(1, $no_wait);
            next;
        }
        if ($rsp->{cmd} eq 'read_serial') {
            # This will stop to work if we change the serialfile after the initialization because of the fork
            my ($serial, $pos) = $bmwqemu::backend->{backend}->read_serial($rsp->{position});
            myjsonrpc::send_json($r, {serial => $serial, position => $pos});
            next;
        }
        die "Unknown command $rsp->{cmd}";
    }

    if (defined $tags && !$needinput) {
        check_asserted_screen(0, $no_wait);
    }
}

# don't leave the commands server open - it will no longer react anyway
# as most of it ends up in the loop above
kill_commands;

if ($testfd) {
    $r = 1;    # unusual shutdown
    CORE::close $testfd;
    kill_autotest;
}

diag "isotovideo " . ($r ? 'failed' : 'done');

my $clean_shutdown;
if (!$r) {
    eval {
        $clean_shutdown = $bmwqemu::backend->_send_json({cmd => 'is_shutdown'});
        diag "BACKEND SHUTDOWN $clean_shutdown";
    };
    # don't rely on the backend in a sane state if we failed - just kill it later
    eval { bmwqemu::stop_vm(); };
    if ($@) {
        diag "Error during stop_vm: $@";
        $r = 1;
    }
}

# read calculated variables from backend and tests
bmwqemu::load_vars();

# mark hard disks for upload if test finished
if (!$r && $completed && (my $nd = $bmwqemu::vars{NUMDISKS}) && ($bmwqemu::vars{BACKEND} eq 'qemu')) {
    my @toextract;
    for my $i (1 .. $nd) {
        my $dir = 'assets_private';
        my $name = $bmwqemu::vars{"STORE_HDD_$i"} || undef;
        unless ($name) {
            $name = $bmwqemu::vars{"PUBLISH_HDD_$i"} || undef;
            $dir = 'assets_public';
        }
        next unless $name;
        $name =~ /\.([[:alnum:]]+)$/;
        my $format = $1;
        push @toextract, {hdd_num => $i, name => $name, dir => $dir, format => $format};
    }
    if (@toextract && !$clean_shutdown) {
        diag "ERROR: Machine not shut down when uploading disks!\n";
        $r = 1;
    }
    else {
        for my $asset (@toextract) {
            local $@;
            eval { $bmwqemu::backend->extract_assets($asset); };
            if ($@) {
                diag "extract assets failed: $@";
                $r = 1;
            }
        }
    }
}

END {
    kill_backend;
    kill_commands;
    kill_autotest;
    # in case of early exit, e.g. help display
    $r //= 0;
    print "$$: EXIT $r\n";
    $? = $r;
}

# vim: set sw=4 et: