nixos/lib/test*: remove perl test driver
This has been deprecated in 20.03, and all tests have been migrated to the python framework, effectively making this dead code.
This commit is contained in:
Florian Klink
parent
6eae50cca8
commit
0620184f3f
|
|
@ -204,6 +204,16 @@ GRANT ALL PRIVILEGES ON *.* TO 'mysql'@'localhost' WITH GRANT OPTION;
|
||||||
Note: Password support is only avaiable in GRUB version 2.
|
Note: Password support is only avaiable in GRUB version 2.
|
||||||
</para>
|
</para>
|
||||||
</listitem>
|
</listitem>
|
||||||
|
<listitem>
|
||||||
|
<para>
|
||||||
|
Following its deprecation in 20.03, the Perl NixOS test driver has been removed.
|
||||||
|
All remaining tests have been ported to the Python test framework.
|
||||||
|
Code outside nixpkgs using <filename>make-test.nix</filename> or
|
||||||
|
<filename>testing.nix</filename> needs to be ported to
|
||||||
|
<filename>make-test-python.nix</filename> and
|
||||||
|
<filename>testing-python.nix</filename> respectively.
|
||||||
|
</para>
|
||||||
|
</listitem>
|
||||||
</itemizedlist>
|
</itemizedlist>
|
||||||
</section>
|
</section>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,75 +0,0 @@
|
||||||
package Logger;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use Thread::Queue;
|
|
||||||
use XML::Writer;
|
|
||||||
use Encode qw(decode encode);
|
|
||||||
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ($class) = @_;
|
|
||||||
|
|
||||||
my $logFile = defined $ENV{LOGFILE} ? "$ENV{LOGFILE}" : "/dev/null";
|
|
||||||
my $log = new XML::Writer(OUTPUT => new IO::File(">$logFile"));
|
|
||||||
|
|
||||||
my $self = {
|
|
||||||
log => $log,
|
|
||||||
logQueue => Thread::Queue->new()
|
|
||||||
};
|
|
||||||
|
|
||||||
$self->{log}->startTag("logfile");
|
|
||||||
|
|
||||||
bless $self, $class;
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub close {
|
|
||||||
my ($self) = @_;
|
|
||||||
$self->{log}->endTag("logfile");
|
|
||||||
$self->{log}->end;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub drainLogQueue {
|
|
||||||
my ($self) = @_;
|
|
||||||
while (defined (my $item = $self->{logQueue}->dequeue_nb())) {
|
|
||||||
$self->{log}->dataElement("line", sanitise($item->{msg}), 'machine' => $item->{machine}, 'type' => 'serial');
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub maybePrefix {
|
|
||||||
my ($msg, $attrs) = @_;
|
|
||||||
$msg = $attrs->{machine} . ": " . $msg if defined $attrs->{machine};
|
|
||||||
return $msg;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub nest {
|
|
||||||
my ($self, $msg, $coderef, $attrs) = @_;
|
|
||||||
print STDERR maybePrefix("$msg\n", $attrs);
|
|
||||||
$self->{log}->startTag("nest");
|
|
||||||
$self->{log}->dataElement("head", $msg, %{$attrs});
|
|
||||||
my $now = clock_gettime(CLOCK_MONOTONIC);
|
|
||||||
$self->drainLogQueue();
|
|
||||||
eval { &$coderef };
|
|
||||||
my $res = $@;
|
|
||||||
$self->drainLogQueue();
|
|
||||||
$self->log(sprintf("(%.2f seconds)", clock_gettime(CLOCK_MONOTONIC) - $now));
|
|
||||||
$self->{log}->endTag("nest");
|
|
||||||
die $@ if $@;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub sanitise {
|
|
||||||
my ($s) = @_;
|
|
||||||
$s =~ s/[[:cntrl:]\xff]//g;
|
|
||||||
$s = decode('UTF-8', $s, Encode::FB_DEFAULT);
|
|
||||||
return encode('UTF-8', $s, Encode::FB_CROAK);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub log {
|
|
||||||
my ($self, $msg, $attrs) = @_;
|
|
||||||
chomp $msg;
|
|
||||||
print STDERR maybePrefix("$msg\n", $attrs);
|
|
||||||
$self->drainLogQueue();
|
|
||||||
$self->{log}->dataElement("line", $msg, %{$attrs});
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
@ -1,734 +0,0 @@
|
||||||
package Machine;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use threads;
|
|
||||||
use Socket;
|
|
||||||
use IO::Handle;
|
|
||||||
use POSIX qw(dup2);
|
|
||||||
use FileHandle;
|
|
||||||
use Cwd;
|
|
||||||
use File::Basename;
|
|
||||||
use File::Path qw(make_path);
|
|
||||||
use File::Slurp;
|
|
||||||
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
|
|
||||||
|
|
||||||
|
|
||||||
my $showGraphics = defined $ENV{'DISPLAY'};
|
|
||||||
|
|
||||||
my $sharedDir;
|
|
||||||
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ($class, $args) = @_;
|
|
||||||
|
|
||||||
my $startCommand = $args->{startCommand};
|
|
||||||
|
|
||||||
my $name = $args->{name};
|
|
||||||
if (!$name) {
|
|
||||||
$startCommand =~ /run-(.*)-vm$/ if defined $startCommand;
|
|
||||||
$name = $1 || "machine";
|
|
||||||
}
|
|
||||||
|
|
||||||
if (!$startCommand) {
|
|
||||||
# !!! merge with qemu-vm.nix.
|
|
||||||
my $netBackend = "-netdev user,id=net0";
|
|
||||||
my $netFrontend = "-device virtio-net-pci,netdev=net0";
|
|
||||||
|
|
||||||
$netBackend .= "," . $args->{netBackendArgs}
|
|
||||||
if defined $args->{netBackendArgs};
|
|
||||||
|
|
||||||
$netFrontend .= "," . $args->{netFrontendArgs}
|
|
||||||
if defined $args->{netFrontendArgs};
|
|
||||||
|
|
||||||
$startCommand =
|
|
||||||
"qemu-kvm -m 384 $netBackend $netFrontend \$QEMU_OPTS ";
|
|
||||||
|
|
||||||
if (defined $args->{hda}) {
|
|
||||||
if ($args->{hdaInterface} eq "scsi") {
|
|
||||||
$startCommand .= "-drive id=hda,file="
|
|
||||||
. Cwd::abs_path($args->{hda})
|
|
||||||
. ",werror=report,if=none "
|
|
||||||
. "-device scsi-hd,drive=hda ";
|
|
||||||
} else {
|
|
||||||
$startCommand .= "-drive file=" . Cwd::abs_path($args->{hda})
|
|
||||||
. ",if=" . $args->{hdaInterface}
|
|
||||||
. ",werror=report ";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
$startCommand .= "-cdrom $args->{cdrom} "
|
|
||||||
if defined $args->{cdrom};
|
|
||||||
$startCommand .= "-device piix3-usb-uhci -drive id=usbdisk,file=$args->{usb},if=none,readonly -device usb-storage,drive=usbdisk "
|
|
||||||
if defined $args->{usb};
|
|
||||||
$startCommand .= "-bios $args->{bios} "
|
|
||||||
if defined $args->{bios};
|
|
||||||
$startCommand .= $args->{qemuFlags} || "";
|
|
||||||
}
|
|
||||||
|
|
||||||
my $tmpDir = $ENV{'TMPDIR'} || "/tmp";
|
|
||||||
unless (defined $sharedDir) {
|
|
||||||
$sharedDir = $tmpDir . "/xchg-shared";
|
|
||||||
make_path($sharedDir, { mode => 0700, owner => $< });
|
|
||||||
}
|
|
||||||
|
|
||||||
my $allowReboot = 0;
|
|
||||||
$allowReboot = $args->{allowReboot} if defined $args->{allowReboot};
|
|
||||||
|
|
||||||
my $self = {
|
|
||||||
startCommand => $startCommand,
|
|
||||||
name => $name,
|
|
||||||
allowReboot => $allowReboot,
|
|
||||||
booted => 0,
|
|
||||||
pid => 0,
|
|
||||||
connected => 0,
|
|
||||||
socket => undef,
|
|
||||||
stateDir => "$tmpDir/vm-state-$name",
|
|
||||||
monitor => undef,
|
|
||||||
log => $args->{log},
|
|
||||||
redirectSerial => $args->{redirectSerial} // 1,
|
|
||||||
};
|
|
||||||
|
|
||||||
mkdir $self->{stateDir}, 0700;
|
|
||||||
|
|
||||||
bless $self, $class;
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub log {
|
|
||||||
my ($self, $msg) = @_;
|
|
||||||
$self->{log}->log($msg, { machine => $self->{name} });
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub nest {
|
|
||||||
my ($self, $msg, $coderef, $attrs) = @_;
|
|
||||||
$self->{log}->nest($msg, $coderef, { %{$attrs || {}}, machine => $self->{name} });
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub name {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{name};
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub stateDir {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{stateDir};
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub start {
|
|
||||||
my ($self) = @_;
|
|
||||||
return if $self->{booted};
|
|
||||||
|
|
||||||
$self->log("starting vm");
|
|
||||||
|
|
||||||
# Create a socket pair for the serial line input/output of the VM.
|
|
||||||
my ($serialP, $serialC);
|
|
||||||
socketpair($serialP, $serialC, PF_UNIX, SOCK_STREAM, 0) or die;
|
|
||||||
|
|
||||||
# Create a Unix domain socket to which QEMU's monitor will connect.
|
|
||||||
my $monitorPath = $self->{stateDir} . "/monitor";
|
|
||||||
unlink $monitorPath;
|
|
||||||
my $monitorS;
|
|
||||||
socket($monitorS, PF_UNIX, SOCK_STREAM, 0) or die;
|
|
||||||
bind($monitorS, sockaddr_un($monitorPath)) or die "cannot bind monitor socket: $!";
|
|
||||||
listen($monitorS, 1) or die;
|
|
||||||
|
|
||||||
# Create a Unix domain socket to which the root shell in the guest will connect.
|
|
||||||
my $shellPath = $self->{stateDir} . "/shell";
|
|
||||||
unlink $shellPath;
|
|
||||||
my $shellS;
|
|
||||||
socket($shellS, PF_UNIX, SOCK_STREAM, 0) or die;
|
|
||||||
bind($shellS, sockaddr_un($shellPath)) or die "cannot bind shell socket: $!";
|
|
||||||
listen($shellS, 1) or die;
|
|
||||||
|
|
||||||
# Start the VM.
|
|
||||||
my $pid = fork();
|
|
||||||
die if $pid == -1;
|
|
||||||
|
|
||||||
if ($pid == 0) {
|
|
||||||
close $serialP;
|
|
||||||
close $monitorS;
|
|
||||||
close $shellS;
|
|
||||||
if ($self->{redirectSerial}) {
|
|
||||||
open NUL, "</dev/null" or die;
|
|
||||||
dup2(fileno(NUL), fileno(STDIN));
|
|
||||||
dup2(fileno($serialC), fileno(STDOUT));
|
|
||||||
dup2(fileno($serialC), fileno(STDERR));
|
|
||||||
}
|
|
||||||
$ENV{TMPDIR} = $self->{stateDir};
|
|
||||||
$ENV{SHARED_DIR} = $sharedDir;
|
|
||||||
$ENV{USE_TMPDIR} = 1;
|
|
||||||
$ENV{QEMU_OPTS} =
|
|
||||||
($self->{allowReboot} ? "" : "-no-reboot ") .
|
|
||||||
"-monitor unix:./monitor -chardev socket,id=shell,path=./shell " .
|
|
||||||
"-device virtio-serial -device virtconsole,chardev=shell " .
|
|
||||||
"-device virtio-rng-pci " .
|
|
||||||
($showGraphics ? "-serial stdio" : "-nographic") . " " . ($ENV{QEMU_OPTS} || "");
|
|
||||||
chdir $self->{stateDir} or die;
|
|
||||||
exec $self->{startCommand};
|
|
||||||
die "running VM script: $!";
|
|
||||||
}
|
|
||||||
|
|
||||||
# Process serial line output.
|
|
||||||
close $serialC;
|
|
||||||
|
|
||||||
threads->create(\&processSerialOutput, $self, $serialP)->detach;
|
|
||||||
|
|
||||||
sub processSerialOutput {
|
|
||||||
my ($self, $serialP) = @_;
|
|
||||||
while (<$serialP>) {
|
|
||||||
chomp;
|
|
||||||
s/\r$//;
|
|
||||||
print STDERR $self->{name}, "# $_\n";
|
|
||||||
$self->{log}->{logQueue}->enqueue({msg => $_, machine => $self->{name}}); # !!!
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
eval {
|
|
||||||
local $SIG{CHLD} = sub { die "QEMU died prematurely\n"; };
|
|
||||||
|
|
||||||
# Wait until QEMU connects to the monitor.
|
|
||||||
accept($self->{monitor}, $monitorS) or die;
|
|
||||||
|
|
||||||
# Wait until QEMU connects to the root shell socket. QEMU
|
|
||||||
# does so immediately; this doesn't mean that the root shell
|
|
||||||
# has connected yet inside the guest.
|
|
||||||
accept($self->{socket}, $shellS) or die;
|
|
||||||
$self->{socket}->autoflush(1);
|
|
||||||
};
|
|
||||||
die "$@" if $@;
|
|
||||||
|
|
||||||
$self->waitForMonitorPrompt;
|
|
||||||
|
|
||||||
$self->log("QEMU running (pid $pid)");
|
|
||||||
|
|
||||||
$self->{pid} = $pid;
|
|
||||||
$self->{booted} = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Send a command to the monitor and wait for it to finish. TODO: QEMU
|
|
||||||
# also has a JSON-based monitor interface now, but it doesn't support
|
|
||||||
# all commands yet. We should use it once it does.
|
|
||||||
sub sendMonitorCommand {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
$self->log("sending monitor command: $command");
|
|
||||||
syswrite $self->{monitor}, "$command\n";
|
|
||||||
return $self->waitForMonitorPrompt;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until the monitor sends "(qemu) ".
|
|
||||||
sub waitForMonitorPrompt {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $res = "";
|
|
||||||
my $s;
|
|
||||||
while (sysread($self->{monitor}, $s, 1024)) {
|
|
||||||
$res .= $s;
|
|
||||||
last if $res =~ s/\(qemu\) $//;
|
|
||||||
}
|
|
||||||
return $res;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Call the given code reference repeatedly, with 1 second intervals,
|
|
||||||
# until it returns 1 or a timeout is reached.
|
|
||||||
sub retry {
|
|
||||||
my ($coderef) = @_;
|
|
||||||
my $n;
|
|
||||||
for ($n = 899; $n >=0; $n--) {
|
|
||||||
return if &$coderef($n);
|
|
||||||
sleep 1;
|
|
||||||
}
|
|
||||||
die "action timed out after $n seconds";
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub connect {
|
|
||||||
my ($self) = @_;
|
|
||||||
return if $self->{connected};
|
|
||||||
|
|
||||||
$self->nest("waiting for the VM to finish booting", sub {
|
|
||||||
|
|
||||||
$self->start;
|
|
||||||
|
|
||||||
my $now = clock_gettime(CLOCK_MONOTONIC);
|
|
||||||
local $SIG{ALRM} = sub { die "timed out waiting for the VM to connect\n"; };
|
|
||||||
alarm 600;
|
|
||||||
readline $self->{socket} or die "the VM quit before connecting\n";
|
|
||||||
alarm 0;
|
|
||||||
|
|
||||||
$self->log("connected to guest root shell");
|
|
||||||
# We're interested in tracking how close we are to `alarm`.
|
|
||||||
$self->log(sprintf("(connecting took %.2f seconds)", clock_gettime(CLOCK_MONOTONIC) - $now));
|
|
||||||
$self->{connected} = 1;
|
|
||||||
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub waitForShutdown {
|
|
||||||
my ($self) = @_;
|
|
||||||
return unless $self->{booted};
|
|
||||||
|
|
||||||
$self->nest("waiting for the VM to power off", sub {
|
|
||||||
waitpid $self->{pid}, 0;
|
|
||||||
$self->{pid} = 0;
|
|
||||||
$self->{booted} = 0;
|
|
||||||
$self->{connected} = 0;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub isUp {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{booted} && $self->{connected};
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub execute_ {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
|
|
||||||
$self->connect;
|
|
||||||
|
|
||||||
print { $self->{socket} } ("( $command ); echo '|!=EOF' \$?\n");
|
|
||||||
|
|
||||||
my $out = "";
|
|
||||||
|
|
||||||
while (1) {
|
|
||||||
my $line = readline($self->{socket});
|
|
||||||
die "connection to VM lost unexpectedly" unless defined $line;
|
|
||||||
#$self->log("got line: $line");
|
|
||||||
if ($line =~ /^(.*)\|\!\=EOF\s+(\d+)$/) {
|
|
||||||
$out .= $1;
|
|
||||||
$self->log("exit status $2");
|
|
||||||
return ($2, $out);
|
|
||||||
}
|
|
||||||
$out .= $line;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub execute {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
my @res;
|
|
||||||
$self->nest("running command: $command", sub {
|
|
||||||
@res = $self->execute_($command);
|
|
||||||
});
|
|
||||||
return @res;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub succeed {
|
|
||||||
my ($self, @commands) = @_;
|
|
||||||
|
|
||||||
my $res;
|
|
||||||
foreach my $command (@commands) {
|
|
||||||
$self->nest("must succeed: $command", sub {
|
|
||||||
my ($status, $out) = $self->execute_($command);
|
|
||||||
if ($status != 0) {
|
|
||||||
$self->log("output: $out");
|
|
||||||
die "command `$command' did not succeed (exit code $status)\n";
|
|
||||||
}
|
|
||||||
$res .= $out;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
return $res;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub mustSucceed {
|
|
||||||
succeed @_;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub waitUntilSucceeds {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
$self->nest("waiting for success: $command", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute($command);
|
|
||||||
return 1 if $status == 0;
|
|
||||||
};
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub waitUntilFails {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
$self->nest("waiting for failure: $command", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute($command);
|
|
||||||
return 1 if $status != 0;
|
|
||||||
};
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub fail {
|
|
||||||
my ($self, $command) = @_;
|
|
||||||
$self->nest("must fail: $command", sub {
|
|
||||||
my ($status, $out) = $self->execute_($command);
|
|
||||||
die "command `$command' unexpectedly succeeded"
|
|
||||||
if $status == 0;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub mustFail {
|
|
||||||
fail @_;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub getUnitInfo {
|
|
||||||
my ($self, $unit, $user) = @_;
|
|
||||||
my ($status, $lines) = $self->systemctl("--no-pager show \"$unit\"", $user);
|
|
||||||
return undef if $status != 0;
|
|
||||||
my $info = {};
|
|
||||||
foreach my $line (split '\n', $lines) {
|
|
||||||
$line =~ /^([^=]+)=(.*)$/ or next;
|
|
||||||
$info->{$1} = $2;
|
|
||||||
}
|
|
||||||
return $info;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub systemctl {
|
|
||||||
my ($self, $q, $user) = @_;
|
|
||||||
if ($user) {
|
|
||||||
$q =~ s/'/\\'/g;
|
|
||||||
return $self->execute("su -l $user -c \$'XDG_RUNTIME_DIR=/run/user/`id -u` systemctl --user $q'");
|
|
||||||
}
|
|
||||||
|
|
||||||
return $self->execute("systemctl $q");
|
|
||||||
}
|
|
||||||
|
|
||||||
# Fail if the given systemd unit is not in the "active" state.
|
|
||||||
sub requireActiveUnit {
|
|
||||||
my ($self, $unit) = @_;
|
|
||||||
$self->nest("checking if unit ‘$unit’ has reached state 'active'", sub {
|
|
||||||
my $info = $self->getUnitInfo($unit);
|
|
||||||
my $state = $info->{ActiveState};
|
|
||||||
if ($state ne "active") {
|
|
||||||
die "Expected unit ‘$unit’ to to be in state 'active' but it is in state ‘$state’\n";
|
|
||||||
};
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
# Wait for a systemd unit to reach the "active" state.
|
|
||||||
sub waitForUnit {
|
|
||||||
my ($self, $unit, $user) = @_;
|
|
||||||
$self->nest("waiting for unit ‘$unit’", sub {
|
|
||||||
retry sub {
|
|
||||||
my $info = $self->getUnitInfo($unit, $user);
|
|
||||||
my $state = $info->{ActiveState};
|
|
||||||
die "unit ‘$unit’ reached state ‘$state’\n" if $state eq "failed";
|
|
||||||
if ($state eq "inactive") {
|
|
||||||
# If there are no pending jobs, then assume this unit
|
|
||||||
# will never reach active state.
|
|
||||||
my ($status, $jobs) = $self->systemctl("list-jobs --full 2>&1", $user);
|
|
||||||
if ($jobs =~ /No jobs/) { # FIXME: fragile
|
|
||||||
# Handle the case where the unit may have started
|
|
||||||
# between the previous getUnitInfo() and
|
|
||||||
# list-jobs.
|
|
||||||
my $info2 = $self->getUnitInfo($unit);
|
|
||||||
die "unit ‘$unit’ is inactive and there are no pending jobs\n"
|
|
||||||
if $info2->{ActiveState} eq $state;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return 1 if $state eq "active";
|
|
||||||
};
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub waitForJob {
|
|
||||||
my ($self, $jobName) = @_;
|
|
||||||
return $self->waitForUnit($jobName);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until the specified file exists.
|
|
||||||
sub waitForFile {
|
|
||||||
my ($self, $fileName) = @_;
|
|
||||||
$self->nest("waiting for file ‘$fileName’", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute("test -e $fileName");
|
|
||||||
return 1 if $status == 0;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
sub startJob {
|
|
||||||
my ($self, $jobName, $user) = @_;
|
|
||||||
$self->systemctl("start $jobName", $user);
|
|
||||||
# FIXME: check result
|
|
||||||
}
|
|
||||||
|
|
||||||
sub stopJob {
|
|
||||||
my ($self, $jobName, $user) = @_;
|
|
||||||
$self->systemctl("stop $jobName", $user);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until the machine is listening on the given TCP port.
|
|
||||||
sub waitForOpenPort {
|
|
||||||
my ($self, $port) = @_;
|
|
||||||
$self->nest("waiting for TCP port $port", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute("nc -z localhost $port");
|
|
||||||
return 1 if $status == 0;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until the machine is not listening on the given TCP port.
|
|
||||||
sub waitForClosedPort {
|
|
||||||
my ($self, $port) = @_;
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute("nc -z localhost $port");
|
|
||||||
return 1 if $status != 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub shutdown {
|
|
||||||
my ($self) = @_;
|
|
||||||
return unless $self->{booted};
|
|
||||||
|
|
||||||
print { $self->{socket} } ("poweroff\n");
|
|
||||||
|
|
||||||
$self->waitForShutdown;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub crash {
|
|
||||||
my ($self) = @_;
|
|
||||||
return unless $self->{booted};
|
|
||||||
|
|
||||||
$self->log("forced crash");
|
|
||||||
|
|
||||||
$self->sendMonitorCommand("quit");
|
|
||||||
|
|
||||||
$self->waitForShutdown;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Make the machine unreachable by shutting down eth1 (the multicast
|
|
||||||
# interface used to talk to the other VMs). We keep eth0 up so that
|
|
||||||
# the test driver can continue to talk to the machine.
|
|
||||||
sub block {
|
|
||||||
my ($self) = @_;
|
|
||||||
$self->sendMonitorCommand("set_link virtio-net-pci.1 off");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Make the machine reachable.
|
|
||||||
sub unblock {
|
|
||||||
my ($self) = @_;
|
|
||||||
$self->sendMonitorCommand("set_link virtio-net-pci.1 on");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Take a screenshot of the X server on :0.0.
|
|
||||||
sub screenshot {
|
|
||||||
my ($self, $filename) = @_;
|
|
||||||
my $dir = $ENV{'out'} || Cwd::abs_path(".");
|
|
||||||
$filename = "$dir/${filename}.png" if $filename =~ /^\w+$/;
|
|
||||||
my $tmp = "${filename}.ppm";
|
|
||||||
my $name = basename($filename);
|
|
||||||
$self->nest("making screenshot ‘$name’", sub {
|
|
||||||
$self->sendMonitorCommand("screendump $tmp");
|
|
||||||
system("pnmtopng $tmp > ${filename}") == 0
|
|
||||||
or die "cannot convert screenshot";
|
|
||||||
unlink $tmp;
|
|
||||||
}, { image => $name } );
|
|
||||||
}
|
|
||||||
|
|
||||||
# Get the text of TTY<n>
|
|
||||||
sub getTTYText {
|
|
||||||
my ($self, $tty) = @_;
|
|
||||||
|
|
||||||
my ($status, $out) = $self->execute("fold -w\$(stty -F /dev/tty${tty} size | awk '{print \$2}') /dev/vcs${tty}");
|
|
||||||
return $out;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Wait until TTY<n>'s text matches a particular regular expression
|
|
||||||
sub waitUntilTTYMatches {
|
|
||||||
my ($self, $tty, $regexp) = @_;
|
|
||||||
|
|
||||||
$self->nest("waiting for $regexp to appear on tty $tty", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($retries_remaining) = @_;
|
|
||||||
if ($retries_remaining == 0) {
|
|
||||||
$self->log("Last chance to match /$regexp/ on TTY$tty, which currently contains:");
|
|
||||||
$self->log($self->getTTYText($tty));
|
|
||||||
}
|
|
||||||
|
|
||||||
return 1 if $self->getTTYText($tty) =~ /$regexp/;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
# Debugging: Dump the contents of the TTY<n>
|
|
||||||
sub dumpTTYContents {
|
|
||||||
my ($self, $tty) = @_;
|
|
||||||
|
|
||||||
$self->execute("fold -w 80 /dev/vcs${tty} | systemd-cat");
|
|
||||||
}
|
|
||||||
|
|
||||||
# Take a screenshot and return the result as text using optical character
|
|
||||||
# recognition.
|
|
||||||
sub getScreenText {
|
|
||||||
my ($self) = @_;
|
|
||||||
|
|
||||||
system("command -v tesseract &> /dev/null") == 0
|
|
||||||
or die "getScreenText used but enableOCR is false";
|
|
||||||
|
|
||||||
my $text;
|
|
||||||
$self->nest("performing optical character recognition", sub {
|
|
||||||
my $tmpbase = Cwd::abs_path(".")."/ocr";
|
|
||||||
my $tmpin = $tmpbase."in.ppm";
|
|
||||||
|
|
||||||
$self->sendMonitorCommand("screendump $tmpin");
|
|
||||||
|
|
||||||
my $magickArgs = "-filter Catrom -density 72 -resample 300 "
|
|
||||||
. "-contrast -normalize -despeckle -type grayscale "
|
|
||||||
. "-sharpen 1 -posterize 3 -negate -gamma 100 "
|
|
||||||
. "-blur 1x65535";
|
|
||||||
my $tessArgs = "-c debug_file=/dev/null --psm 11 --oem 2";
|
|
||||||
|
|
||||||
$text = `convert $magickArgs $tmpin tiff:- | tesseract - - $tessArgs`;
|
|
||||||
my $status = $? >> 8;
|
|
||||||
unlink $tmpin;
|
|
||||||
|
|
||||||
die "OCR failed with exit code $status" if $status != 0;
|
|
||||||
});
|
|
||||||
return $text;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until a specific regexp matches the textual contents of the screen.
|
|
||||||
sub waitForText {
|
|
||||||
my ($self, $regexp) = @_;
|
|
||||||
$self->nest("waiting for $regexp to appear on the screen", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($retries_remaining) = @_;
|
|
||||||
if ($retries_remaining == 0) {
|
|
||||||
$self->log("Last chance to match /$regexp/ on the screen, which currently contains:");
|
|
||||||
$self->log($self->getScreenText);
|
|
||||||
}
|
|
||||||
|
|
||||||
return 1 if $self->getScreenText =~ /$regexp/;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until it is possible to connect to the X server. Note that
|
|
||||||
# testing the existence of /tmp/.X11-unix/X0 is insufficient.
|
|
||||||
sub waitForX {
|
|
||||||
my ($self, $regexp) = @_;
|
|
||||||
$self->nest("waiting for the X11 server", sub {
|
|
||||||
retry sub {
|
|
||||||
my ($status, $out) = $self->execute("journalctl -b SYSLOG_IDENTIFIER=systemd | grep 'Reached target Current graphical'");
|
|
||||||
return 0 if $status != 0;
|
|
||||||
($status, $out) = $self->execute("[ -e /tmp/.X11-unix/X0 ]");
|
|
||||||
return 1 if $status == 0;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub getWindowNames {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $res = $self->mustSucceed(
|
|
||||||
q{xwininfo -root -tree | sed 's/.*0x[0-9a-f]* \"\([^\"]*\)\".*/\1/; t; d'});
|
|
||||||
return split /\n/, $res;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub waitForWindow {
|
|
||||||
my ($self, $regexp) = @_;
|
|
||||||
$self->nest("waiting for a window to appear", sub {
|
|
||||||
retry sub {
|
|
||||||
my @names = $self->getWindowNames;
|
|
||||||
|
|
||||||
my ($retries_remaining) = @_;
|
|
||||||
if ($retries_remaining == 0) {
|
|
||||||
$self->log("Last chance to match /$regexp/ on the the window list, which currently contains:");
|
|
||||||
$self->log(join(", ", @names));
|
|
||||||
}
|
|
||||||
|
|
||||||
foreach my $n (@names) {
|
|
||||||
return 1 if $n =~ /$regexp/;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub copyFileFromHost {
|
|
||||||
my ($self, $from, $to) = @_;
|
|
||||||
my $s = `cat $from` or die;
|
|
||||||
$s =~ s/'/'\\''/g;
|
|
||||||
$self->mustSucceed("echo '$s' > $to");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
my %charToKey = (
|
|
||||||
'A' => "shift-a", 'N' => "shift-n", '-' => "0x0C", '_' => "shift-0x0C", '!' => "shift-0x02",
|
|
||||||
'B' => "shift-b", 'O' => "shift-o", '=' => "0x0D", '+' => "shift-0x0D", '@' => "shift-0x03",
|
|
||||||
'C' => "shift-c", 'P' => "shift-p", '[' => "0x1A", '{' => "shift-0x1A", '#' => "shift-0x04",
|
|
||||||
'D' => "shift-d", 'Q' => "shift-q", ']' => "0x1B", '}' => "shift-0x1B", '$' => "shift-0x05",
|
|
||||||
'E' => "shift-e", 'R' => "shift-r", ';' => "0x27", ':' => "shift-0x27", '%' => "shift-0x06",
|
|
||||||
'F' => "shift-f", 'S' => "shift-s", '\'' => "0x28", '"' => "shift-0x28", '^' => "shift-0x07",
|
|
||||||
'G' => "shift-g", 'T' => "shift-t", '`' => "0x29", '~' => "shift-0x29", '&' => "shift-0x08",
|
|
||||||
'H' => "shift-h", 'U' => "shift-u", '\\' => "0x2B", '|' => "shift-0x2B", '*' => "shift-0x09",
|
|
||||||
'I' => "shift-i", 'V' => "shift-v", ',' => "0x33", '<' => "shift-0x33", '(' => "shift-0x0A",
|
|
||||||
'J' => "shift-j", 'W' => "shift-w", '.' => "0x34", '>' => "shift-0x34", ')' => "shift-0x0B",
|
|
||||||
'K' => "shift-k", 'X' => "shift-x", '/' => "0x35", '?' => "shift-0x35",
|
|
||||||
'L' => "shift-l", 'Y' => "shift-y", ' ' => "spc",
|
|
||||||
'M' => "shift-m", 'Z' => "shift-z", "\n" => "ret",
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
sub sendKeys {
|
|
||||||
my ($self, @keys) = @_;
|
|
||||||
foreach my $key (@keys) {
|
|
||||||
$key = $charToKey{$key} if exists $charToKey{$key};
|
|
||||||
$self->sendMonitorCommand("sendkey $key");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub sendChars {
|
|
||||||
my ($self, $chars) = @_;
|
|
||||||
$self->nest("sending keys ‘$chars’", sub {
|
|
||||||
$self->sendKeys(split //, $chars);
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Sleep N seconds (in virtual guest time, not real time).
|
|
||||||
sub sleep {
|
|
||||||
my ($self, $time) = @_;
|
|
||||||
$self->succeed("sleep $time");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Forward a TCP port on the host to a TCP port on the guest. Useful
|
|
||||||
# during interactive testing.
|
|
||||||
sub forwardPort {
|
|
||||||
my ($self, $hostPort, $guestPort) = @_;
|
|
||||||
$hostPort = 8080 unless defined $hostPort;
|
|
||||||
$guestPort = 80 unless defined $guestPort;
|
|
||||||
$self->sendMonitorCommand("hostfwd_add tcp::$hostPort-:$guestPort");
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
@ -1,191 +0,0 @@
|
||||||
#! /somewhere/perl -w
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use Machine;
|
|
||||||
use Term::ReadLine;
|
|
||||||
use IO::File;
|
|
||||||
use IO::Pty;
|
|
||||||
use Logger;
|
|
||||||
use Cwd;
|
|
||||||
use POSIX qw(_exit dup2);
|
|
||||||
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
|
|
||||||
|
|
||||||
$SIG{PIPE} = 'IGNORE'; # because Unix domain sockets may die unexpectedly
|
|
||||||
|
|
||||||
STDERR->autoflush(1);
|
|
||||||
|
|
||||||
my $log = new Logger;
|
|
||||||
|
|
||||||
|
|
||||||
# Start vde_switch for each network required by the test.
|
|
||||||
my %vlans;
|
|
||||||
foreach my $vlan (split / /, $ENV{VLANS} || "") {
|
|
||||||
next if defined $vlans{$vlan};
|
|
||||||
# Start vde_switch as a child process. We don't run it in daemon
|
|
||||||
# mode because we want the child process to be cleaned up when we
|
|
||||||
# die. Since we have to make sure that the control socket is
|
|
||||||
# ready, we send a dummy command to vde_switch (via stdin) and
|
|
||||||
# wait for a reply. Note that vde_switch requires stdin to be a
|
|
||||||
# TTY, so we create one.
|
|
||||||
$log->log("starting VDE switch for network $vlan");
|
|
||||||
my $socket = Cwd::abs_path "./vde$vlan.ctl";
|
|
||||||
my $pty = new IO::Pty;
|
|
||||||
my ($stdoutR, $stdoutW); pipe $stdoutR, $stdoutW;
|
|
||||||
my $pid = fork(); die "cannot fork" unless defined $pid;
|
|
||||||
if ($pid == 0) {
|
|
||||||
dup2(fileno($pty->slave), 0);
|
|
||||||
dup2(fileno($stdoutW), 1);
|
|
||||||
exec "vde_switch -s $socket --dirmode 0700" or _exit(1);
|
|
||||||
}
|
|
||||||
close $stdoutW;
|
|
||||||
print $pty "version\n";
|
|
||||||
readline $stdoutR or die "cannot start vde_switch";
|
|
||||||
$ENV{"QEMU_VDE_SOCKET_$vlan"} = $socket;
|
|
||||||
$vlans{$vlan} = $pty;
|
|
||||||
die unless -e "$socket/ctl";
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
my %vms;
|
|
||||||
my $context = "";
|
|
||||||
|
|
||||||
sub createMachine {
|
|
||||||
my ($args) = @_;
|
|
||||||
my $vm = Machine->new({%{$args}, log => $log, redirectSerial => ($ENV{USE_SERIAL} // "0") ne "1"});
|
|
||||||
$vms{$vm->name} = $vm;
|
|
||||||
$context .= "my \$" . $vm->name . " = \$vms{'" . $vm->name . "'}; ";
|
|
||||||
return $vm;
|
|
||||||
}
|
|
||||||
|
|
||||||
foreach my $vmScript (@ARGV) {
|
|
||||||
my $vm = createMachine({startCommand => $vmScript});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub startAll {
|
|
||||||
$log->nest("starting all VMs", sub {
|
|
||||||
$_->start foreach values %vms;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Wait until all VMs have terminated.
|
|
||||||
sub joinAll {
|
|
||||||
$log->nest("waiting for all VMs to finish", sub {
|
|
||||||
$_->waitForShutdown foreach values %vms;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# In interactive tests, this allows the non-interactive test script to
|
|
||||||
# be executed conveniently.
|
|
||||||
sub testScript {
|
|
||||||
eval "$context $ENV{testScript};\n";
|
|
||||||
warn $@ if $@;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
my $nrTests = 0;
|
|
||||||
my $nrSucceeded = 0;
|
|
||||||
|
|
||||||
|
|
||||||
sub subtest {
|
|
||||||
my ($name, $coderef) = @_;
|
|
||||||
$log->nest("subtest: $name", sub {
|
|
||||||
$nrTests++;
|
|
||||||
eval { &$coderef };
|
|
||||||
if ($@) {
|
|
||||||
$log->log("error: $@", { error => 1 });
|
|
||||||
} else {
|
|
||||||
$nrSucceeded++;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub runTests {
|
|
||||||
if (defined $ENV{tests}) {
|
|
||||||
$log->nest("running the VM test script", sub {
|
|
||||||
eval "$context $ENV{tests}";
|
|
||||||
if ($@) {
|
|
||||||
$log->log("error: $@", { error => 1 });
|
|
||||||
die $@;
|
|
||||||
}
|
|
||||||
}, { expanded => 1 });
|
|
||||||
} else {
|
|
||||||
my $term = Term::ReadLine->new('nixos-vm-test');
|
|
||||||
$term->ReadHistory;
|
|
||||||
while (defined ($_ = $term->readline("> "))) {
|
|
||||||
eval "$context $_\n";
|
|
||||||
warn $@ if $@;
|
|
||||||
}
|
|
||||||
$term->WriteHistory;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Copy the kernel coverage data for each machine, if the kernel
|
|
||||||
# has been compiled with coverage instrumentation.
|
|
||||||
$log->nest("collecting coverage data", sub {
|
|
||||||
foreach my $vm (values %vms) {
|
|
||||||
my $gcovDir = "/sys/kernel/debug/gcov";
|
|
||||||
|
|
||||||
next unless $vm->isUp();
|
|
||||||
|
|
||||||
my ($status, $out) = $vm->execute("test -e $gcovDir");
|
|
||||||
next if $status != 0;
|
|
||||||
|
|
||||||
# Figure out where to put the *.gcda files so that the
|
|
||||||
# report generator can find the corresponding kernel
|
|
||||||
# sources.
|
|
||||||
my $kernelDir = $vm->mustSucceed("echo \$(dirname \$(readlink -f /run/current-system/kernel))/.build/linux-*");
|
|
||||||
chomp $kernelDir;
|
|
||||||
my $coverageDir = "/tmp/xchg/coverage-data/$kernelDir";
|
|
||||||
|
|
||||||
# Copy all the *.gcda files.
|
|
||||||
$vm->execute("for d in $gcovDir/nix/store/*/.build/linux-*; do for i in \$(cd \$d && find -name '*.gcda'); do echo \$i; mkdir -p $coverageDir/\$(dirname \$i); cp -v \$d/\$i $coverageDir/\$i; done; done");
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
||||||
$log->nest("syncing", sub {
|
|
||||||
foreach my $vm (values %vms) {
|
|
||||||
next unless $vm->isUp();
|
|
||||||
$vm->execute("sync");
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
||||||
if ($nrTests != 0) {
|
|
||||||
$log->log("$nrSucceeded out of $nrTests tests succeeded",
|
|
||||||
($nrSucceeded < $nrTests ? { error => 1 } : { }));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Create an empty raw virtual disk with the given name and size (in
|
|
||||||
# MiB).
|
|
||||||
sub createDisk {
|
|
||||||
my ($name, $size) = @_;
|
|
||||||
system("qemu-img create -f raw $name ${size}M") == 0
|
|
||||||
or die "cannot create image of size $size";
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
END {
|
|
||||||
$log->nest("cleaning up", sub {
|
|
||||||
foreach my $vm (values %vms) {
|
|
||||||
if ($vm->{pid}) {
|
|
||||||
$log->log("killing " . $vm->{name} . " (pid " . $vm->{pid} . ")");
|
|
||||||
kill 9, $vm->{pid};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
});
|
|
||||||
$log->close();
|
|
||||||
}
|
|
||||||
|
|
||||||
my $now1 = clock_gettime(CLOCK_MONOTONIC);
|
|
||||||
|
|
||||||
runTests;
|
|
||||||
|
|
||||||
my $now2 = clock_gettime(CLOCK_MONOTONIC);
|
|
||||||
|
|
||||||
printf STDERR "test script finished in %.2fs\n", $now2 - $now1;
|
|
||||||
|
|
||||||
exit ($nrSucceeded < $nrTests ? 1 : 0);
|
|
||||||
|
|
@ -1,258 +0,0 @@
|
||||||
{ system
|
|
||||||
, pkgs ? import ../.. { inherit system config; }
|
|
||||||
# Use a minimal kernel?
|
|
||||||
, minimal ? false
|
|
||||||
# Ignored
|
|
||||||
, config ? {}
|
|
||||||
# Modules to add to each VM
|
|
||||||
, extraConfigurations ? [] }:
|
|
||||||
|
|
||||||
with import ./build-vms.nix { inherit system pkgs minimal extraConfigurations; };
|
|
||||||
with pkgs;
|
|
||||||
|
|
||||||
rec {
|
|
||||||
|
|
||||||
inherit pkgs;
|
|
||||||
|
|
||||||
|
|
||||||
testDriver = lib.warn ''
|
|
||||||
Perl VM tests are deprecated and will be removed for 20.09.
|
|
||||||
Please update your tests to use the python test driver.
|
|
||||||
See https://github.com/NixOS/nixpkgs/pull/71684 for details.
|
|
||||||
'' stdenv.mkDerivation {
|
|
||||||
name = "nixos-test-driver";
|
|
||||||
|
|
||||||
buildInputs = [ makeWrapper perl ];
|
|
||||||
|
|
||||||
dontUnpack = true;
|
|
||||||
|
|
||||||
preferLocalBuild = true;
|
|
||||||
|
|
||||||
installPhase =
|
|
||||||
''
|
|
||||||
mkdir -p $out/bin
|
|
||||||
cp ${./test-driver/test-driver.pl} $out/bin/nixos-test-driver
|
|
||||||
chmod u+x $out/bin/nixos-test-driver
|
|
||||||
|
|
||||||
libDir=$out/${perl.libPrefix}
|
|
||||||
mkdir -p $libDir
|
|
||||||
cp ${./test-driver/Machine.pm} $libDir/Machine.pm
|
|
||||||
cp ${./test-driver/Logger.pm} $libDir/Logger.pm
|
|
||||||
|
|
||||||
wrapProgram $out/bin/nixos-test-driver \
|
|
||||||
--prefix PATH : "${lib.makeBinPath [ qemu_test vde2 netpbm coreutils ]}" \
|
|
||||||
--prefix PERL5LIB : "${with perlPackages; makePerlPath [ TermReadLineGnu XMLWriter IOTty FileSlurp ]}:$out/${perl.libPrefix}"
|
|
||||||
'';
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
# Run an automated test suite in the given virtual network.
|
|
||||||
# `driver' is the script that runs the network.
|
|
||||||
runTests = driver:
|
|
||||||
stdenv.mkDerivation {
|
|
||||||
name = "vm-test-run-${driver.testName}";
|
|
||||||
|
|
||||||
requiredSystemFeatures = [ "kvm" "nixos-test" ];
|
|
||||||
|
|
||||||
buildCommand =
|
|
||||||
''
|
|
||||||
mkdir -p $out
|
|
||||||
|
|
||||||
LOGFILE=/dev/null tests='eval $ENV{testScript}; die $@ if $@;' ${driver}/bin/nixos-test-driver
|
|
||||||
|
|
||||||
for i in */xchg/coverage-data; do
|
|
||||||
mkdir -p $out/coverage-data
|
|
||||||
mv $i $out/coverage-data/$(dirname $(dirname $i))
|
|
||||||
done
|
|
||||||
'';
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
makeTest =
|
|
||||||
{ testScript
|
|
||||||
, makeCoverageReport ? false
|
|
||||||
, enableOCR ? false
|
|
||||||
, name ? "unnamed"
|
|
||||||
, ...
|
|
||||||
} @ t:
|
|
||||||
|
|
||||||
let
|
|
||||||
# A standard store path to the vm monitor is built like this:
|
|
||||||
# /tmp/nix-build-vm-test-run-$name.drv-0/vm-state-machine/monitor
|
|
||||||
# The max filename length of a unix domain socket is 108 bytes.
|
|
||||||
# This means $name can at most be 50 bytes long.
|
|
||||||
maxTestNameLen = 50;
|
|
||||||
testNameLen = builtins.stringLength name;
|
|
||||||
|
|
||||||
testDriverName = with builtins;
|
|
||||||
if testNameLen > maxTestNameLen then
|
|
||||||
abort ("The name of the test '${name}' must not be longer than ${toString maxTestNameLen} " +
|
|
||||||
"it's currently ${toString testNameLen} characters long.")
|
|
||||||
else
|
|
||||||
"nixos-test-driver-${name}";
|
|
||||||
|
|
||||||
nodes = buildVirtualNetwork (
|
|
||||||
t.nodes or (if t ? machine then { machine = t.machine; } else { }));
|
|
||||||
|
|
||||||
testScript' =
|
|
||||||
# Call the test script with the computed nodes.
|
|
||||||
if lib.isFunction testScript
|
|
||||||
then testScript { inherit nodes; }
|
|
||||||
else testScript;
|
|
||||||
|
|
||||||
vlans = map (m: m.config.virtualisation.vlans) (lib.attrValues nodes);
|
|
||||||
|
|
||||||
vms = map (m: m.config.system.build.vm) (lib.attrValues nodes);
|
|
||||||
|
|
||||||
ocrProg = tesseract4.override { enableLanguages = [ "eng" ]; };
|
|
||||||
|
|
||||||
imagemagick_tiff = imagemagick_light.override { inherit libtiff; };
|
|
||||||
|
|
||||||
# Generate onvenience wrappers for running the test driver
|
|
||||||
# interactively with the specified network, and for starting the
|
|
||||||
# VMs from the command line.
|
|
||||||
driver = runCommand testDriverName
|
|
||||||
{ buildInputs = [ makeWrapper];
|
|
||||||
testScript = testScript';
|
|
||||||
preferLocalBuild = true;
|
|
||||||
testName = name;
|
|
||||||
}
|
|
||||||
''
|
|
||||||
mkdir -p $out/bin
|
|
||||||
echo "$testScript" > $out/test-script
|
|
||||||
ln -s ${testDriver}/bin/nixos-test-driver $out/bin/
|
|
||||||
vms=($(for i in ${toString vms}; do echo $i/bin/run-*-vm; done))
|
|
||||||
wrapProgram $out/bin/nixos-test-driver \
|
|
||||||
--add-flags "''${vms[*]}" \
|
|
||||||
${lib.optionalString enableOCR
|
|
||||||
"--prefix PATH : '${ocrProg}/bin:${imagemagick_tiff}/bin'"} \
|
|
||||||
--run "export testScript=\"\$(cat $out/test-script)\"" \
|
|
||||||
--set VLANS '${toString vlans}'
|
|
||||||
ln -s ${testDriver}/bin/nixos-test-driver $out/bin/nixos-run-vms
|
|
||||||
wrapProgram $out/bin/nixos-run-vms \
|
|
||||||
--add-flags "''${vms[*]}" \
|
|
||||||
${lib.optionalString enableOCR "--prefix PATH : '${ocrProg}/bin'"} \
|
|
||||||
--set tests 'startAll; joinAll;' \
|
|
||||||
--set VLANS '${toString vlans}' \
|
|
||||||
${lib.optionalString (builtins.length vms == 1) "--set USE_SERIAL 1"}
|
|
||||||
''; # "
|
|
||||||
|
|
||||||
passMeta = drv: drv // lib.optionalAttrs (t ? meta) {
|
|
||||||
meta = (drv.meta or {}) // t.meta;
|
|
||||||
};
|
|
||||||
|
|
||||||
test = passMeta (runTests driver);
|
|
||||||
report = passMeta (releaseTools.gcovReport { coverageRuns = [ test ]; });
|
|
||||||
|
|
||||||
nodeNames = builtins.attrNames nodes;
|
|
||||||
invalidNodeNames = lib.filter
|
|
||||||
(node: builtins.match "^[A-z_][A-z0-9_]+$" node == null) nodeNames;
|
|
||||||
|
|
||||||
in
|
|
||||||
if lib.length invalidNodeNames > 0 then
|
|
||||||
throw ''
|
|
||||||
Cannot create machines out of (${lib.concatStringsSep ", " invalidNodeNames})!
|
|
||||||
All machines are referenced as perl variables in the testing framework which will break the
|
|
||||||
script when special characters are used.
|
|
||||||
|
|
||||||
Please stick to alphanumeric chars and underscores as separation.
|
|
||||||
''
|
|
||||||
else
|
|
||||||
(if makeCoverageReport then report else test) // {
|
|
||||||
inherit nodes driver test;
|
|
||||||
};
|
|
||||||
|
|
||||||
runInMachine =
|
|
||||||
{ drv
|
|
||||||
, machine
|
|
||||||
, preBuild ? ""
|
|
||||||
, postBuild ? ""
|
|
||||||
, ... # ???
|
|
||||||
}:
|
|
||||||
let
|
|
||||||
vm = buildVM { }
|
|
||||||
[ machine
|
|
||||||
{ key = "run-in-machine";
|
|
||||||
networking.hostName = "client";
|
|
||||||
nix.readOnlyStore = false;
|
|
||||||
virtualisation.writableStore = false;
|
|
||||||
}
|
|
||||||
];
|
|
||||||
|
|
||||||
buildrunner = writeText "vm-build" ''
|
|
||||||
source $1
|
|
||||||
|
|
||||||
${coreutils}/bin/mkdir -p $TMPDIR
|
|
||||||
cd $TMPDIR
|
|
||||||
|
|
||||||
exec $origBuilder $origArgs
|
|
||||||
'';
|
|
||||||
|
|
||||||
testScript = ''
|
|
||||||
startAll;
|
|
||||||
$client->waitForUnit("multi-user.target");
|
|
||||||
${preBuild}
|
|
||||||
$client->succeed("env -i ${bash}/bin/bash ${buildrunner} /tmp/xchg/saved-env >&2");
|
|
||||||
${postBuild}
|
|
||||||
$client->succeed("sync"); # flush all data before pulling the plug
|
|
||||||
'';
|
|
||||||
|
|
||||||
vmRunCommand = writeText "vm-run" ''
|
|
||||||
xchg=vm-state-client/xchg
|
|
||||||
${coreutils}/bin/mkdir $out
|
|
||||||
${coreutils}/bin/mkdir -p $xchg
|
|
||||||
|
|
||||||
for i in $passAsFile; do
|
|
||||||
i2=''${i}Path
|
|
||||||
_basename=$(${coreutils}/bin/basename ''${!i2})
|
|
||||||
${coreutils}/bin/cp ''${!i2} $xchg/$_basename
|
|
||||||
eval $i2=/tmp/xchg/$_basename
|
|
||||||
${coreutils}/bin/ls -la $xchg
|
|
||||||
done
|
|
||||||
|
|
||||||
unset i i2 _basename
|
|
||||||
export | ${gnugrep}/bin/grep -v '^xchg=' > $xchg/saved-env
|
|
||||||
unset xchg
|
|
||||||
|
|
||||||
export tests='${testScript}'
|
|
||||||
${testDriver}/bin/nixos-test-driver ${vm.config.system.build.vm}/bin/run-*-vm
|
|
||||||
''; # */
|
|
||||||
|
|
||||||
in
|
|
||||||
lib.overrideDerivation drv (attrs: {
|
|
||||||
requiredSystemFeatures = [ "kvm" ];
|
|
||||||
builder = "${bash}/bin/sh";
|
|
||||||
args = ["-e" vmRunCommand];
|
|
||||||
origArgs = attrs.args;
|
|
||||||
origBuilder = attrs.builder;
|
|
||||||
});
|
|
||||||
|
|
||||||
|
|
||||||
runInMachineWithX = { require ? [], ... } @ args:
|
|
||||||
let
|
|
||||||
client =
|
|
||||||
{ ... }:
|
|
||||||
{
|
|
||||||
inherit require;
|
|
||||||
imports = [
|
|
||||||
../tests/common/auto.nix
|
|
||||||
];
|
|
||||||
virtualisation.memorySize = 1024;
|
|
||||||
services.xserver.enable = true;
|
|
||||||
test-support.displayManager.auto.enable = true;
|
|
||||||
services.xserver.displayManager.defaultSession = "none+icewm";
|
|
||||||
services.xserver.windowManager.icewm.enable = true;
|
|
||||||
};
|
|
||||||
in
|
|
||||||
runInMachine ({
|
|
||||||
machine = client;
|
|
||||||
preBuild =
|
|
||||||
''
|
|
||||||
$client->waitForX;
|
|
||||||
'';
|
|
||||||
} // args);
|
|
||||||
|
|
||||||
|
|
||||||
simpleTest = as: (makeTest as).test;
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
f: {
|
|
||||||
system ? builtins.currentSystem,
|
|
||||||
pkgs ? import ../.. { inherit system; config = {}; },
|
|
||||||
...
|
|
||||||
} @ args:
|
|
||||||
|
|
||||||
with import ../lib/testing.nix { inherit system pkgs; };
|
|
||||||
|
|
||||||
makeTest (if pkgs.lib.isFunction f then f (args // { inherit pkgs; inherit (pkgs) lib; }) else f)
|
|
||||||
Loading…
Reference in New Issue