Commit 2bd73a1b authored by Kevin Tew's avatar Kevin Tew

testswap update, includes ssh capability

parent 55e1f5b0
# pull in ExtUtils/AutoInstall.pm from 'inc'
use lib 'inc';
use ExtUtils::AutoInstall (
-core => [ # mandatory modules
'Carp' => '',
'Modern::Perl' => '',
'Mouse' => '',
'RPC::XML::Client' => '',
'RPC::XML' => '',
'Sys::Hostname' => '',
'Test::More' => '',
'Time::Local' => '',
'TAP::Harness' => '',
],
);
=pod
WriteMakefile(
AUTHOR => 'Emula Perl <perl@emulab.net>',
ABSTRACT => 'Perl Testsuite for Emulab',
NAME => 'Testbed::Testsuite',
VERSION_FROM => 'Testbed::Testsuite::Experiment.pm',
DISTNAME => 'Emulab-Testbed',
);
=cut
#!/usr/bin/perl
use Modern::Perl;
use inc::Module::Install;
# Define metadata
name 'tbts';
all_from 'lib/TestBed/XMLRPC/Client.pm';
perl_version '5.010';
author 'Kevin Tew <tewk@flux.utah.edu>';
version '0.01';
# Specific dependencies
requires 'File::Spec' => '0.80';
requires 'Carp' => '1.08';
requires 'Modern::Perl' => '1.03';
requires 'Mouse' => '0.19';
requires 'RPC::XML::Client' => '1.24';
requires 'RPC::XML' => '1.41';
requires 'Sys::Hostname' => '1.11';
requires 'Test::More' => '0.86';
requires 'Time::Local' => '1.1901';
requires 'TAP::Harness' => '3.16';
requires 'Net::SSH::Perl' => '1.34';
requires 'Net::SFTP' => '0.10';
requires 'Crypt::X509' => '0.32';
requires 'Log::Log4perl' => '1.20';
requires 'Log::Dispatch::File' => '1.22';
test_requires 'Test::More' => '0.42';
no_index 'directory' => 'demos';
WriteAll;
TO INSTALL
perl Makefile.PL
make
TO FUN
make test
make t/topologies/basic.t
use Modern::Perl;
package TBConfig;
use Sys::Hostname;
=pod
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw($XMLRPC_SERVER, $CLIENT_CERT, $CLIENT_KEY);
=cut
use Crypt::X509;
use Tools qw(slurp);
use Data::Dumper;
use MIME::Base64;
sub istan {
hostname() =~ /tan/;
}
our $XMLRPC_SERVER = "https://boss.emulab.net:3069/usr/testbed";
our $XMLRPC_VERSION = "0.1";
our $SSL_CLIENT_CERT = "~/.ssl/emulab.cert";
our $SSL_CLIENT_KEY = "~/.ssl/emulabkeyout.pem";
our $DEBUG_XML_CLIENT = istan();
our $XMLRPC_SERVER = "https://boss.emulab.net:3069/usr/testbed";
our $XMLRPC_VERSION = "0.1";
our $SSL_CLIENT_CERT = glob("~/.ssl/emulab.cert");
our $SSL_CLIENT_KEY = glob("~/.ssl/emulabkeyout.pem");
our $EMULAB_USER = get_emulab_user();
sub KEVINS_MOCK_SETUP {
our $XMLRPC_SERVER = "https://localhost:3069/home/tewk/srcs/tbxmlrpctests";
our $SSL_CLIENT_CERT = "mock/client/cl-cert.pem";
our $SSL_CLIENT_KEY = "mock/client/cl-key.pem";
our $DBI_CONNECT_STR = "DBI:mysql:tbdb";
sub get_emulab_user {
my $cert = slurp($SSL_CLIENT_CERT);
$cert =~ s/^-----BEGIN CERTIFICATE-----//;
$cert =~ s/-----END CERTIFICATE-----//;
$cert = decode_base64($cert);
$cert = Crypt::X509->new(cert => $cert);
my $user = $cert->subject_ou;
$user =~ /.*\.(.*)/;
$1
}
1;
xml result codes
DEBUG flags
hand die in middle of a swap
topology dsls
ssh test
test groupings
linkinfo
event system
THINKING ABOUT IT
Test::Class
MOSTLY DONE
Parse NodeInfo
LATER
Client.pm duplicate code elimination - Maybe this would make the code too unreadable
Work on TestSuite::Experiment::Macros
......@@ -2,44 +2,69 @@
use Modern::Perl;
package TestBed::TestSuite::Experiment;
use Mouse;
use TestBed::XMLRPC::Client::Experiment;
use Tools::PingTest;
use Tools::TBSSH;
use Data::Dumper;
use TestBed::XMLRPC::Client::Experiment;
use Test::More;
our @ISA = qw(Test::More);
our @EXPORT = qw(e ep echo newexp batchexp list list_brief list_full launchpingswapkill);
sub ep { TestBed::XMLRPC::Client::Experiment->new() }
sub e { TestBed::XMLRPC::Client::Experiment->new('pid'=> shift, 'eid' => shift) }
sub echo { ep()->echo(@_); }
sub _newexp { my $e = e(shift, shift); $e->batchexp_ns(shift, @_); $e }
sub _newexp_wait { _newexp(@_, 'wait' => 1); }
sub newexp { _newexp(@_); }
sub newexp_wait { _newexp_wait(@_); }
sub batchexp { _newexp(@_); }
sub batchexp_wait { _newexp_wait(@_); }
sub list { ep()->getlist; }
sub list_brief { ep()->getlist_brief; }
sub list_full { ep()->getlist_full; }
sub connectivity_test {
ping("node1.tewkt.tbres.emulab.net");
ping("node2.tewkt.tbres.emulab.net");
extends 'Exporter', 'TestBed::XMLRPC::Client::Experiment';
require Exporter;
our @EXPORT;
push @EXPORT, qw(e ep launchpingkill launchpingswapkill);
sub ep { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid'=> shift, 'eid' => shift) }
sub ping_test {
my ($e) = @_;
my $nodes = $e->nodeinfo();
for (@$nodes) {
ping($_);
}
}
sub ssh_hostname_test {
my ($e) = @_;
my $nodes = $e->nodeinfo();
for (@$nodes) {
Tools::TBSSH::sshhostname($_, $TBConfig::EMULAB_USER);
}
}
sub trytest(&$) {
eval {$_[0]->()};
if ($@) {
say $@;
$_[1]->end;
0;
}
else {
1;
}
}
sub launchpingkill {
my ($pid, $eid, $ns) = @_;
my $e = e($pid, $eid);
trytest {
$e->batchexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->end && die "exp end $eid failed";
} $e;
}
sub launchpingswapkill {
my ($pid, $eid, $ns) = @_;
my $e = e($pid, $eid);
$e->batchexp_ns($ns) && die "batchexp $eid failed";
$e->waitforactive();
connectivity_test($e);
$e->nodeinfo();
$e->swapoutw();
$e->waitforswapped();
$e->swapinw();
$e->waitforactive();
connectivity_test($e);
$e->end();
trytest {
$e->batchexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->swapout_wait && die "swap out $eid failed";
$e->swapin_wait && die "swap in $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->end && die "exp end $eid failed";
} $e;
}
1;
#!/usr/bin/perl
use Modern::Perl;
package TestBed::TestSuite::Experiment::Macros;
use Data::Dumper;
require Exporter;
our @ISA = qw(Test::More);
our @EXPORT =qw(e ep echo newexp batchexp list list_brief list_full);
use TestBed::TestSuite::Experiment;
use Test::More;
sub echo { ep()->echo(@_); }
sub _newexp { my $e = e(shift, shift); $e->batchexp_ns(shift, @_); $e }
sub _newexp_wait { my $e = e(shift, shift); $e->batchexp_ns_wait(shift, @_); $e }
sub newexp { _newexp(@_); }
sub newexp_wait { _newexp_wait(@_); }
sub batchexp { _newexp(@_); }
sub batchexp_wait { _newexp_wait(@_); }
sub list { ep()->getlist; }
sub list_brief { ep()->getlist_brief; }
sub list_full { ep()->getlist_full; }
1;
......@@ -8,18 +8,11 @@ use TBConfig;
use Data::Dumper;
use Carp;
use Tools;
BEGIN {
use TBConfig;
$ENV{HTTPS_CERT_FILE} = glob($TBConfig::SSL_CLIENT_CERT);
$ENV{HTTPS_KEY_FILE} = glob($TBConfig::SSL_CLIENT_KEY);
}
our $DEBUG = $TBConfig::DEBUG_XML_CLIENT;
my $logger = init_tbts_logger("XMLRPCClient", undef, "INFO", "SCREEN");
has 'client' => ( isa => 'RPC::XML::Client', is => 'rw', default => sub {
my $c = RPC::XML::Client->new($TBConfig::XMLRPC_SERVER, 'timeout' => (4*60));
$c->{'__useragent'}->timeout(60*4);
my $c = RPC::XML::Client->new($TBConfig::XMLRPC_SERVER, 'timeout' => (10*60));
$c->{'__useragent'}->timeout(60*10);
$c; } );
our $AUTOLOAD;
......@@ -34,54 +27,58 @@ sub args {
+{ @_ };
}
sub augment {
my $self = shift;
$self->xmlrpc_req_value($self->pkgfunc(), $self->args(@_));
}
sub augment_output {
my $self = shift;
$self->xmlrpc_req_output($self->pkgfunc(), $self->args(@_));
}
sub augment_func {
my $self = shift;
$self->xmlrpc_req_value($self->pkg() . "." . shift, $self->args(@_));
}
sub xmlrpcfunc {
$_[1] =~ m/.*:([^:]*)::([^:]*)/;
my ($package, $func) = ($1, $2);
$func =~ s/\_.*//;
(lc($package) . "." . $func, lc($package), $func);
my ($package, $funcname) = (lc($1), $2);
$funcname =~ s/\_.*//;
("$package.$funcname", $package, $funcname);
}
sub pkgfunclist {
my $c = ((caller(3))[3]);
#say $c;
(shift->xmlrpcfunc($c));
my $caller = ((caller(3))[3]);
(shift->xmlrpcfunc($caller));
}
sub pkgfunc { (shift->pkgfunclist())[0]; }
sub pkg { (shift->pkgfunclist())[1]; }
sub func { (shift->pkgfunclist())[2]; }
sub pkg { (shift->pkgfunclist())[1]; }
sub func { (shift->pkgfunclist())[2]; }
sub single_request {
my ($self, $command, @args) = @_;
if ($DEBUG) {
sayperl($command, @args);
sayts("Sent");
}
$logger->debug(toperl($command, @args));
$logger->debug("Sent");
my $resp = $self->client->send_request($command, $TBConfig::XMLRPC_VERSION, @args);
if ($DEBUG) {
sayts("Received");
say Dumper($resp);
}
$logger->debug("Received");
$logger->debug( sub { Dumper($resp); } );
$resp;
}
sub xmlrpc_req_value { single_request(@_)->value-> {'value'}; }
sub xmlrpc_req_output { single_request(@_)->value-> {'output'}; }
sub xmlrpc_req_code { single_request(@_)->value-> {'code'}; }
sub augment {
my $self = shift;
$self->xmlrpc_req_value($self->pkgfunc(), $self->args(@_));
}
sub augment_output {
my $self = shift;
$self->xmlrpc_req_output($self->pkgfunc(), $self->args(@_));
}
sub augment_code {
my $self = shift;
$self->xmlrpc_req_code($self->pkgfunc(), $self->args(@_));
}
sub augment_func {
my $self = shift;
$self->xmlrpc_req_value($self->pkg() . "." . shift, $self->args(@_));
}
sub augment_func_output {
my $self = shift;
$self->xmlrpc_req_output($self->pkg() . "." . shift, $self->args(@_));
}
sub augment_func_code {
my $self = shift;
$self->xmlrpc_req_code($self->pkg() . "." . shift, $self->args(@_));
}
1;
......@@ -4,6 +4,7 @@ use Modern::Perl;
package TestBed::XMLRPC::Client::Experiment;
use Mouse;
use Data::Dumper;
use TestBed::XMLRPC::Client::NodeInfo;
extends 'TestBed::XMLRPC::Client';
......@@ -21,23 +22,51 @@ sub echo { shift->augment_output( 'str' => shift ); }
sub getlist_brief { shift->augment( 'format' => 'brief'); }
sub getlist_full { shift->augment( 'format' => 'full' ); }
sub batchexp_ns { shift->augment( 'nsfilestr' => shift, @_ ); }
sub swapin { shift->augment_func( 'swapexp', 'direction' => 'in' ); }
sub swapout { shift->augment_func( 'swapexp', 'direction' => 'out' ); }
sub swapinw { shift->augment_func( 'swapexp', 'direction' => 'in', 'wait' => 1 ); }
sub swapoutw { shift->augment_func( 'swapexp', 'direction' => 'out', 'wait' => 1 ); }
sub end { shift->augment_func( 'endexp' ); }
sub waitforswapped { shift->augment_func( 'statewait', 'state' => 'swapped' ); }
sub swapin { shift->augment_func_code( 'swapexp', 'direction' => 'in' ); }
sub swapout { shift->augment_func_code( 'swapexp', 'direction' => 'out' ); }
sub end { shift->augment_func_code( 'endexp' ); }
sub nodeinfo { parseNodeInfo(shift->augment_func_output('expinfo', 'show' => 'nodeinfo')); }
sub waitforactive {
my $self = shift;
$self->augment_code(@_) && die sprintf("wait for swapin %s failed", $self->eid);
}
sub waitforswapped {
my $self = shift;
$self->augment_func_code( 'statewait', 'state' => 'swapped' )
&& die sprintf("wait for swapin %s failed", $self->eid);
}
sub batchexp_ns_wait {
my $self = shift;
$self->batchexp_ns(@_);
$self->waitforactive;
}
sub swapin_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'in', 'wait' => 1 );
$self->waitforactive;
}
sub swapout_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'out', 'wait' => 1 );
$self->waitforswapped
}
sub inject_sub {
my ($fqname, $sub) = @_;
no strict 'refs';
*{ $fqname } = $sub;
}
sub gen_expinfo_funcs {
my ($package) = caller();
for my $funcname (qw( nodeinfo mapping linkinfo shaping) ) {
for my $funcname (qw(mapping linkinfo shaping) ) {
my $sub = sub {
shift->augment_func('expinfo', 'show' => $funcname );
};
no strict 'refs';
*{ $package . '::' . $funcname } = $sub;
inject_sub($package . '::' . $funcname, $sub);
}
}
gen_expinfo_funcs();
1;
#!/usr/bin/perl
use Modern::Perl;
package TestBed::XMLRPC::Client::NodeInfo;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(parseNodeInfo);
use Data::Dumper;
our $ni= <<'END';
Experiment: tbres/tewkt
State: active
Virtual Node Info:
ID Type OS Qualified Name
--------------- ------------ --------------- --------------------
node1 pc node1.tewkt.tbres.emulab.net
node2 pc node2.tewkt.tbres.emulab.net
END
sub splitlines {
my @lines = split(/\n/, $_[0]);
\@lines;
}
sub asplitmatch {
my ($pat, $array) = @_;
my $i = 0;
my $d = 0;
for (@{$array}) {
if ($_ =~ $pat) {
$d = $i;
last;
}
$i++;
};
my @a = @{$array};
my @aa = @a[($d+1) .. $#a];
\@aa;
}
sub project_nodes {
my ($nodes) = @_;
my @nodes;
for (@$nodes) {
if($_ =~ /(\S+)$/) {
push @nodes, $1;
}
}
\@nodes;
}
sub parseNodeInfo {
my ($text) = @_;
project_nodes(asplitmatch(qr/---------------/, splitlines($text)));
}
1;
use Modern::Perl;
package Tools;
use Log::Log4perl qw(get_logger :levels);
#use Log::Log4perl::Appender::Screen
#use Log::Log4perl::Appender::ScreenColoredLevels
#use Log::Log4perl::Appender::File
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(prettytimestamp timestamp sayts sayperl);
our @EXPORT = qw(prettytimestamp timestamp sayts sayperl slurp splat toperl
init_tbts_logger);
sub slurp {
my ($fn) = @_;
open(my $fh, "<", $fn) or die "$fn not found or couldn't be opened";
local( $/ );
my $data = <$fh>;
close($fh);
return $data;
}
sub splat {
my ($fn, $data) = @_;
open(my $fh, ">", $fn);
print $fh $data;
close($fh);
}
sub prettytimestamp {
my $t = shift || time;
......@@ -26,8 +48,12 @@ sub perlit {
map {_perlit($_)} @_;
}
sub toperl {
join(", ", perlit(@_));
}
sub sayperl {
say join(", ", perlit(@_));
say toperl(@_);
}
sub _perlit {
......@@ -55,4 +81,36 @@ sub _perlit {
}
}
sub init_tbts_logger {
my ($name, $file, $level, $app_type) = @_;
$file ||= $name;
$level ||= $INFO;
$app_type ||= 'SCREEN';
my $logger = get_logger($name);
$logger->level($INFO);
$logger->level($DEBUG) if $level =~ /DEBUG/;
my $layout = Log::Log4perl::Layout::PatternLayout->new( "%d %p> %F{1}:%L %M - %m%n");
if ($app_type =~ /FILE/) {
my $appender = Log::Log4perl::Appender->new(
"Log::Log4perl::Appender::File",
filename => timestamp() . $file,
mode => "append",
);
$appender->layout($layout);
$logger->add_appender($appender);
}
elsif ($app_type =~ /SCREEN/) {
my $appender = Log::Log4perl::Appender->new(
"Log::Log4perl::Appender::Screen",
filename => timestamp() . $file,
mode => "append",
);
$appender->layout($layout);
$logger->add_appender($appender);
}
$logger;
}
1;
#!/usr/bin/perl
use Modern::Perl;
use Net::SSH::Perl;
use Net::SFTP;
use Data::UUID;
package Tools::TBSSH;
use Data::Dumper;
sub uuid {
my $ug = new Data::UUID;
my $uuid = $ug->create_hex();
$uuid =~ s/^0x//;
say $uuid;
$uuid;
}
sub path_to_last_part {
my ($volume,$directories,$file) = File::Spec->splitpath( $_[0] );
my @dirs = grep {/\S+/} File::Spec->splitdir( $directories );
if ($file eq '') {
return $dirs[$#dirs];
}
else {
return $file;
}
}
sub sshhostname {
my ($host, $user) = @_;
my $ssh = Net::SSH::Perl->new($host, protocol => "2", options => [ "ForwardAgent yes" ]);
$ssh->login($user);
print [$ssh->cmd('uname -a')]->[0];
return $ssh