pyrox.dev
1#! /somewhere/perl -w
2
3use strict;
4use Machine;
5use Term::ReadLine;
6use IO::File;
7use IO::Pty;
8use Logger;
9use Cwd;
10use POSIX qw(_exit dup2);
11use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
12
13$SIG{PIPE} = 'IGNORE'; # because Unix domain sockets may die unexpectedly
14
15STDERR->autoflush(1);
16
17my $log = new Logger;
18
19
20# Start vde_switch for each network required by the test.
21my %vlans;
22foreach my $vlan (split / /, $ENV{VLANS} || "") {
23 next if defined $vlans{$vlan};
24 # Start vde_switch as a child process. We don't run it in daemon
25 # mode because we want the child process to be cleaned up when we
26 # die. Since we have to make sure that the control socket is
27 # ready, we send a dummy command to vde_switch (via stdin) and
28 # wait for a reply. Note that vde_switch requires stdin to be a
29 # TTY, so we create one.
30 $log->log("starting VDE switch for network $vlan");
31 my $socket = Cwd::abs_path "./vde$vlan.ctl";
32 my $pty = new IO::Pty;
33 my ($stdoutR, $stdoutW); pipe $stdoutR, $stdoutW;
34 my $pid = fork(); die "cannot fork" unless defined $pid;
35 if ($pid == 0) {
36 dup2(fileno($pty->slave), 0);
37 dup2(fileno($stdoutW), 1);
38 exec "vde_switch -s $socket --dirmode 0700" or _exit(1);
39 }
40 close $stdoutW;
41 print $pty "version\n";
42 readline $stdoutR or die "cannot start vde_switch";
43 $ENV{"QEMU_VDE_SOCKET_$vlan"} = $socket;
44 $vlans{$vlan} = $pty;
45 die unless -e "$socket/ctl";
46}
47
48
49my %vms;
50my $context = "";
51
52sub createMachine {
53 my ($args) = @_;
54 my $vm = Machine->new({%{$args}, log => $log, redirectSerial => ($ENV{USE_SERIAL} // "0") ne "1"});
55 $vms{$vm->name} = $vm;
56 $context .= "my \$" . $vm->name . " = \$vms{'" . $vm->name . "'}; ";
57 return $vm;
58}
59
60foreach my $vmScript (@ARGV) {
61 my $vm = createMachine({startCommand => $vmScript});
62}
63
64
65sub startAll {
66 $log->nest("starting all VMs", sub {
67 $_->start foreach values %vms;
68 });
69}
70
71
72# Wait until all VMs have terminated.
73sub joinAll {
74 $log->nest("waiting for all VMs to finish", sub {
75 $_->waitForShutdown foreach values %vms;
76 });
77}
78
79
80# In interactive tests, this allows the non-interactive test script to
81# be executed conveniently.
82sub testScript {
83 eval "$context $ENV{testScript};\n";
84 warn $@ if $@;
85}
86
87
88my $nrTests = 0;
89my $nrSucceeded = 0;
90
91
92sub subtest {
93 my ($name, $coderef) = @_;
94 $log->nest("subtest: $name", sub {
95 $nrTests++;
96 eval { &$coderef };
97 if ($@) {
98 $log->log("error: $@", { error => 1 });
99 } else {
100 $nrSucceeded++;
101 }
102 });
103}
104
105
106sub runTests {
107 if (defined $ENV{tests}) {
108 $log->nest("running the VM test script", sub {
109 eval "$context $ENV{tests}";
110 if ($@) {
111 $log->log("error: $@", { error => 1 });
112 die $@;
113 }
114 }, { expanded => 1 });
115 } else {
116 my $term = Term::ReadLine->new('nixos-vm-test');
117 $term->ReadHistory;
118 while (defined ($_ = $term->readline("> "))) {
119 eval "$context $_\n";
120 warn $@ if $@;
121 }
122 $term->WriteHistory;
123 }
124
125 # Copy the kernel coverage data for each machine, if the kernel
126 # has been compiled with coverage instrumentation.
127 $log->nest("collecting coverage data", sub {
128 foreach my $vm (values %vms) {
129 my $gcovDir = "/sys/kernel/debug/gcov";
130
131 next unless $vm->isUp();
132
133 my ($status, $out) = $vm->execute("test -e $gcovDir");
134 next if $status != 0;
135
136 # Figure out where to put the *.gcda files so that the
137 # report generator can find the corresponding kernel
138 # sources.
139 my $kernelDir = $vm->mustSucceed("echo \$(dirname \$(readlink -f /run/current-system/kernel))/.build/linux-*");
140 chomp $kernelDir;
141 my $coverageDir = "/tmp/xchg/coverage-data/$kernelDir";
142
143 # Copy all the *.gcda files.
144 $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");
145 }
146 });
147
148 $log->nest("syncing", sub {
149 foreach my $vm (values %vms) {
150 next unless $vm->isUp();
151 $vm->execute("sync");
152 }
153 });
154
155 if ($nrTests != 0) {
156 $log->log("$nrSucceeded out of $nrTests tests succeeded",
157 ($nrSucceeded < $nrTests ? { error => 1 } : { }));
158 }
159}
160
161
162# Create an empty raw virtual disk with the given name and size (in
163# MiB).
164sub createDisk {
165 my ($name, $size) = @_;
166 system("qemu-img create -f raw $name ${size}M") == 0
167 or die "cannot create image of size $size";
168}
169
170
171END {
172 $log->nest("cleaning up", sub {
173 foreach my $vm (values %vms) {
174 if ($vm->{pid}) {
175 $log->log("killing " . $vm->{name} . " (pid " . $vm->{pid} . ")");
176 kill 9, $vm->{pid};
177 }
178 }
179 });
180 $log->close();
181}
182
183my $now1 = clock_gettime(CLOCK_MONOTONIC);
184
185runTests;
186
187my $now2 = clock_gettime(CLOCK_MONOTONIC);
188
189printf STDERR "test script finished in %.2fs\n", $now2 - $now1;
190
191exit ($nrSucceeded < $nrTests ? 1 : 0);