ipxtester

#!/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();
}