diff options
Diffstat (limited to 'nixos/lib/test-driver/Machine.pm')
-rw-r--r-- | nixos/lib/test-driver/Machine.pm | 568 |
1 files changed, 568 insertions, 0 deletions
diff --git a/nixos/lib/test-driver/Machine.pm b/nixos/lib/test-driver/Machine.pm new file mode 100644 index 000000000000..a28214ea934f --- /dev/null +++ b/nixos/lib/test-driver/Machine.pm @@ -0,0 +1,568 @@ +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); + + +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. + $startCommand = + "qemu-kvm -m 384 " . + "-net nic,model=virtio \$QEMU_OPTS "; + my $iface = $args->{hdaInterface} || "virtio"; + $startCommand .= "-drive file=" . Cwd::abs_path($args->{hda}) . ",if=$iface,boot=on,werror=report " + if defined $args->{hda}; + $startCommand .= "-cdrom $args->{cdrom} " + if defined $args->{cdrom}; + $startCommand .= $args->{qemuFlags} || ""; + } else { + $startCommand = Cwd::abs_path $startCommand; + } + + 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 " . + ($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 = 0; $n < 900; $n++) { + return if &$coderef; + 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; + + local $SIG{ALRM} = sub { die "timed out waiting for the VM to connect\n"; }; + alarm 300; + readline $self->{socket} or die "the VM quit before connecting\n"; + alarm 0; + + $self->log("connected to guest root shell"); + $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) = @_; + my ($status, $lines) = $self->execute("systemctl --no-pager show '$unit'"); + return undef if $status != 0; + my $info = {}; + foreach my $line (split '\n', $lines) { + $line =~ /^([^=]+)=(.*)$/ or next; + $info->{$1} = $2; + } + return $info; +} + + +# Wait for a systemd unit to reach the "active" state. +sub waitForUnit { + my ($self, $unit) = @_; + $self->nest("waiting for unit ‘$unit’", sub { + retry sub { + my $info = $self->getUnitInfo($unit); + my $state = $info->{ActiveState}; + die "unit ‘$unit’ reached state ‘$state’\n" if $state eq "failed"; + 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) = @_; + $self->execute("systemctl start $jobName"); + # FIXME: check result +} + +sub stopJob { + my ($self, $jobName) = @_; + $self->execute("systemctl stop $jobName"); +} + + +# 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("convert $tmp ${filename}") == 0 + or die "cannot convert screenshot"; + unlink $tmp; + }, { image => $name } ); +} + + +# 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("xwininfo -root > /dev/null 2>&1"); + 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; + foreach my $n (@names) { + return 1 if $n =~ /$regexp/; + } + } + }); +} + + +sub copyFileFromHost { + my ($self, $from, $to) = @_; + my $s = `cat $from` or die; + $self->mustSucceed("echo '$s' > $to"); # !!! escaping +} + + +sub sendKeys { + my ($self, @keys) = @_; + foreach my $key (@keys) { + $key = "spc" if $key eq " "; + $key = "ret" if $key eq "\n"; + $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; |