Commit ffd44243 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap ImageTests

parent a8e9c6d2
......@@ -17,6 +17,10 @@ our $DEFAULT_PID = $ENV{'TBTS_PROJECT'} || 'tbres';
our $DEFAULT_GID = $ENV{'TBTS_GROUP'} || '';
our $DEBUG_XML_CLIENT = $ENV{'TBTS_DEBUG'} || 0;
our $CMDLINE_OPTIONS = {};
our @EXPERIMENT_OPS_PARAMS = ('noemail' => 1);
our $concurrent_prerun_jobs = 4;
our $concurrent_node_usage = 20;
our $EMULAB_SUFFIX = "emulab.net";
sub get_emulab_user {
my $cert = slurp($SSL_CLIENT_CERT);
......
ImageTest
Parameters
OldTests
Cleanup SSH
DOCS TODO
backoff example
......
......@@ -57,6 +57,10 @@ has 'errors' => ( isa => 'ArrayRef', is => 'rw', default => sub { [ ] } );
sub push_success { push @{shift->successes}, shift; }
sub push_error { push @{shift->errors}, shift; }
sub has_errors { scalar @{shift->errors};}
sub successful { ! shift->has_errors;}
sub sorted_results {
return map { $_->result } (sort { $a->itemid <=> $b->itemid } @{shift->successes});
}
sub handle_result {
my ($self, $result) = @_;
if ( $result->is_error ) { $self->push_error($result); }
......@@ -279,6 +283,11 @@ sub max_work {
$s->workloop;
}
sub worksubs {
my $items = [@_];
return max_work(scalar @$items, sub { $_[0]->() } , $items);
}
sub doItem { my ($s, $itemid) = @_; $s->proc->($s->items->[$itemid]); }
package TestBed::ForkFramework::WeightedScheduler::Task;
......
......@@ -3,8 +3,9 @@ package TestBed::TestSuite;
use SemiModern::Perl;
use TestBed::TestSuite::Experiment;
use TestBed::ParallelRunner;
use TestBed::ForkFramework;
use Data::Dumper;
use Tools;
use Tools qw(concretize);
my $error_sub = sub {
use Carp qw(longmess);
......@@ -17,7 +18,7 @@ my $error_sub = sub {
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(e CartProd CartProdRunner concretize defaults override rege runtests pr_e);
our @EXPORT = qw(e CartProd CartProdRunner concretize defaults override rege runtests pr_e prun prunout);
sub e { TestBed::TestSuite::Experiment->new(_build_e_from_positionals(@_)); }
......@@ -112,6 +113,17 @@ sub override {
return { %{($params || {})}, %overrides };
}
sub prun {
my $results = TestBed::ForkFramework::ForEach::worksubs( @_);
die ("prun item failed", $results) if ($results->has_errors);
return $results;
}
sub prunout {
my $results = prun(@_);
return $results->sorted_results;
}
=head1 NAME
TestBed::TestSuite
......
......@@ -23,13 +23,28 @@ framwork class for starting and testing experiments
=over 4
=item C<< $e->resolve($nodename) >>
resolves node name into a fully qualified node name
=cut
sub resolve {
my ($e, $name) = @_;
if ($name !~ m{\.}) {
my $eid = $e->eid;
my $pid = $e->pid;
my $suffix = $TBConfig::EMULAB_SUFFIX;
return "$name.$eid.$pid.$suffix";
}
return $name;
}
=item C<< $e->node($nodename) >>
returns a node object representing node $nodename in the experiment
=cut
sub node {
my ($e, $nodename) = @_;
TestBed::TestSuite::Node->new('experiment' => $e, 'name' => $nodename);
TestBed::TestSuite::Node->new('experiment' => $e, 'name' => $e->resolve($nodename));
}
=item C<< $e->link($linkname) >>
......@@ -181,12 +196,10 @@ splats $data to $filename on each node
=cut
sub splat {
my ($e, $data, $fn) = @_;
my $temp = splat_to_temp($data);
my $temp = Tools::splat_to_temp($data);
my $rc = 0;
for (@{$e->nodes}) {
my $user = $TBConfig::EMULAB_USER;
my $host = $_->name;
my $dest = "$user\@$host:$fn";
my $dest = $_->build_remote_name($fn);
my @results = $_->scp($temp, $dest);
$rc ||= $results[0];
die "splat to $dest failed" if $rc;
......
......@@ -2,6 +2,7 @@
package TestBed::TestSuite::Node;
use SemiModern::Perl;
use Mouse;
use Tools;
use Tools::Network;
use Tools::TBSSH;
use Data::Dumper;
......@@ -55,6 +56,39 @@ sub scp {
return Tools::TBSSH::scp($self->name, @_);
}
sub build_remote_name {
my ($s, $fn) = @_;
my $user = $TBConfig::EMULAB_USER;
my $host = $s->name;
return "$user\@$host:$fn";
}
sub splat {
my ($s, $data, $fn) = @_;
my $temp = Tools::splat_to_temp($data);
my $dest = $s->build_remote_name($fn);
my @results = $s->scp($temp, $dest);
die "splat to $dest failed" if $results[0];
return 1;
}
sub splatex {
my ($s, $data, $fn) = @_;
$s->splat($data, $fn);
$s->ssh->cmdsuccess("chmod +x $fn");
}
sub slurp {
my ($s, $fn) = @_;
use File::Temp;
my $temp = File::Temp->new;
my $src = $s->build_remote_name($fn);
my @results = $s->scp($src, $temp);
die "spurp from $src failed" if $results[0];
return Tools::slurp($temp);
return 1;
}
=back
=cut
......
......@@ -10,7 +10,7 @@ use Tools;
my $loglevel = "INFO";
$loglevel = "DEBUG" if $TBConfig::DEBUG_XML_CLIENT;
my $logger = init_tbts_logger("XMLRPCClient", undef, "INFO", "SCREEN");
my $logger = Tools::init_tbts_logger("XMLRPCClient", undef, "INFO", "SCREEN");
#ensures loading of client side SSL certificates
......@@ -59,11 +59,11 @@ sub func { (shift->pkgfunclist())[2]; }
sub single_request {
my ($self, $command, @args) = @_;
$logger->debug(toperl($command, @args));
$logger->debug(Tools::toperl($command, @args));
$logger->debug("Sent");
if ($TBConfig::DEBUG_XML_CLIENT) {
say("Sent");
sayperl($command, @args)
Tools::sayperl($command, @args)
}
my $resp = $self->client->send_request($command, $TBConfig::XMLRPC_VERSION, @args);
$logger->debug("Received");
......
......@@ -7,7 +7,7 @@ use Log::Log4perl qw(get_logger :levels);
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(prettytimestamp timestamp sayts sayperl slurp toperl
our @EXPORT_OK = qw(prettytimestamp timestamp sayts sayperl slurp toperl
init_tbts_logger concretize yn_prompt splat_to_temp);
=head1 NAME
......
......@@ -64,6 +64,12 @@ sub cmdsuccess {
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[2] == 0; } );
}
sub cmdoutput {
my ($host, $cmd, $diemessage) = @_;
my @results = wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[2] == 0; }, $diemessage );
return $results[1];
}
sub cmdmatch {
my ($host, $cmd, $regex, $diemessage) = @_;
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[0] =~ $regex; }, $diemessage );
......
......@@ -32,7 +32,7 @@ $ns run
NSEND
sub usage {
say <<"END"
say <<'END'
ShortCut
./sc CMD EID ARGS
......@@ -40,19 +40,28 @@ ShortCut
swapin
swapout
end
endall
watch
watchall
ping
tevc
linktest
single_node_tests
ni // nodeinfo
li // linkinfo
ni // nodeinfo expinfo
li // linkinfo expinfo
fqnn // list fully qualified node names
im // $e->info(aspect => 'mapping'))
ip // $e->info(aspect => 'physical'))
it // $e->info(aspect => 'traces'))
il // $e->info(aspect => 'links'))
ex execute arbitrary perl code
END
}
sub end_all_experiments {
e->pretty_list;
say "";
if (yn_prompt("Are you sure you want to terminate all experiments?")) {
if (Tools::yn_prompt("Are you sure you want to terminate all experiments?")) {
my @experiment_names = experiments_hash_to_list(e->getlist_full);
e(@{$_->[0]})->end for(@experiment_names);
e(@{$_->[0]})->waitforended for(@experiment_names);
......@@ -65,14 +74,14 @@ sub watch {
my $eid = $e->eid;
while ($result) {
my $result = $e->state;
say prettytimestamp . " Watch $eid = $result";
say Tools::prettytimestamp . " Watch $eid = $result";
sleep(2);
}
}
sub watchall {
while (1) {
say prettytimestamp;
say Tools::prettytimestamp;
e->pretty_list;
sleep(5);
}
......
......@@ -16,4 +16,4 @@ Dooh
RedHatAnchient
Dooh
END
ok(concretize($a, OS=>'RedHatAnchient') eq $b, 'concretize templating utility');
ok(Tools::concretize($a, OS=>'RedHatAnchient') eq $b, 'concretize templating utility');
package ImageTests;
use SemiModern::Perl;
use TestBed::TestSuite;
use Test::More;
my $ThreeNodeLan = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
tb-set-node-os $node0 @OS@
set node1 [$ns node]
tb-set-node-os $node1 @OS@
set node2 [$ns node]
tb-set-node-os $node2 @OS@
set lan0 [$ns make-lan "$node0 $node1 $node2 " 100Mb 0ms]
$ns rtproto Static
$ns run
END
my $TwoNodeLink = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
tb-set-node-os $node0 @OS@
set node1 [$ns node]
tb-set-node-os $node1 @OS@
set link0 [$ns duplex-link $node0 $node1 100Mb 0ms DropTail]
$ns rtproto Static
$ns run
END
my $LinkDelay = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
tb-set-node-os $node0 @OS@
set node1 [$ns node]
tb-set-node-os $node1 @OS@
set node2 [$ns node]
tb-set-node-os $node2 @OS@
set link0 [$ns duplex-link $node0 $node1 55Mb 10ms DropTail]
set link1 [$ns duplex-link $node0 $node1 100Mb 0ms DropTail]
tb-set-link-loss $link1 0.01
tb-use-endnodeshaping 1
$ns rtproto Static
$ns run
END
my $LinkTestNSE = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set client1 [$ns node]
tb-set-node-os $client1 @OS@
set router1 [$ns node]
tb-set-node-os $router1 @OS@
set server1 [$ns node]
tb-set-node-os $server1 @OS@
set link0 [$ns duplex-link $client1 $router1 1Mbps 25ms DropTail]
set queue0 [[$ns link $client1 $router1] queue]
$queue0 set limit_ 20
set link1 [$ns duplex-link $router1 $server1 1Mbps 25ms DropTail]
set queue1 [[$ns link $router1 $server1] queue]
$queue1 set limit_ 20
set tcp_src [new Agent/TCP/FullTcp]
$ns attach-agent $client1 $tcp_src
set tcp_sink [new Agent/TCP/FullTcp]
$tcp_sink listen
$ns attach-agent $server1 $tcp_sink
$ns connect $tcp_src $tcp_sink
set ftp [new Application/FTP]
$ftp attach-agent $tcp_src
$ns run
END
my $LinkTestHilat = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
tb-set-node-os $node0 @OS@
set node00 [$ns node]
tb-set-node-os $node00 @OS@
set node000 [$ns node]
tb-set-node-os $node000 @OS@
set node001 [$ns node]
tb-set-node-os $node001 @OS@
set node0010 [$ns node]
tb-set-node-os $node0010 @OS@
set node00100 [$ns node]
tb-set-node-os $node00100 @OS@
set node0000 [$ns node]
tb-set-node-os $node0000 @OS@
set node00000 [$ns node]
tb-set-node-os $node00000 @OS@
set lan0 [$ns make-lan "$node0 $node00 $node000 $node0000 " 1Mb 0ms]
set lan1 [$ns make-lan "$node0000 $node00000 " 100Mb 0ms]
set lan00 [$ns make-lan "$node001 $node0010 $node00100 $node00000 " 1Mb 0ms]
tb-set-node-lan-params $node0 $lan0 100ms 1Mb 0.0
tb-set-node-lan-params $node00 $lan0 100ms 1Mb 0.0
tb-set-node-lan-params $node000 $lan0 100ms 1Mb 0.0
tb-set-node-lan-params $node0000 $lan0 100ms 1Mb 0.0
tb-set-node-lan-params $node0000 $lan1 50ms 100Mb 0.0
tb-set-node-lan-params $node00000 $lan1 50ms 100Mb 0.0
tb-set-node-lan-params $node001 $lan00 100ms 1Mb 0.0
tb-set-node-lan-params $node0010 $lan00 100ms 1Mb 0.0
tb-set-node-lan-params $node00100 $lan00 100ms 1Mb 0.0
tb-set-node-lan-params $node00000 $lan00 100ms 1Mb 0.0
$ns rtproto Static
$ns run
END
my $LinkTestLoBW = <<'END';
set ns [new Simulator]
source tb_compat.tcl
set nodeA [$ns node]
set nodeB [$ns node]
tb-set-node-os $nodeA @OS@
tb-set-node-os $nodeB @OS@
set linkAB [$ns duplex-link $nodeA $nodeB 64kb 50ms DropTail]
tb-set-link-loss $linkAB 0.0
$ns rtproto Static
$ns run
END
my $Router = << 'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
set node1 [$ns node]
set node2 [$ns node]
set node3 [$ns node]
set node4 [$ns node]
tb-set-node-os $node0 @OS@
tb-set-node-os $node1 @OS@
tb-set-node-os $node2 @OS@
tb-set-node-os $node3 @OS@
tb-set-node-os $node4 @OS@
set link0 [$ns duplex-link $node0 $node2 100Mb 0ms DropTail]
set link1 [$ns duplex-link $node1 $node2 100Mb 0ms DropTail]
set link2 [$ns duplex-link $node2 $node3 100Mb 0ms DropTail]
set link3 [$ns duplex-link $node3 $node4 100Mb 0ms DropTail]
$ns rtproto @RTPROTO@
$ns run
END
my $RouterManual = << 'END';
set ns [new Simulator]
source tb_compat.tcl
set node1 [$ns node]
set node2 [$ns node]
set node3 [$ns node]
set nodeA [$ns node]
tb-set-node-os $node1 @OS@
tb-set-node-os $node2 @OS@
tb-set-node-os $node3 @OS@
tb-set-node-os $nodeA @OS@
set lan [$ns make-lan "$node1 $node2 $node3" 100Mb 0ms]
set link [$ns duplex-link $node3 $nodeA 100Mb 0ms DropTail]
tb-set-ip $node1 192.168.1.1
tb-set-ip $node2 192.168.1.2
tb-set-ip-lan $node3 $lan 192.168.1.3
tb-set-netmask $lan 255.255.255.248
tb-set-ip-link $node3 $link 192.168.1.9
tb-set-ip-link $nodeA $link 192.168.1.10
tb-set-netmask $link 255.255.255.252
$node1 add-route $nodeA $node3
$node2 add-route $nodeA $node3
$nodeA add-route $lan $node3
$ns rtproto Manual
$ns run
END
my $Sync= << 'END';
set ns [new Simulator]
source tb_compat.tcl
set node0 [$ns node]
set node1 [$ns node]
set node2 [$ns node]
set node3 [$ns node]
set node4 [$ns node]
tb-set-node-os $node0 @OS@
tb-set-node-os $node1 @OS@
tb-set-node-os $node2 @OS@
tb-set-node-os $node3 @OS@
tb-set-node-os $node4 @OS@
tb-set-sync-server $node0
$ns run
END
my $image_tests = [
['threenodelan', $ThreeNodeLan, 'Simple three node experment connected via a lan'], #lan
['twonodelink', $TwoNodeLink, 'Two node experiment with a single link between them'], #pair
['linkdelay', $LinkDelay, 'Per-Link Traffic Shaping' ],
['linktestnse', $LinkTestNSE, 'Test linktest on a topo with NSE hanging around sucking CPU.'],
['linktesthilat', $LinkTestHilat,'Test linktest on a topo with long delays.'],
['linktestlobw', $LinkTestLoBW, 'Test linktest on a topo with low bandwidth.'],
['router', $Router, '5 node routing experiement'],
['routermanual', $RouterManual, 'Tests manual routing and tb-set-ip/netmask.'],
];
=pod
sub router_test {
test_traceroute 'node0', 'node4', qw(node2-link0 node3-link2 node4-link3);
test_traceroute 'node4', 'node0', qw(node3-link3 node2-link2 node0-link0);
test_traceroute 'node0', 'node1', qw(node2-link0 node1-link1);
test_traceroute 'node1', 'node0', qw(node2-link1 node0-link0);
test_traceroute 'node1', 'node4', qw(node2-link1 node3-link2 node4-link3);
test_traceroute 'node4', 'node1', qw(node3-link3 node2-link2 node1-link1);
}
sub router_manual_test {
test_traceroute 'node1', 'nodeA', qw(node3-lan nodeA-link);
test_traceroute 'nodeA', 'node1', qw(node3-link node1-lan);
test_traceroute 'node2', 'nodeA', qw(node3-lan nodeA-link);
test_traceroute 'nodeA', 'node2', qw(node3-link node2-lan);
test_traceroute 'node3', 'nodeA', qw(nodeA-link);
test_traceroute 'nodeA', 'node3', qw(node3-link);
test_traceroute 'node1', 'node3', qw(node3-lan);
test_traceroute 'node3', 'node1', qw(node1-lan);
}
=cut
my $OS ="RHL90-STD";
sub basic_test {
my $e = shift;
my $eid = $e->eid;
ok($e->single_node_tests, "$eid single_node_tests");
ok($e->linktest, "$eid linktest");
}
for (@$image_tests[0..1]) {
my ($eid, $orig_ns, $desc) = @$_;
my $ns = concretize($orig_ns, OS => 'RHL90-STD');
#say "$eid\n$ns\n$desc";
pr_e(e($eid), $ns, \&basic_test, 2, $desc);
}
sub sync_test {
my %cmds = (
'0' => <<'END',
#!/bin/sh
perl -e 'sleep(rand()*30)'
echo 0 > node0up
/usr/testbed/bin/emulab-sync -i 3
cat node0up node1up node2up > node0res
END
'1' => <<'END',
#!/bin/sh
perl -e 'sleep(rand()*30)'
echo 1 > node1up
/usr/testbed/bin/emulab-sync
cat node0up node1up node2up > node1res
END
'2' => <<'END',
#!/bin/sh
# This wil deadlock unless the asynchronous (-a) option is working
/usr/testbed/bin/emulab-sync -a -i 2 -n barrier2
perl -e 'sleep(rand()*30)'
echo 2 > node2up
/usr/testbed/bin/emulab-sync
cat node0up node1up node2up > node2res
END
'3' => <<'END',
#!/bin/sh
# This wil deadlock unless the asynchronous (-a) option is working
/usr/testbed/bin/emulab-sync
sleep 22
echo 3 > node3up
/usr/testbed/bin/emulab-sync -n barrier2
cat node3up node4up > node3res
END
'4' => <<'END',
#!/bin/sh
echo 4 > node4up
/usr/testbed/bin/emulab-sync -n barrier2
cat node3up node4up > node4res
END
);
my $e = shift;
my @ids = (0..4);
ok( prun( map { my $n = $_; sub { $e->node('node'.$n)->splatex($cmds{$n}, 'startcmd'.$n.'.sh'); } } @ids ) );
ok( prun( map { my $n = $_; sub { $e->node('node'.$n)->ssh->cmdoutput('./startcmd'.$n.'.sh'); } } @ids ) );
my @results = prunout( map { my $n = $_; sub { $e->node('node'.$n)->slurp('node'.$n.'res'); } } @ids );
ok( /^0\n1\n2\n$/ ) for (@results[0..2]);
ok( /^3\n4\n$/ ) for (@results[3..4]);
}
pr_e(e('sync'), concretize($Sync, OS => 'RHL90-STD'), \&sync_test, 7, 'ImageTest-sync test');
1;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment