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