* Improved logging in the test driver.

* Support subtests.

svn path=/nixos/trunk/; revision=25451

lib/test-driver/Logger.pm

@@ -0,0 +1,68 @@
+package Logger;
+
+use strict;
+use Thread::Queue;
+use XML::Writer;
+
+sub new {
+    my ($class) = @_;
+    
+    my $logFile = defined $ENV{LOGFILE} ? "$ENV{LOGFILE}" : "/dev/null";
+    my $log = new XML::Writer(OUTPUT => new IO::File(">$logFile"));
+    
+    my $self = {
+        log => $log,
+        logQueue => Thread::Queue->new()
+    };
+    
+    $self->{log}->startTag("logfile");
+    
+    bless $self, $class;
+    return $self;
+}
+
+sub close {
+    my ($self) = @_;
+    $self->{log}->endTag("logfile");
+    $self->{log}->end;
+}
+
+sub drainLogQueue {
+    my ($self) = @_;
+    while (defined (my $item = $self->{logQueue}->dequeue_nb())) {
+        $self->{log}->dataElement("line", sanitise($item->{msg}), 'machine' => $item->{machine}, 'type' => 'serial');
+    }
+}
+
+sub maybePrefix {
+    my ($msg, $attrs) = @_;
+    $msg = $attrs->{machine} . ": " . $msg if defined $attrs->{machine};
+    return $msg;
+}
+
+sub nest {
+    my ($self, $msg, $coderef, $attrs) = @_;
+    print STDERR maybePrefix("$msg\n", $attrs);
+    $self->{log}->startTag("nest");
+    $self->{log}->dataElement("head", $msg, %{$attrs});
+    $self->drainLogQueue();
+    &$coderef;
+    $self->drainLogQueue();
+    $self->{log}->endTag("nest");
+}
+
+sub sanitise {
+    my ($s) = @_;
+    $s =~ s/[[:cntrl:]\xff]//g;
+    return $s;
+}
+
+sub log {
+    my ($self, $msg, $attrs) = @_;
+    chomp $msg;
+    print STDERR maybePrefix("$msg\n", $attrs);
+    $self->drainLogQueue();
+    $self->{log}->dataElement("line", $msg, %{$attrs});
+}
+
+1;

lib/test-driver/Machine.pm

@@ -7,6 +7,7 @@ use IO::Handle;
 use POSIX qw(dup2);
 use FileHandle;
 use Cwd;
+use File::Basename;
 
 
 # Stuff our PID in the multicast address/port to prevent collissions
@@ -58,6 +59,7 @@ sub new {
         socket => undef,
         stateDir => "$tmpDir/vm-state-$name",
         monitor => undef,
+        log => $args->{log},
     };
 
     mkdir $self->{stateDir}, 0700;
@@ -69,8 +71,13 @@ sub new {
 
 sub log {
     my ($self, $msg) = @_;
-    chomp $msg;
-    print STDERR $self->{name}, ": $msg\n";
+    $self->{log}->log($msg, { machine => $self->{name} });
+}
+
+
+sub nest {
+    my ($self, $msg, $coderef, $attrs) = @_;
+    $self->{log}->nest($msg, $coderef, { %{$attrs || {}}, machine => $self->{name} });
 }
 
 
@@ -146,7 +153,8 @@ sub start {
         while (<$serialP>) {
             chomp;
             s/\r$//;
-            print STDERR $self->name, "# $_\n";
+            print STDERR $self->{name}, "# $_\n";
+            $self->{log}->{logQueue}->enqueue({msg => $_, machine => $self->{name}}); # !!!
         }
     }
 
@@ -214,26 +222,32 @@ sub connect {
     my ($self) = @_;
     return if $self->{connected};
 
-    $self->start;
+    $self->nest("waiting for the VM to finish booting", sub {
 
-    local $SIG{ALRM} = sub { die "timed out waiting for the guest to connect\n"; };
-    alarm 300;
-    readline $self->{socket} or die;
-    alarm 0;
+        $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;
+        $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;
+
+    $self->nest("waiting for the VM to power off", sub {
+        waitpid $self->{pid}, 0;
+        $self->{pid} = 0;
+        $self->{booted} = 0;
+        $self->{connected} = 0;
+    });
 }
 
 
@@ -243,13 +257,11 @@ sub isUp {
 }
 
 
-sub execute {
+sub execute_ {
     my ($self, $command) = @_;
     
     $self->connect;
 
-    $self->log("running command: $command");
-
     print { $self->{socket} } ("( $command ); echo '|!=EOF' \$?\n");
 
     my $out = "";
@@ -268,17 +280,31 @@ sub execute {
 }
 
 
+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) {
-        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;
+        $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;
 }
 
@@ -290,27 +316,33 @@ sub mustSucceed {
 
 sub waitUntilSucceeds {
     my ($self, $command) = @_;
-    retry sub {
-        my ($status, $out) = $self->execute($command);
-        return 1 if $status == 0;
-    };
+    $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) = @_;
-    retry sub {
-        my ($status, $out) = $self->execute($command);
-        return 1 if $status != 0;
-    };
+    $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) = @_;
-    my ($status, $out) = $self->execute($command);
-    die "command `$command' unexpectedly succeeded"
-        if $status == 0;
+    $self->nest("must fail: $command", sub {
+        my ($status, $out) = $self->execute_($command);
+        die "command `$command' unexpectedly succeeded"
+            if $status == 0;
+    });
 }
 
 
@@ -322,20 +354,24 @@ sub mustFail {
 # 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/;
-    };
+    $self->nest("waiting for job ‘$jobName’", sub {
+        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;
-    }
+    $self->nest("waiting for file ‘$fileName’", sub {
+        retry sub {
+            my ($status, $out) = $self->execute("test -e $fileName");
+            return 1 if $status == 0;
+        }
+    });
 }
 
 sub startJob {
@@ -356,10 +392,12 @@ sub stopJob {
 # 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;
-    }
+    $self->nest("waiting for TCP port $port", sub {
+        retry sub {
+            my ($status, $out) = $self->execute("nc -z localhost $port");
+            return 1 if $status == 0;
+        }
+    });
 }
 
 
@@ -415,10 +453,13 @@ sub screenshot {
     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;
+    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 } );
 }
 
 
@@ -471,7 +512,9 @@ sub sendKeys {
 
 sub sendChars {
     my ($self, $chars) = @_;
-    $self->sendKeys(split //, $chars);
+    $self->nest("sending keys ‘$chars’", sub {
+        $self->sendKeys(split //, $chars);
+    });
 }
 
 

lib/test-driver/test-driver.pl

@@ -4,15 +4,13 @@ use strict;
 use Machine;
 use Term::ReadLine;
 use IO::File;
-use XML::Writer;
+use Logger;
 
 $SIG{PIPE} = 'IGNORE'; # because Unix domain sockets may die unexpectedly
 
 STDERR->autoflush(1);
 
-my $logFile = defined $ENV{LOGFILE} ? "$ENV{LOGFILE}" : "/dev/null";
-my $log = new XML::Writer(OUTPUT => new IO::File(">$logFile"));
-$log->startTag("logfile");
+my $log = new Logger;
 
 
 my %vms;
@@ -20,7 +18,7 @@ my $context = "";
 
 sub createMachine {
     my ($args) = @_;
-    my $vm = Machine->new($args);
+    my $vm = Machine->new({%{$args}, log => $log});
     $vms{$vm->name} = $vm;
     return $vm;
 }
@@ -32,7 +30,9 @@ foreach my $vmScript (@ARGV) {
 
 
 sub startAll {
-    $_->start foreach values %vms;
+    $log->nest("starting all VMs", sub {
+        $_->start foreach values %vms;
+    });
 }
 
 
@@ -44,6 +44,20 @@ sub testScript {
 }
 
 
+my $nrTests = 0;
+my $nrSucceeded = 0;
+
+
+sub subtest {
+    my ($name, $coderef) = @_;
+    $log->nest("subtest: $name", sub {
+        $nrTests++;
+        &$coderef;
+        $nrSucceeded++;
+    });
+}
+
+
 sub runTests {
     if (defined $ENV{tests}) {
         eval "$context $ENV{tests}";
@@ -77,6 +91,10 @@ sub runTests {
         # Copy all the *.gcda files.
         $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");
     }
+
+    if ($nrTests != 0) {
+        #$log->dataElement("line", "$nrSucceeded out of $nrTests tests succeeded");
+    }
 }
 
 
@@ -92,12 +110,11 @@ sub createDisk {
 END {
     foreach my $vm (values %vms) {
         if ($vm->{pid}) {
-            print STDERR "killing ", $vm->{name}, " (pid ", $vm->{pid}, ")\n";
+            $log->log("killing " . $vm->{name} . " (pid " . $vm->{pid} . ")");
             kill 9, $vm->{pid};
         }
     }
-    $log->endTag("logfile");
-    $log->end;
+    $log->close();
 }
 
 

lib/testing.nix

@@ -24,6 +24,7 @@ rec {
         libDir=$out/lib/perl5/site_perl
         mkdir -p $libDir
         cp ${./test-driver/Machine.pm} $libDir/Machine.pm
+        cp ${./test-driver/Logger.pm} $libDir/Logger.pm
 
         wrapProgram $out/bin/nixos-test-driver \
           --prefix PATH : "${imagemagick}/bin" \

tests/login.nix

@@ -6,43 +6,55 @@
 
   testScript =
     ''
-      $machine->mustSucceed("useradd -m alice");
-      $machine->mustSucceed("(echo foobar; echo foobar) | passwd alice");
+      subtest "create user", sub {
+          $machine->succeed("useradd -m alice");
+          $machine->succeed("(echo foobar; echo foobar) | passwd alice");
+      };
 
-      # Log in as alice on a virtual console.      
-      $machine->waitForJob("tty1");
-      $machine->sendChars("alice\n");
-      $machine->waitUntilSucceeds("pgrep login");
-      $machine->execute("sleep 2"); # urgh: wait for `Password:'
-      $machine->sendChars("foobar\n");
-      $machine->waitUntilSucceeds("pgrep -u alice bash");
-      $machine->sendChars("touch done\n");
-      $machine->waitForFile("/home/alice/done");
+      # Log in as alice on a virtual console.
+      subtest "virtual console login", sub {
+          $machine->waitForJob("tty1");
+          $machine->sendChars("alice\n");
+          $machine->waitUntilSucceeds("pgrep login");
+          $machine->execute("sleep 2"); # urgh: wait for `Password:'
+          $machine->sendChars("foobar\n");
+          $machine->waitUntilSucceeds("pgrep -u alice bash");
+          $machine->sendChars("touch done\n");
+          $machine->waitForFile("/home/alice/done");
+      };
       
       # Check whether switching VTs works.
-      $machine->sendKeys("alt-f10");
-      $machine->waitUntilSucceeds("[ \$(fgconsole) = 10 ]");
-      $machine->execute("sleep 2"); # allow fbcondecor to catch up (not important)
-      $machine->screenshot("syslog");
+      subtest "virtual console switching", sub {
+          $machine->sendKeys("alt-f10");
+          $machine->waitUntilSucceeds("[ \$(fgconsole) = 10 ]");
+          $machine->execute("sleep 2"); # allow fbcondecor to catch up (not important)
+          $machine->screenshot("syslog");
+      };
 
       # Check whether ConsoleKit/udev gives and removes device
       # ownership as needed.
-      $machine->mustSucceed("chvt 1");
-      $machine->execute("sleep 1"); # urgh
-      $machine->mustSucceed("getfacl /dev/snd/timer | grep -q alice");
-      $machine->mustSucceed("chvt 2");
-      $machine->execute("sleep 1"); # urgh
-      $machine->mustFail("getfacl /dev/snd/timer | grep -q alice");
+      subtest "device permissions", sub {
+          $machine->succeed("chvt 1");
+          $machine->execute("sleep 1"); # urgh
+          $machine->succeed("getfacl /dev/snd/timer | grep -q alice");
+          $machine->succeed("chvt 2");
+          $machine->execute("sleep 1"); # urgh
+          $machine->fail("getfacl /dev/snd/timer | grep -q alice");
+      };
 
       # Log out.
-      $machine->mustSucceed("chvt 1");
-      $machine->sendChars("exit\n");
-      $machine->waitUntilFails("pgrep -u alice bash");
-      $machine->screenshot("mingetty");
+      subtest "virtual console logout", sub {
+          $machine->succeed("chvt 1");
+          $machine->sendChars("exit\n");
+          $machine->waitUntilFails("pgrep -u alice bash");
+          $machine->screenshot("mingetty");
+      };
       
       # Check whether ctrl-alt-delete works.
-      $machine->sendKeys("ctrl-alt-delete");
-      $machine->waitForShutdown;
+      subtest "ctrl-alt-delete", sub {
+          $machine->sendKeys("ctrl-alt-delete");
+          $machine->waitForShutdown;
+      };
     '';
   
 }