Permalink
Cannot retrieve contributors at this time
#!/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(); | |
} |