nixpkgs/lib/test-driver/Machine.pm

package Machine;

use strict;
use threads;
use Socket;
use IO::Handle;
use POSIX qw(dup2);
use FileHandle;
use Cwd;


# Stuff our PID in the multicast address/port to prevent collissions
# with other NixOS VM networks.  See
# http://www.iana.org/assignments/multicast-addresses/.
my $mcastPrefix = "232.18";
my $mcastSuffix = ($$ >> 8) . ":" . (64000 + ($$ & 0xff));
print STDERR "using multicast addresses $mcastPrefix.<vlan>.$mcastSuffix\n";
for (my $n = 0; $n < 256; $n++) {
    $ENV{"QEMU_MCAST_ADDR_$n"} = "$mcastPrefix.$n.$mcastSuffix";
}

my $showGraphics = defined $ENV{'DISPLAY'};


sub new {
    my ($class, $args) = @_;

    my $startCommand = $args->{startCommand};
    
    my $name = $args->{name};
    if (!$name) {
        $startCommand =~ /run-(.*)-vm$/;
        $name = $1 || "machine";
    }

    if (!$startCommand) {
        # !!! merge with qemu-vm.nix.
        $startCommand =
            "qemu-system-x86_64 -m 384 " .
            "-net nic,model=virtio -net user,\$QEMU_NET_OPTS \$QEMU_OPTS ";
        $startCommand .= "-drive file=" . Cwd::abs_path($args->{hda}) . ",if=virtio,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";
    
    my $self = {
        startCommand => $startCommand,
        name => $name,
        booted => 0,
        pid => 0,
        connected => 0,
        socket => undef,
        stateDir => "$tmpDir/vm-state-$name",
        monitor => undef,
    };

    mkdir $self->{stateDir}, 0700;

    bless $self, $class;
    return $self;
}


sub log {
    my ($self, $msg) = @_;
    chomp $msg;
    print STDERR $self->{name}, ": $msg\n";
}


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;
        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{USE_TMPDIR} = 1;
        $ENV{QEMU_OPTS} =
            "-no-reboot -monitor unix:./monitor -chardev socket,id=shell,path=./shell " .
            ($showGraphics ? "-serial stdio" : "-nographic");
        $ENV{QEMU_NET_OPTS} = "guestfwd=tcp:10.0.2.6:23-chardev:shell";
        $ENV{QEMU_KERNEL_PARAMS} = "hostTmpDir=$ENV{TMPDIR}";
        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";
        }
    }

    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->start;

    local $SIG{ALRM} = sub { die "timed out waiting for the guest to connect\n"; };
    alarm 300;
    readline $self->{socket} or die;
    alarm 0;
        
    $self->log("connected to guest root shell");
    $self->{connected} = 1;
}


sub waitForShutdown {
    my ($self) = @_;
    return unless $self->{booted};
    
    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;

    $self->log("running command: $command");

    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 succeed {
    my ($self, @commands) = @_;
    my $res;
    foreach my $command (@commands) {
        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) = @_;
    retry sub {
        my ($status, $out) = $self->execute($command);
        return 1 if $status == 0;
    };
}


sub waitUntilFails {
    my ($self, $command) = @_;
    retry sub {
        my ($status, $out) = $self->execute($command);
        return 1 if $status != 0;
    };
}


sub fail {
    my ($self, $command) = @_;
    my ($status, $out) = $self->execute($command);
    die "command `$command' unexpectedly succeeded"
        if $status == 0;
}


sub mustFail {
    fail @_;
}


# Wait for an Upstart job to reach the "running" state.
sub waitForJob {
    my ($self, $jobName) = @_;
    retry sub {
        my ($status, $out) = $self->execute("initctl status $jobName");
        return 1 if $out =~ /start\/running/;
    };
}


# Wait until the specified file exists.
sub waitForFile {
    my ($self, $fileName) = @_;
    retry sub {
        my ($status, $out) = $self->execute("test -e $fileName");
        return 1 if $status == 0;
    }
}

sub startJob {
    my ($self, $jobName) = @_;
    $self->execute("initctl start $jobName");
    my ($status, $out) = $self->execute("initctl status $jobName");
    die "failed to start $jobName" unless $out =~ /start\/running/;
}

sub stopJob {
    my ($self, $jobName) = @_;
    $self->execute("initctl stop $jobName");
    my ($status, $out) = $self->execute("initctl status $jobName");
    die "failed to stop $jobName" unless $out =~ /stop\/waiting/;
}


# Wait until the machine is listening on the given TCP port.
sub waitForOpenPort {
    my ($self, $port) = @_;
    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};

    $self->execute("poweroff");

    $self->waitForShutdown;
}


sub crash {
    my ($self) = @_;
    return unless $self->{booted};

    $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 down");
}


# Make the machine reachable.
sub unblock {
    my ($self) = @_;
    $self->sendMonitorCommand("set_link virtio-net-pci.1 up");
}


# 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";
    $self->sendMonitorCommand("screendump $tmp");
    system("convert $tmp ${filename}") == 0
        or die "cannot convert screenshot";
    unlink $tmp;
}


# 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) = @_;
    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) = @_;
    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->sendKeys(split //, $chars);
}


1;