pyrox.dev
1package Machine;
2
3use strict;
4use threads;
5use Socket;
6use IO::Handle;
7use POSIX qw(dup2);
8use FileHandle;
9use Cwd;
10use File::Basename;
11use File::Path qw(make_path);
12use File::Slurp;
13
14
15my $showGraphics = defined $ENV{'DISPLAY'};
16
17my $sharedDir;
18
19
20sub new {
21 my ($class, $args) = @_;
22
23 my $startCommand = $args->{startCommand};
24
25 my $name = $args->{name};
26 if (!$name) {
27 $startCommand =~ /run-(.*)-vm$/ if defined $startCommand;
28 $name = $1 || "machine";
29 }
30
31 if (!$startCommand) {
32 # !!! merge with qemu-vm.nix.
33 $startCommand =
34 "qemu-kvm -m 384 " .
35 "-net nic,model=virtio \$QEMU_OPTS ";
36 my $iface = $args->{hdaInterface} || "virtio";
37 $startCommand .= "-drive file=" . Cwd::abs_path($args->{hda}) . ",if=$iface,werror=report "
38 if defined $args->{hda};
39 $startCommand .= "-cdrom $args->{cdrom} "
40 if defined $args->{cdrom};
41 $startCommand .= "-device piix3-usb-uhci -drive id=usbdisk,file=$args->{usb},if=none,readonly -device usb-storage,drive=usbdisk "
42 if defined $args->{usb};
43 $startCommand .= "-bios $args->{bios} "
44 if defined $args->{bios};
45 $startCommand .= $args->{qemuFlags} || "";
46 }
47
48 my $tmpDir = $ENV{'TMPDIR'} || "/tmp";
49 unless (defined $sharedDir) {
50 $sharedDir = $tmpDir . "/xchg-shared";
51 make_path($sharedDir, { mode => 0700, owner => $< });
52 }
53
54 my $allowReboot = 0;
55 $allowReboot = $args->{allowReboot} if defined $args->{allowReboot};
56
57 my $self = {
58 startCommand => $startCommand,
59 name => $name,
60 allowReboot => $allowReboot,
61 booted => 0,
62 pid => 0,
63 connected => 0,
64 socket => undef,
65 stateDir => "$tmpDir/vm-state-$name",
66 monitor => undef,
67 log => $args->{log},
68 redirectSerial => $args->{redirectSerial} // 1,
69 };
70
71 mkdir $self->{stateDir}, 0700;
72
73 bless $self, $class;
74 return $self;
75}
76
77
78sub log {
79 my ($self, $msg) = @_;
80 $self->{log}->log($msg, { machine => $self->{name} });
81}
82
83
84sub nest {
85 my ($self, $msg, $coderef, $attrs) = @_;
86 $self->{log}->nest($msg, $coderef, { %{$attrs || {}}, machine => $self->{name} });
87}
88
89
90sub name {
91 my ($self) = @_;
92 return $self->{name};
93}
94
95
96sub stateDir {
97 my ($self) = @_;
98 return $self->{stateDir};
99}
100
101
102sub start {
103 my ($self) = @_;
104 return if $self->{booted};
105
106 $self->log("starting vm");
107
108 # Create a socket pair for the serial line input/output of the VM.
109 my ($serialP, $serialC);
110 socketpair($serialP, $serialC, PF_UNIX, SOCK_STREAM, 0) or die;
111
112 # Create a Unix domain socket to which QEMU's monitor will connect.
113 my $monitorPath = $self->{stateDir} . "/monitor";
114 unlink $monitorPath;
115 my $monitorS;
116 socket($monitorS, PF_UNIX, SOCK_STREAM, 0) or die;
117 bind($monitorS, sockaddr_un($monitorPath)) or die "cannot bind monitor socket: $!";
118 listen($monitorS, 1) or die;
119
120 # Create a Unix domain socket to which the root shell in the guest will connect.
121 my $shellPath = $self->{stateDir} . "/shell";
122 unlink $shellPath;
123 my $shellS;
124 socket($shellS, PF_UNIX, SOCK_STREAM, 0) or die;
125 bind($shellS, sockaddr_un($shellPath)) or die "cannot bind shell socket: $!";
126 listen($shellS, 1) or die;
127
128 # Start the VM.
129 my $pid = fork();
130 die if $pid == -1;
131
132 if ($pid == 0) {
133 close $serialP;
134 close $monitorS;
135 close $shellS;
136 if ($self->{redirectSerial}) {
137 open NUL, "</dev/null" or die;
138 dup2(fileno(NUL), fileno(STDIN));
139 dup2(fileno($serialC), fileno(STDOUT));
140 dup2(fileno($serialC), fileno(STDERR));
141 }
142 $ENV{TMPDIR} = $self->{stateDir};
143 $ENV{SHARED_DIR} = $sharedDir;
144 $ENV{USE_TMPDIR} = 1;
145 $ENV{QEMU_OPTS} =
146 ($self->{allowReboot} ? "" : "-no-reboot ") .
147 "-monitor unix:./monitor -chardev socket,id=shell,path=./shell " .
148 "-device virtio-serial -device virtconsole,chardev=shell " .
149 ($showGraphics ? "-serial stdio" : "-nographic") . " " . ($ENV{QEMU_OPTS} || "");
150 chdir $self->{stateDir} or die;
151 exec $self->{startCommand};
152 die "running VM script: $!";
153 }
154
155 # Process serial line output.
156 close $serialC;
157
158 threads->create(\&processSerialOutput, $self, $serialP)->detach;
159
160 sub processSerialOutput {
161 my ($self, $serialP) = @_;
162 while (<$serialP>) {
163 chomp;
164 s/\r$//;
165 print STDERR $self->{name}, "# $_\n";
166 $self->{log}->{logQueue}->enqueue({msg => $_, machine => $self->{name}}); # !!!
167 }
168 }
169
170 eval {
171 local $SIG{CHLD} = sub { die "QEMU died prematurely\n"; };
172
173 # Wait until QEMU connects to the monitor.
174 accept($self->{monitor}, $monitorS) or die;
175
176 # Wait until QEMU connects to the root shell socket. QEMU
177 # does so immediately; this doesn't mean that the root shell
178 # has connected yet inside the guest.
179 accept($self->{socket}, $shellS) or die;
180 $self->{socket}->autoflush(1);
181 };
182 die "$@" if $@;
183
184 $self->waitForMonitorPrompt;
185
186 $self->log("QEMU running (pid $pid)");
187
188 $self->{pid} = $pid;
189 $self->{booted} = 1;
190}
191
192
193# Send a command to the monitor and wait for it to finish. TODO: QEMU
194# also has a JSON-based monitor interface now, but it doesn't support
195# all commands yet. We should use it once it does.
196sub sendMonitorCommand {
197 my ($self, $command) = @_;
198 $self->log("sending monitor command: $command");
199 syswrite $self->{monitor}, "$command\n";
200 return $self->waitForMonitorPrompt;
201}
202
203
204# Wait until the monitor sends "(qemu) ".
205sub waitForMonitorPrompt {
206 my ($self) = @_;
207 my $res = "";
208 my $s;
209 while (sysread($self->{monitor}, $s, 1024)) {
210 $res .= $s;
211 last if $res =~ s/\(qemu\) $//;
212 }
213 return $res;
214}
215
216
217# Call the given code reference repeatedly, with 1 second intervals,
218# until it returns 1 or a timeout is reached.
219sub retry {
220 my ($coderef) = @_;
221 my $n;
222 for ($n = 0; $n < 900; $n++) {
223 return if &$coderef;
224 sleep 1;
225 }
226 die "action timed out after $n seconds";
227}
228
229
230sub connect {
231 my ($self) = @_;
232 return if $self->{connected};
233
234 $self->nest("waiting for the VM to finish booting", sub {
235
236 $self->start;
237
238 local $SIG{ALRM} = sub { die "timed out waiting for the VM to connect\n"; };
239 alarm 300;
240 readline $self->{socket} or die "the VM quit before connecting\n";
241 alarm 0;
242
243 $self->log("connected to guest root shell");
244 $self->{connected} = 1;
245
246 });
247}
248
249
250sub waitForShutdown {
251 my ($self) = @_;
252 return unless $self->{booted};
253
254 $self->nest("waiting for the VM to power off", sub {
255 waitpid $self->{pid}, 0;
256 $self->{pid} = 0;
257 $self->{booted} = 0;
258 $self->{connected} = 0;
259 });
260}
261
262
263sub isUp {
264 my ($self) = @_;
265 return $self->{booted} && $self->{connected};
266}
267
268
269sub execute_ {
270 my ($self, $command) = @_;
271
272 $self->connect;
273
274 print { $self->{socket} } ("( $command ); echo '|!=EOF' \$?\n");
275
276 my $out = "";
277
278 while (1) {
279 my $line = readline($self->{socket});
280 die "connection to VM lost unexpectedly" unless defined $line;
281 #$self->log("got line: $line");
282 if ($line =~ /^(.*)\|\!\=EOF\s+(\d+)$/) {
283 $out .= $1;
284 $self->log("exit status $2");
285 return ($2, $out);
286 }
287 $out .= $line;
288 }
289}
290
291
292sub execute {
293 my ($self, $command) = @_;
294 my @res;
295 $self->nest("running command: $command", sub {
296 @res = $self->execute_($command);
297 });
298 return @res;
299}
300
301
302sub succeed {
303 my ($self, @commands) = @_;
304
305 my $res;
306 foreach my $command (@commands) {
307 $self->nest("must succeed: $command", sub {
308 my ($status, $out) = $self->execute_($command);
309 if ($status != 0) {
310 $self->log("output: $out");
311 die "command `$command' did not succeed (exit code $status)\n";
312 }
313 $res .= $out;
314 });
315 }
316
317 return $res;
318}
319
320
321sub mustSucceed {
322 succeed @_;
323}
324
325
326sub waitUntilSucceeds {
327 my ($self, $command) = @_;
328 $self->nest("waiting for success: $command", sub {
329 retry sub {
330 my ($status, $out) = $self->execute($command);
331 return 1 if $status == 0;
332 };
333 });
334}
335
336
337sub waitUntilFails {
338 my ($self, $command) = @_;
339 $self->nest("waiting for failure: $command", sub {
340 retry sub {
341 my ($status, $out) = $self->execute($command);
342 return 1 if $status != 0;
343 };
344 });
345}
346
347
348sub fail {
349 my ($self, $command) = @_;
350 $self->nest("must fail: $command", sub {
351 my ($status, $out) = $self->execute_($command);
352 die "command `$command' unexpectedly succeeded"
353 if $status == 0;
354 });
355}
356
357
358sub mustFail {
359 fail @_;
360}
361
362
363sub getUnitInfo {
364 my ($self, $unit) = @_;
365 my ($status, $lines) = $self->execute("systemctl --no-pager show '$unit'");
366 return undef if $status != 0;
367 my $info = {};
368 foreach my $line (split '\n', $lines) {
369 $line =~ /^([^=]+)=(.*)$/ or next;
370 $info->{$1} = $2;
371 }
372 return $info;
373}
374
375
376# Wait for a systemd unit to reach the "active" state.
377sub waitForUnit {
378 my ($self, $unit) = @_;
379 $self->nest("waiting for unit ‘$unit’", sub {
380 retry sub {
381 my $info = $self->getUnitInfo($unit);
382 my $state = $info->{ActiveState};
383 die "unit ‘$unit’ reached state ‘$state’\n" if $state eq "failed";
384 if ($state eq "inactive") {
385 my ($status, $jobs) = $self->execute("systemctl list-jobs --full 2>&1");
386 die "unit ‘$unit’ is inactive and there are no pending jobs\n"
387 if $jobs =~ /No jobs/; # FIXME: fragile
388 }
389 return 1 if $state eq "active";
390 };
391 });
392}
393
394
395sub waitForJob {
396 my ($self, $jobName) = @_;
397 return $self->waitForUnit($jobName);
398}
399
400
401# Wait until the specified file exists.
402sub waitForFile {
403 my ($self, $fileName) = @_;
404 $self->nest("waiting for file ‘$fileName’", sub {
405 retry sub {
406 my ($status, $out) = $self->execute("test -e $fileName");
407 return 1 if $status == 0;
408 }
409 });
410}
411
412sub startJob {
413 my ($self, $jobName) = @_;
414 $self->execute("systemctl start $jobName");
415 # FIXME: check result
416}
417
418sub stopJob {
419 my ($self, $jobName) = @_;
420 $self->execute("systemctl stop $jobName");
421}
422
423
424# Wait until the machine is listening on the given TCP port.
425sub waitForOpenPort {
426 my ($self, $port) = @_;
427 $self->nest("waiting for TCP port $port", sub {
428 retry sub {
429 my ($status, $out) = $self->execute("nc -z localhost $port");
430 return 1 if $status == 0;
431 }
432 });
433}
434
435
436# Wait until the machine is not listening on the given TCP port.
437sub waitForClosedPort {
438 my ($self, $port) = @_;
439 retry sub {
440 my ($status, $out) = $self->execute("nc -z localhost $port");
441 return 1 if $status != 0;
442 }
443}
444
445
446sub shutdown {
447 my ($self) = @_;
448 return unless $self->{booted};
449
450 print { $self->{socket} } ("poweroff\n");
451
452 $self->waitForShutdown;
453}
454
455
456sub crash {
457 my ($self) = @_;
458 return unless $self->{booted};
459
460 $self->log("forced crash");
461
462 $self->sendMonitorCommand("quit");
463
464 $self->waitForShutdown;
465}
466
467
468# Make the machine unreachable by shutting down eth1 (the multicast
469# interface used to talk to the other VMs). We keep eth0 up so that
470# the test driver can continue to talk to the machine.
471sub block {
472 my ($self) = @_;
473 $self->sendMonitorCommand("set_link virtio-net-pci.1 off");
474}
475
476
477# Make the machine reachable.
478sub unblock {
479 my ($self) = @_;
480 $self->sendMonitorCommand("set_link virtio-net-pci.1 on");
481}
482
483
484# Take a screenshot of the X server on :0.0.
485sub screenshot {
486 my ($self, $filename) = @_;
487 my $dir = $ENV{'out'} || Cwd::abs_path(".");
488 $filename = "$dir/${filename}.png" if $filename =~ /^\w+$/;
489 my $tmp = "${filename}.ppm";
490 my $name = basename($filename);
491 $self->nest("making screenshot ‘$name’", sub {
492 $self->sendMonitorCommand("screendump $tmp");
493 system("pnmtopng $tmp > ${filename}") == 0
494 or die "cannot convert screenshot";
495 unlink $tmp;
496 }, { image => $name } );
497}
498
499
500# Take a screenshot and return the result as text using optical character
501# recognition.
502sub getScreenText {
503 my ($self) = @_;
504
505 system("command -v tesseract &> /dev/null") == 0
506 or die "getScreenText used but enableOCR is false";
507
508 my $text;
509 $self->nest("performing optical character recognition", sub {
510 my $tmpbase = Cwd::abs_path(".")."/ocr";
511 my $tmpin = $tmpbase."in.ppm";
512 my $tmpout = "$tmpbase.ppm";
513
514 $self->sendMonitorCommand("screendump $tmpin");
515 system("ppmtopgm $tmpin | pamscale 4 -filter=lanczos > $tmpout") == 0
516 or die "cannot scale screenshot";
517 unlink $tmpin;
518 system("tesseract $tmpout $tmpbase") == 0 or die "OCR failed";
519 unlink $tmpout;
520 $text = read_file("$tmpbase.txt");
521 unlink "$tmpbase.txt";
522 });
523 return $text;
524}
525
526
527# Wait until a specific regexp matches the textual contents of the screen.
528sub waitForText {
529 my ($self, $regexp) = @_;
530 $self->nest("waiting for $regexp to appear on the screen", sub {
531 retry sub {
532 return 1 if $self->getScreenText =~ /$regexp/;
533 }
534 });
535}
536
537
538# Wait until it is possible to connect to the X server. Note that
539# testing the existence of /tmp/.X11-unix/X0 is insufficient.
540sub waitForX {
541 my ($self, $regexp) = @_;
542 $self->nest("waiting for the X11 server", sub {
543 retry sub {
544 my ($status, $out) = $self->execute("journalctl -b SYSLOG_IDENTIFIER=systemd | grep 'session opened'");
545 return 0 if $status != 0;
546 ($status, $out) = $self->execute("xwininfo -root > /dev/null 2>&1");
547 return 1 if $status == 0;
548 }
549 });
550}
551
552
553sub getWindowNames {
554 my ($self) = @_;
555 my $res = $self->mustSucceed(
556 q{xwininfo -root -tree | sed 's/.*0x[0-9a-f]* \"\([^\"]*\)\".*/\1/; t; d'});
557 return split /\n/, $res;
558}
559
560
561sub waitForWindow {
562 my ($self, $regexp) = @_;
563 $self->nest("waiting for a window to appear", sub {
564 retry sub {
565 my @names = $self->getWindowNames;
566 foreach my $n (@names) {
567 return 1 if $n =~ /$regexp/;
568 }
569 }
570 });
571}
572
573
574sub copyFileFromHost {
575 my ($self, $from, $to) = @_;
576 my $s = `cat $from` or die;
577 $self->mustSucceed("echo '$s' > $to"); # !!! escaping
578}
579
580
581sub sendKeys {
582 my ($self, @keys) = @_;
583 foreach my $key (@keys) {
584 $key = "spc" if $key eq " ";
585 $key = "ret" if $key eq "\n";
586 $self->sendMonitorCommand("sendkey $key");
587 }
588}
589
590
591sub sendChars {
592 my ($self, $chars) = @_;
593 $self->nest("sending keys ‘$chars’", sub {
594 $self->sendKeys(split //, $chars);
595 });
596}
597
598
599# Sleep N seconds (in virtual guest time, not real time).
600sub sleep {
601 my ($self, $time) = @_;
602 $self->succeed("sleep $time");
603}
604
605
606# Forward a TCP port on the host to a TCP port on the guest. Useful
607# during interactive testing.
608sub forwardPort {
609 my ($self, $hostPort, $guestPort) = @_;
610 $hostPort = 8080 unless defined $hostPort;
611 $guestPort = 80 unless defined $guestPort;
612 $self->sendMonitorCommand("hostfwd_add tcp::$hostPort-:$guestPort");
613}
614
615
6161;