Skip to content
Permalink
master
Go to file
 
 
Cannot retrieve contributors at this time
executable file 656 lines (522 sloc) 15.8 KB
#!/usr/bin/perl
# Run the IPXWrapper test suite in temporary VirtualBox VMs
# By Daniel Collins (2017-2019)
# Released to public domain
use strict;
use warnings;
use feature qw(state);
use Config::INI::Reader;
use Errno qw(EEXIST ENOENT);
use Fcntl;
use FindBin;
use IPC::Run qw(run binary start);
use IPC::Semaphore;
use IPC::SysV qw(ftok IPC_CREAT IPC_EXCL SEM_UNDO);
use Term::ANSIColor;
# Configuration variables populated by read_config()
my $IMAGES_DIRECTORY;
my $TMP_DIRECTORY;
my $AVAILABLE_RESOURCE;
my $MAX_DURATION;
my $DIRECTOR_OS_TYPE;
my $DIRECTOR_VCPUS;
my $DIRECTOR_MEM;
my $DIRECTOR_IMAGE;
my %TEST_PLATFORMS;
my %INTERFACES;
my $CONFIG_OK = 0;
# Interfaces which have been locked
my @my_interfaces = ();
read_config("$FindBin::Bin/ipxtester.ini");
# ftok() will fail if it can't stat the directory as the key is generated using
# properties of the inode, not the string passed in.
my $SEM_KEY = do
{
my $key_path = "$TMP_DIRECTORY/sem.key";
unless(-e $key_path)
{
open(my $sem, ">", $key_path) or die "Unable to create $key_path: $!\n";
}
ftok($key_path, 1) // die "$key_path: $!\n";
};
# Install handlers for common exit signals to ensure our VMs/etc are cleaned up
# before our hold on the semaphore is released if we are killed early.
$SIG{HUP} = $SIG{INT} = $SIG{TERM} = $SIG{ALRM} = sub
{
my ($sig_name) = @_;
cleanup_vms();
# Raise the signal again now we've cleaned up so the parent gets the
# correct wait status (if we even have one any more).
$SIG{$sig_name} = "DEFAULT";
kill($sig_name, $$);
};
if(defined $ENV{SSH_ORIGINAL_COMMAND})
{
if($ENV{SSH_ORIGINAL_COMMAND} =~ m/^\S+\s+test\s+(\S+)$/s)
{
cmd_test($1);
}
else{
print STDERR "Unexpected SSH_ORIGINAL_COMMAND: ", $ENV{SSH_ORIGINAL_COMMAND}, "\n";
exit(42); # EX_USAGE
}
}
else{
if((scalar @ARGV) == 1 && $ARGV[0] eq "init")
{
cmd_init();
}
elsif((scalar @ARGV) == 2 && $ARGV[0] eq "test")
{
cmd_test($ARGV[1]);
}
else{
print STDERR "Usage: $0 init\n";
print STDERR " $0 test <platform> < build-tree.tar\n";
exit(42); # EX_USAGE
}
}
sub cmd_init
{
# Delete VMs
if(open(my $vbm, "-|", "VBoxManage", "list", "vms"))
{
while(defined(my $line = <$vbm>))
{
my ($vm) = ($line =~ m/^"(.*)"/);
if(defined($vm) && $vm =~ m/^ipxtest-/)
{
system("VBoxManage", "unregistervm", $vm, "--delete")
and warn "Could not delete VM '$vm'\n";
}
}
}
else{
warn "Could not execute VBoxManage: $!\n";
}
# Delete any orphaned disk images and port reservations.
foreach my $file(glob("$TMP_DIRECTORY/*"))
{
next if($file =~ m/\/sem\.key$/);
unlink($file)
or warn "Could not unlink $file: $!\n";
}
# Create the semaphore.
my $sem = IPC::Semaphore->new($SEM_KEY, 1, (0600 | IPC_CREAT | IPC_EXCL))
// die "Cannot open semaphore: $!";
# Initialise semaphore. Any pending commands may now begin.
$sem->setall(0);
$sem->op(0, $AVAILABLE_RESOURCE, 0);
exit(0);
}
sub cmd_test
{
my ($platform_name) = @_;
binmode(STDIN, ":raw");
my $tarball = do { local $/; <STDIN> };
my $platform = $TEST_PLATFORMS{$platform_name}
// die "Unknown platform. Valid platforms are: ".join(" ", keys(%TEST_PLATFORMS))."\n";
claim_resource($platform->{resource});
print STDERR "--- Setting up environment\n";
alarm($MAX_DURATION); # Abort eventually if the test stalls
# Register instances and start director VMs
my @instances = ();
for(my $instance_i = 1; $instance_i <= $platform->{workers}; ++$instance_i)
{
my $intnet_a = "ipxtest-$$-${instance_i}-a";
my $intnet_b = "ipxtest-$$-${instance_i}-b";
my $iface = reserve_iface();
create_vm("${instance_i}-director", $DIRECTOR_OS_TYPE, $DIRECTOR_VCPUS, $DIRECTOR_MEM, $DIRECTOR_IMAGE, [
[
"--nic1" => "hostonly",
"--hostonlyadapter1" => "$iface",
"--nictype1" => "82540EM",
"--macaddress1" => "0800274155B4",
],
[
"--nic2" => "intnet",
"--intnet2" => $intnet_a,
"--nictype2" => "82540EM",
"--macaddress2" => "080027525F9E",
"--nicpromisc2" => "allow-all",
],
[
"--nic3" => "intnet",
"--intnet3" => $intnet_b,
"--nictype3" => "82540EM",
"--macaddress3" => "080027F5BE4C",
"--nicpromisc3" => "allow-all",
],
]);
push(@instances, {
name => "ipxtest-$$-${instance_i}",
ip => $INTERFACES{$iface},
free => 1,
});
}
# Wait for director VMs to boot and unpack build trees
foreach my $instance(@instances)
{
my $ip = $instance->{ip};
my $wait_for_vm = sub
{
my ($command, $name) = @_;
print STDERR "Waiting for ", $instance->{name}, "-${name} to boot...\n";
wait_for_success("ssh", "-o" => "ConnectTimeout=1", "root\@${ip}", $command);
};
$wait_for_vm->("true", "director");
run([ "ssh", "root\@${ip}", "tar -xf - -C /srv/ipxwrapper/" ],
"<" => binary, \$tarball,
">&2",
)
or die "Could not unpack build tree\n";
}
# Start Windows VMs
# This is done as a seperate step as when running on a fast enough host, Windows 10 seems
# to realise that it can't access the SMB share exported from the director VM and cache
# that failure rather than retrying whenever we connect and try to map it.
for(my $instance_i = 1; $instance_i <= $platform->{workers}; ++$instance_i)
{
my $intnet_a = "ipxtest-$$-${instance_i}-a";
my $intnet_b = "ipxtest-$$-${instance_i}-b";
create_vm("${instance_i}-main", $platform->{os_type}, $platform->{vcpus}, $platform->{mem}, $platform->{main_image}, [
[
"--nic1" => "intnet",
"--intnet1" => $intnet_a,
"--nictype1" => "82540EM",
"--macaddress1" => "080027C36AE6",
"--nicpromisc1" => "allow-all",
],
[
"--nic2" => "intnet",
"--intnet2" => $intnet_b,
"--nictype2" => "82540EM",
"--macaddress2" => "08002743475C",
"--nicpromisc2" => "allow-all",
],
]);
create_vm("${instance_i}-dp1", $platform->{os_type}, $platform->{vcpus}, $platform->{mem}, $platform->{dp1_image}, [
[
"--nic1" => "intnet",
"--intnet1" => $intnet_a,
"--nictype1" => "82540EM",
"--macaddress1" => "08002748276B",
"--nicpromisc1" => "allow-all",
],
]);
create_vm("${instance_i}-dp2", $platform->{os_type}, $platform->{vcpus}, $platform->{mem}, $platform->{dp2_image}, [
[
"--nic1" => "intnet",
"--intnet1" => $intnet_a,
"--nictype1" => "82540EM",
"--macaddress1" => "08002771C850",
"--nicpromisc1" => "allow-all",
],
]);
}
# Wait for Windows VMs to boot.
foreach my $instance(@instances)
{
my $ip = $instance->{ip};
my $wait_for_vm = sub
{
my ($command, $name) = @_;
print STDERR "Waiting for ", $instance->{name}, "-${name} to boot...\n";
wait_for_success("ssh", "-o" => "ConnectTimeout=1", "root\@${ip}", $command);
};
$wait_for_vm->("ssh -o ConnectTimeout=1 172.16.1.21 ';'", "main");
$wait_for_vm->("ssh -o ConnectTimeout=1 172.16.1.22 ';'", "dp1");
$wait_for_vm->("ssh -o ConnectTimeout=1 172.16.1.23 ';'", "dp2");
}
# Gather list of tests to run from the first instance.
my $tests_ls = "";
run(
[ "ssh", "root\@".$instances[0]->{ip}, "cd /srv/ipxwrapper/tests/ && ls -1 *.t" ],
">" => \$tests_ls,
"<" => "/dev/null")
or die "Unable to enumerate tests";
my @tests = map {
{
name => $_, # Name of test script (xxx.t)
instance => undef, # Instance running the test (from started until done)
started => 0, # Has test been started?
output => "", # Output from test (STDOUT and STDERR)
handle => undef, # IPC::Run handle (from started until done)
done => 0, # Has test finished?
passed => undef, # Did test pass? (after done)
}
} sort ($tests_ls =~ m/(\S+)/g);
print STDERR "--- Running tests\n";
while(grep { !$_->{done} } @tests)
{
my ($next_test) = grep { !$_->{started} } @tests;
my ($next_free) = grep { $_->{free} } @instances;
my $did_work = 0;
if(defined($next_test) && defined($next_free))
{
$next_test->{handle} = start(
[ "ssh", "-tt", "root\@".$next_free->{ip}, "cd /srv/ipxwrapper/ && prove -v tests/".$next_test->{name} ],
">&" => \($next_test->{output}),
"<" => "/dev/null")
or die "Unable to start ".$next_test->{name};
$next_free->{free} = 0;
$next_test->{instance} = $next_free;
$next_test->{started} = 1;
$did_work = 1;
}
foreach my $running_test(grep { $_->{started} && !$_->{done} } @tests)
{
if(!$running_test->{handle}->pump_nb())
{
# Process is finished
$running_test->{passed} = $running_test->{handle}->finish();
$running_test->{handle} = undef;
$running_test->{instance}->{free} = 1;
$running_test->{instance} = undef;
$running_test->{done} = 1;
$did_work = 1;
}
}
foreach my $test(@tests)
{
if($test->{output} ne "")
{
print STDERR $test->{output};
$test->{output} = "";
$did_work = 1;
}
last unless($test->{done});
}
sleep(1) unless($did_work);
}
my @failed_tests = grep { !$_->{passed} } @tests;
if(@failed_tests)
{
print STDERR color("bright_red");
print STDERR "\nThe following test scripts FAILED:\n\n";
print STDERR $_->{name}, "\n" foreach(@failed_tests);
print STDERR "\n";
}
else{
print STDERR color("bright_green");
print STDERR "\nAll test scripts passed!\n\n";
}
print STDERR color("reset");
print STDERR "--- Destroying environment\n";
exit(@failed_tests ? 1 : 0);
}
sub claim_resource
{
my ($resource) = @_;
state $sem;
until(defined($sem = IPC::Semaphore->new($SEM_KEY, 1, 0600)))
{
die "Cannot open semaphore: $!"
unless($!{ENOENT});
sleep 1;
}
while($sem->stat()->otime == 0)
{
sleep 1;
}
print STDERR "Waiting for $resource resource units...\n";
$sem->op(0, -$resource, SEM_UNDO);
}
sub reserve_iface
{
foreach my $iface(keys %INTERFACES)
{
if(sysopen(my $fh, "$TMP_DIRECTORY/iface-$iface", O_WRONLY | O_CREAT | O_EXCL, 0644))
{
push(@my_interfaces, $iface);
return $iface;
}
die "Cannot create $TMP_DIRECTORY/iface-$iface: $!\n"
unless($!{EEXIST});
}
die "No network interfaces available!\n";
}
sub wait_for_success
{
my (@command) = @_;
# TODO: Timeout?
until(run(\@command, ">&" => "/dev/null")) {}
}
sub do_or_die
{
my (@cmd) = @_;
print STDERR "Running [".join("] [", @cmd)."]...\n";
run(\@cmd, ">&2")
or die "Command exited with status $?\n";
}
sub create_vm
{
my ($vm_name, $ostype, $vcpus, $mem_mb, $image, $modifyvm_commands) = @_;
$vm_name = "ipxtest-$$-$vm_name";
my $disk_path = "$TMP_DIRECTORY/$vm_name.vdi";
do_or_die("cp", "--reflink", $image, $disk_path);
do_or_die("VBoxManage", "internalcommands", "sethduuid", $disk_path);
do_or_die("VBoxManage", "createvm",
"--register",
"--name" => $vm_name,
"--ostype" => $ostype);
if($ostype =~ m/^WindowsXP/)
{
# PIIX4 IDE
do_or_die("VBoxManage", "storagectl", $vm_name,
"--name" => "IDE Controller",
"--add" => "ide",
"--controller" => "PIIX4",
"--hostiocache" => "on");
do_or_die("VBoxManage", "storageattach", $vm_name,
"--storagectl" => "IDE Controller",
"--port" => "0",
"--device" => "0",
"--type" => "hdd",
"--medium" => $disk_path);
}
else{
# AHCI SATA
do_or_die("VBoxManage", "storagectl", $vm_name,
"--name" => "SATA Controller",
"--add" => "sata",
"--controller" => "IntelAHCI",
"--portcount" => "1",
"--hostiocache" => "on");
do_or_die("VBoxManage", "storageattach", $vm_name,
"--storagectl" => "SATA Controller",
"--port" => "0",
"--device" => "0",
"--type" => "hdd",
"--medium" => $disk_path);
}
if($vm_name !~ m/^Windows/)
{
# Not Windows, RTC time should be UTC.
do_or_die("VBoxManage", "modifyvm", $vm_name, "--rtcuseutc" => "on");
}
do_or_die("VBoxManage", "modifyvm", $vm_name, "--cpus", => $vcpus);
do_or_die("VBoxManage", "modifyvm", $vm_name, "--memory" => $mem_mb);
# Stop Windows wasting lots of time trying to find/install an audio driver.
do_or_die("VBoxManage", "modifyvm", $vm_name, "--audio" => "none");
foreach my $mvm_cmd(@$modifyvm_commands)
{
do_or_die("VBoxManage", "modifyvm", $vm_name, @$mvm_cmd);
}
do_or_die("VBoxManage", "startvm", $vm_name, "--type" => "headless");
}
sub cleanup_vms
{
# Don't override the damn exit status, Perl!
local $?;
# Don't try to clean up when we don't know what we're doing.
return unless($CONFIG_OK);
# Stop running VMs
if(open(my $vbm, "-|", "VBoxManage", "list", "runningvms"))
{
while(defined(my $line = <$vbm>))
{
my ($vm) = ($line =~ m/^"(.*)"/);
if(defined($vm) && $vm =~ m/^ipxtest-$$-/)
{
print STDERR "Powering off VM $vm...\n";
system("VBoxManage", "controlvm", $vm, "poweroff")
and warn "Could not power off VM $vm\n";
}
}
}
else{
warn "Could not execute VBoxManage: $!\n";
}
# Delete VMs
if(open(my $vbm, "-|", "VBoxManage", "list", "vms"))
{
while(defined(my $line = <$vbm>))
{
my ($vm) = ($line =~ m/^"(.*)"/);
if(defined($vm) && $vm =~ m/^ipxtest-$$-/)
{
print STDERR "Deleting VM $vm...\n";
system("VBoxManage", "unregistervm", $vm, "--delete")
and warn "Could not delete VM $vm\n";
}
}
}
else{
warn "Could not execute VBoxManage: $!\n";
}
# Delete any disk images. Should be a noop unless we bailed out before
# registering a VM or the above delete failed.
foreach my $image(glob("$TMP_DIRECTORY/ipxtest-$$-*.vdi"))
{
unlink($image)
or warn "Could not unlink $image: $!\n";
}
# Release network interfaces we claimed
foreach my $iface(@my_interfaces)
{
my $path = "$TMP_DIRECTORY/iface-$iface";
unlink($path)
or warn "Could not unlink $path: $!\n";
}
}
sub read_config
{
my ($ini_file) = @_;
# Throws on error
my $ini = Config::INI::Reader->read_file($ini_file);
my $ini_val = sub
{
my ($section, $key, $valid) = @_;
my $value = $ini->{$section}->{$key}
// die "Missing '$key' property in ".($section eq "_" ? "top-level" : $section)." configuration\n";
die "Invalid '$key' property in ".($section eq "_" ? "top-level" : $section)." configuration\n"
if(defined($valid) && !$valid->($value));
delete $ini->{$section}->{$key};
return $value;
};
my $ini_check = sub
{
my ($section) = @_;
my @keys = keys(%{ $ini->{$section} });
if(@keys)
{
die "Unexpected properties in ".($section eq "_" ? "top-level" : $section)." configuration: ".join(", ", @keys)."\n";
}
};
my $is_pnum = sub { return !!($_[0] =~ m/^[1-9][0-9]*$/); };
my $is_dir = sub { return -d $_[0]; };
my $is_image = sub { return -f "$IMAGES_DIRECTORY/".$_[0]; };
$IMAGES_DIRECTORY = $ini_val->("_", "images directory", $is_dir);
$TMP_DIRECTORY = $ini_val->("_", "tmp directory", $is_dir);
$AVAILABLE_RESOURCE = $ini_val->("_", "total resource", $is_pnum);
$MAX_DURATION = $ini_val->("_", "max duration", $is_pnum);
$DIRECTOR_OS_TYPE = $ini_val->("_", "director os");
$DIRECTOR_VCPUS = $ini_val->("_", "director vcpus", $is_pnum);
$DIRECTOR_MEM = $ini_val->("_", "director mem", $is_pnum);
$DIRECTOR_IMAGE = "$IMAGES_DIRECTORY/".$ini_val->("_", "director image", $is_image);
foreach my $key(grep { m/^vboxnet\S+/ } keys(%{ $ini->{"_"} }))
{
$INTERFACES{$key} = $ini_val->("_", $key, sub { 1; });
}
$ini_check->("_");
delete $ini->{"_"};
foreach my $section(keys %$ini)
{
$TEST_PLATFORMS{$section} = {
os_type => $ini_val->($section, "os"),
vcpus => $ini_val->($section, "vcpus", $is_pnum),
mem => $ini_val->($section, "mem", $is_pnum),
workers => $ini_val->($section, "workers", $is_pnum),
resource => $ini_val->($section, "resource cost", $is_pnum),
main_image => "$IMAGES_DIRECTORY/".$ini_val->($section, "main image", $is_image),
dp1_image => "$IMAGES_DIRECTORY/".$ini_val->($section, "dp1 image", $is_image),
dp2_image => "$IMAGES_DIRECTORY/".$ini_val->($section, "dp2 image", $is_image),
};
$ini_check->($section);
}
$CONFIG_OK = 1;
}
END {
cleanup_vms();
}