our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
$VERSION = 1.00;
@ISA = qw(Exporter);
- @EXPORT = qw(
- dbfl_check get_harness_rev grabrepolock_reexec
- findtask @all_lock_tables
+ @EXPORT = qw(dbfl_check get_harness_rev grabrepolock_reexec
+ findtask @all_lock_tables
tcpconnect_queuedaemon plan_search
alloc_resources alloc_resources_rollback_begin_work
resource_check_allocated resource_shared_mark_ready
- built_stash duration_estimator
- csreadconfig ts_get_host_guest
- opendb_state get_timeout
- host_involves_pcipassthrough host_get_pcipassthrough_devs
- link_file_contents create_webfile
- setup_pxeboot setup_pxeboot_local
- await_webspace_fetch_byleaf await_tcp
- remote_perl_script_open remote_perl_script_done sshopts
- host_pxedir
- target_choose_vg target_umount_lv target_await_down
- target_ping_check_down target_ping_check_up
- target_kernkind_check target_kernkind_console_inittab
- target_var target_var_prefix
- selectguest prepareguest more_prepareguest_hvm
- guest_var guest_var_commalist
- prepareguest_part_lvmdisk prepareguest_part_xencfg
- guest_umount_lv guest_await guest_await_dhcp_tcp
- guest_checkrunning guest_check_ip guest_find_ether
- guest_find_domid guest_check_up guest_check_up_quick
- guest_get_state guest_await_reboot guest_destroy
- guest_vncsnapshot_begin guest_vncsnapshot_stash
- guest_check_remus_ok guest_editconfig
- dir_identify_vcs build_clone
- hg_dir_revision git_dir_revision vcs_dir_revision
- store_revision store_vcs_revision
- toolstack authorized_keys
+ duration_estimator
+ opendb_state
);
%EXPORT_TAGS = ( );
QueuePlanUpdateInterval => 300, # seconds
);
-our %timeout= qw(RebootDown 100
- RebootUp 400
- HardRebootUp 600);
-
#---------- configuration reader etc. ----------
sub opendb_tests () {
$dbh_tests ||= $mjobdb->open();
}
-sub csreadconfig () {
- readconfigonly();
- opendb_tests();
-}
-
sub grabrepolock_reexec {
my (@org_argv) = @_;
my $repos_lock= "$c{Repos}/lock";
return $rev;
}
-#---------- test script startup ----------
-
-sub ts_get_host_guest { # pass this @ARGV
- my ($gn,$whhost) = reverse @_;
- $whhost ||= 'host';
- $gn ||= 'guest';
-
- my $ho= selecthost($whhost);
- my $gho= selectguest($gn,$ho);
- return ($ho,$gho);
-}
-
#---------- database access ----------#
sub opendb_state () {
return $dbh;
}
-#---------- building, vcs's, etc. ----------
-
-sub build_clone ($$$$) {
- my ($ho, $which, $builddir, $subdir) = @_;
-
- need_runvars("tree_$which", "revision_$which");
-
- my $tree= $r{"tree_$which"};
- my $timeout= 4000;
-
- my $vcs = $r{"treevcs_$which"};
- if (defined $vcs) {
- } elsif ($tree =~ m/\.hg$/) {
- $vcs= 'hg';
- } elsif ($tree =~ m/\.git$/) {
- $vcs= 'git';
- } else {
- die "unknown vcs for $which $tree ";
- }
-
- if ($vcs eq 'hg') {
-
- target_cmd_build($ho, $timeout, $builddir, <<END.
- hg clone '$tree' $subdir
- cd $subdir
-END
- (length($r{"revision_$which"}) ? <<END : ''));
- hg update '$r{"revision_$which"}'
-END
- } elsif ($vcs eq 'git') {
-
- target_cmd_build($ho, $timeout, $builddir, <<END.
- git clone '$tree' $subdir
- cd $subdir
-END
- (length($r{"revision_$which"}) ? <<END : ''));
- git checkout '$r{"revision_$which"}'
-END
- } else {
- die "$vcs $which $tree ?";
- }
-
- my $rev= vcs_dir_revision($ho, "$builddir/$subdir", $vcs);
- store_vcs_revision($which, $rev, $vcs);
-}
-
-sub dir_identify_vcs ($$) {
- my ($ho,$dir) = @_;
- return target_cmd_output($ho, <<END);
- set -e
- if ! test -e $dir; then echo none; exit 0; fi
- cd $dir
- (test -d .git && echo git) ||
- (test -d .hg && echo hg) ||
- (echo >&2 'unable to determine vcs'; fail)
-END
-}
-
-sub store_revision ($$$;$) {
- my ($ho,$which,$dir,$optional) = @_;
- my $vcs= dir_identify_vcs($ho,$dir);
- return if $optional && $vcs eq 'none';
- my $rev= vcs_dir_revision($ho,$dir,$vcs);
- store_vcs_revision($which,$rev,$vcs);
-}
-
-sub store_vcs_revision ($$$) {
- my ($which,$rev,$vcs) = @_;
- store_runvar("built_vcs_$which", $vcs);
- store_runvar("built_revision_$which", $rev);
-}
-
-sub built_stash ($$$$) {
- my ($ho, $builddir, $distroot, $item) = @_;
- target_cmd($ho, <<END, 300);
- set -xe
- cd $builddir
- cd $distroot
- tar zcf $builddir/$item.tar.gz *
-END
- my $build= "build";
- my $stashleaf= "$build/$item.tar.gz";
- ensuredir("$stash/$build");
- target_getfile($ho, 300,
- "$builddir/$item.tar.gz",
- "$stash/$stashleaf");
- store_runvar("path_$item", $stashleaf);
-}
-
-sub vcs_dir_revision ($$$) {
- my ($ho,$builddir,$vcs) = @_;
- no strict qw(refs);
- return &{"${vcs}_dir_revision"}($ho,$builddir);
-}
-
-sub hg_dir_revision ($$) {
- my ($ho,$builddir) = @_;
- my $rev= target_cmd_output($ho, "cd $builddir && hg identify -ni", 100);
- $rev =~ m/^([0-9a-f]{10,}\+?) (\d+\+?)$/ or die "$builddir $rev ?";
- return "$2:$1";
-}
-
-sub git_dir_revision ($$) {
- my ($ho,$builddir) = @_;
- my $rev= target_cmd_output($ho, "cd $builddir && git rev-parse HEAD^0");
- $rev =~ m/^([0-9a-f]{10,})$/ or die "$builddir $rev ?";
- return "$1";
-}
-
#---------- host (and other resource) allocation ----------
our $taskid;
};
}
-#---------- hosts and guests ----------
-
-sub get_hostflags ($) {
- my ($ident) = @_;
- # may be run outside transaction, or with flights locked
- my $flags= get_runvar_default('all_hostflags', $job, '').','.
- get_runvar_default("${ident}_hostflags", $job, '');
- return grep /./, split /\,/, $flags;
-}
-
-sub host_involves_pcipassthrough ($) {
- my ($ho) = @_;
- return !!grep m/^pcipassthrough\-/, get_hostflags($ho->{Ident});
-}
-
-sub host_get_pcipassthrough_devs ($) {
- my ($ho) = @_;
- my @devs;
- foreach my $prop (values %{ $ho->{Properties} }) {
- next unless $prop->{name} =~ m/^pcipassthrough (\w+)$/;
- my $devtype= $1;
- next unless grep { m/^pcipassthrough-$devtype$/ } get_hostflags($ho);
- $prop->{val} =~ m,^([0-9a-f]+\:[0-9a-f]+\.\d+)/, or
- die "$ho->{Ident} $prop->{val} ?";
- push @devs, {
- DevType => $devtype,
- Bdf => $1,
- Info => $' #'
- };
- }
- return @devs;
-}
-
-sub get_timeout ($$$) {
- my ($ho,$which,$default) = @_;
- return $default + get_host_property($ho, "$which-time-extra", 0);
-}
-
-sub guest_find_tcpcheckport ($) {
- my ($gho) = @_;
- $gho->{TcpCheckPort}= $r{"$gho->{Guest}_tcpcheckport"};
- $gho->{PingBroken}= $r{"$gho->{Guest}_pingbroken"};
-}
-
-sub selectguest ($$) {
- my ($gn,$ho) = @_;
- my $gho= {
- Guest => $gn,
- Name => $r{"${gn}_hostname"},
- CfgPath => $r{"${gn}_cfgpath"},
- Host => $ho,
- };
- foreach my $opt (guest_var_commalist($gho,'options')) {
- $gho->{Options}{$opt}++;
- }
- guest_find_lv($gho);
- guest_find_ether($gho);
- guest_find_tcpcheckport($gho);
- return $gho;
-}
-
-sub guest_find_lv ($) {
- my ($gho) = @_;
- my $gn= $gho->{Guest};
- $gho->{Vg}= $r{"${gn}_vg"};
- $gho->{Lv}= $r{"${gn}_disk_lv"};
- $gho->{Lvdev}= (defined $gho->{Vg} && defined $gho->{Lv})
- ? '/dev/'.$gho->{Vg}.'/'.$gho->{Lv} : undef;
-}
-
-sub guest_find_ether ($) {
- my ($gho) = @_;
- $gho->{Ether}= $r{"$gho->{Guest}_ether"};
-}
-
-sub report_once ($$$) {
- my ($ho, $what, $msg) = @_;
- my $k= "Lastmsg_$what";
- return if defined($ho->{$k}) and $ho->{$k} eq $msg;
- logm($msg);
- $ho->{$k}= $msg;
-}
-
-sub guest_check_ip ($) {
- my ($gho) = @_;
-
- guest_find_ether($gho);
-
- my $leases;
- my $leasesfn = $gho->{DhcpLeases} || $gho->{Host}{DhcpLeases};
-
- if ($leasesfn =~ m,/,) {
- $leases= new IO::File $leasesfn, 'r';
- if (!defined $leases) { return "open $leasesfn: $!"; }
- } else {
- $leases= new IO::Socket::INET(PeerAddr => $leasesfn);
- }
-
- my $lstash= "dhcpleases-$gho->{Guest}";
- my $inlease;
- my $props;
- my $best;
- my @warns;
-
- my $copy= new IO::File "$stash/$lstash.new", 'w';
- $copy or die "$lstash.new $!";
-
- my $saveas= sub {
- my ($fn,$keep) = @_;
-
- while (<$leases>) { print $copy $_ or die $!; }
- die $! unless $leases->eof;
-
- my $rename= sub {
- my ($src,$dst) = @_;
- rename "$stash/$src", "$stash/$dst"
- or $!==&ENOENT
- or die "rename $fn.$keep $!";
- };
- while (--$keep>0) {
- $rename->("$fn.$keep", "$fn.".($keep+1));
- }
- if ($keep>=0) {
- die if $keep;
- $rename->("$fn", "$fn.$keep");
- }
- $copy->close();
- rename "$stash/$lstash.new", "$stash/$fn" or die "$lstash.new $fn $!";
- logm("warning: $_") foreach grep { defined } @warns[0..5];
- logm("$fn: rotated and stashed current leases");
- };
-
- my $badleases= sub {
- my ($m) = @_;
- $m= "$leasesfn:$.: unknown syntax";
- $saveas->("$lstash.bad", 7);
- return $m;
- };
-
- while (<$leases>) {
- print $copy $_ or die $!;
-
- chomp; s/^\s+//; s/\s+$//;
- next if m/^\#/; next unless m/\S/;
- if (m/^lease\s+([0-9.]+)\s+\{$/) {
- return $badleases->("lease inside lease") if defined $inlease;
- $inlease= $1;
- $props= { };
- next;
- }
- if (!m/^\}$/) {
- s/^( hardware \s+ ethernet |
- binding \s+ state
- ) \s+//x
- or
- s/^( [-a-z0-9]+
- ) \s+//x
- or
- return $badleases->("unknown syntax");
- my $prop= $1;
- s/\s*\;$// or return $badleases->("missing semicolon");
- $props->{$prop}= $_;
- next;
- }
- return $badleases->("end lease not inside lease")
- unless defined $inlease;
-
- $props->{' addr'}= $inlease;
- undef $inlease;
-
- # got a lease in $props
-
- # ignore old leases
- next if exists $props->{'binding state'} &&
- lc $props->{'binding state'} ne 'active';
-
- # ignore leases we don't understand
- my @missing= grep { !defined $props->{$_} }
- ('binding state', 'hardware ethernet', 'ends');
- if (@missing) {
- push @warns, "$leasesfn:$.: lease without \`$_'"
- foreach @missing;
- next;
- }
-
- # ignore leases for other hosts
- next unless lc $props->{'hardware ethernet'} eq lc $gho->{Ether};
-
- $props->{' ends'}= $props->{'ends'};
- $props->{' ends'} =~
- s/^[0-6]\s+(\S+)\s+(\d+)\:(\d+\:\d+)$/
- sprintf "%s %02d:%s", $1,$2,$3 /e
- or return $badleases->("unexpected syntax for ends");
-
- next if $best &&
- $best->{' ends'} gt $props->{' ends'};
- $best= $props;
- }
-
- if (!$best) {
- $saveas->("$lstash.nolease", 3);
- return "no active lease";
- }
- $gho->{Ip}= $best->{' addr'};
-
- report_once($gho, 'guest_check_ip',
- "guest $gho->{Name}: $gho->{Ether} $gho->{Ip}");
- return undef;
-}
-
-sub guest_editconfig ($$$) {
- my ($ho, $gho, $code) = @_;
- target_editfile_root($ho, "$gho->{CfgPath}", sub {
- while (<::EI>) {
- $code->();
- print ::EO or die $!;
- }
- die $! if ::EI->error;
- });
-}
-
-sub guest_await_reboot ($$$) {
- my ($ho,$gho, $timeout) = @_;
- poll_loop($timeout, 30, "await reboot request from $gho->{Guest}", sub {
- my $st= guest_get_state($ho,$gho);
- return undef if $st eq 'sr';
- fail("guest unexpectedly shutdown; state is '$st'")
- if $st =~ m/^s/ || $st eq '';
- return "guest state is $st";
- });
-}
-
-sub guest_destroy ($$) {
- my ($ho,$gho) = @_;
- target_cmd_root($ho, toolstack()->{Command}." destroy $gho->{Name}", 40);
-}
-
-sub target_choose_vg ($$) {
- my ($ho, $mbneeded) = @_;
- my $vgs= target_cmd_output_root($ho, 'vgdisplay --colon');
- my $bestkb= 1.0e90;
- my $bestvg;
- foreach my $l (split /\n/, $vgs) {
- $l =~ s/^\s+//; $l =~ s/\s+$//;
- my @l= split /\:/, $l;
- my $tvg= $l[0];
- my $pesize= $l[12];
- my $freepekb= $l[15];
- my $tkb= $l[12] * 1.0 * $l[15];
- if ($tkb < $mbneeded*1024.0) {
- logm("vg $tvg ${tkb}kb free - too small");
- next;
- }
- if ($tkb < $bestkb) {
- $bestvg= $tvg;
- $bestkb= $tkb;
- }
- }
- die "no vg of sufficient size"
- unless defined $bestvg;
- logm("vg $bestvg ${bestkb}kb free - will use");
- return $bestvg;
-}
-
-sub select_ether ($) {
- my ($vn) = @_;
- # must be run outside transaction
- my $ether= $r{$vn};
- return $ether if defined $ether;
- my $prefix= sprintf "%s:%02x", $c{GenEtherPrefix}, $flight & 0xff;
-
- db_retry($flight,'running', $dbh_tests,[qw(flights)], sub {
- my $previous= $dbh_tests->selectrow_array(<<END, {}, $flight);
- SELECT max(val) FROM runvars WHERE flight=?
- AND name LIKE E'%\\_ether'
- AND val LIKE '$prefix:%'
-END
- if (defined $previous) {
- $previous =~ m/^\w+:\w+:\w+:\w+:([0-9a-f]+):([0-9a-f]+)$/i
- or die "$previous ?";
- my $val= (hex($1)<<8) | hex($2);
- $val++; $val &= 0xffff;
- $ether= sprintf "%s:%02x:%02x", $prefix, $val >> 8, $val & 0xff;
- logm("select_ether $prefix:... $ether (previous $previous)");
- } else {
- $ether= "$prefix:00:01";
- logm("select_ether $prefix:... $ether (first in flight)");
- }
- $dbh_tests->do(<<END, {}, $flight,$job,$vn,$ether);
- INSERT INTO runvars VALUES (?,?,?,?,'t')
-END
- my $chkrow= $dbh_tests->selectrow_hashref(<<END,{}, $flight);
- SELECT val, count(*) FROM runvars WHERE flight=?
- AND name LIKE E'%\\_ether'
- AND val LIKE '$prefix:%'
- GROUP BY val
- HAVING count(*) <> 1
- LIMIT 1
-END
- die "$chkrow->{val} $chkrow->{count}" if $chkrow;
- });
- $r{$vn}= $ether;
- return $ether;
-}
-
-sub guest_var ($$$) {
- my ($gho, $runvartail, $default) = @_;
- my $val= $r{ $gho->{Guest}."_".$runvartail }; return $val if defined $val;
- $val= $r{ "guests_$runvartail" }; return $val if defined $val;
- return $default;
-}
-
-sub guest_var_commalist ($$) {
- my ($gho,$runvartail) = @_;
- return split /\,/, guest_var($gho,$runvartail,'');
-}
-
-sub prepareguest ($$$$$$) {
- my ($ho, $gn, $hostname, $tcpcheckport, $mb,
- $boot_timeout) = @_;
- # must be run outside transaction
-
- # If we are passing through a nic, use its mac address not a generated one
- my $ptnichostident= $r{"${gn}_pcipassthrough_nic"};
- if (!$ptnichostident) {
- select_ether("${gn}_ether");
- } else {
- my $ptnicho= selecthost($ptnichostident);
- my $ptnicinfo= get_host_property($ptnicho,'pcipassthrough nic');
- $ptnicinfo =~ m,/, or die "$ptnichostident $ptnicinfo ?";
- my $ptether= $'; #'
- $r{"${gn}_ether"}= $ptether;
- logm("passthrough nic from $ptnichostident ether $ptether");
- }
-
- store_runvar("${gn}_hostname", $hostname);
- store_runvar("${gn}_disk_lv", $r{"${gn}_hostname"}.'-disk');
- store_runvar("${gn}_tcpcheckport", $tcpcheckport);
- store_runvar("${gn}_boot_timeout", $boot_timeout);
-
- my $gho= selectguest($gn, $ho);
- store_runvar("${gn}_domname", $gho->{Name});
-
- store_runvar("${gn}_vg", '');
- if (!length $r{"${gn}_vg"}) {
- store_runvar("${gn}_vg", target_choose_vg($ho, $mb));
- }
-
- guest_find_lv($gho);
- guest_find_ether($gho);
- guest_find_tcpcheckport($gho);
- return $gho;
-}
-
-sub prepareguest_part_lvmdisk ($$$) {
- my ($ho, $gho, $disk_mb) = @_;
- target_cmd_root($ho, "lvremove -f $gho->{Lvdev} ||:");
- target_cmd_root($ho, "lvcreate -L ${disk_mb}M -n $gho->{Lv} $gho->{Vg}");
- target_cmd_root($ho, "dd if=/dev/zero of=$gho->{Lvdev} count=10");
-}
-
-sub prepareguest_part_xencfg ($$$$$) {
- my ($ho, $gho, $ram_mb, $xopts, $cfgrest) = @_;
- my $onreboot= $xopts->{OnReboot} || 'restart';
- my $vcpus= guest_var($gho, 'vcpus', $xopts->{DefVcpus} || 2);
- my $xoptcfg= $xopts->{ExtraConfig};
- $xoptcfg='' unless defined $xoptcfg;
- my $xencfg= <<END;
-name = '$gho->{Name}'
-memory = ${ram_mb}
-vif = [ 'type=ioemu,mac=$gho->{Ether}' ]
-#
-on_poweroff = 'destroy'
-on_reboot = '$onreboot'
-on_crash = 'preserve'
-#
-vcpus = $vcpus
-#
-$cfgrest
-#
-$xoptcfg
-END
-
- my $cfgpath= "/etc/xen/$gho->{Name}.cfg";
- store_runvar("$gho->{Guest}_cfgpath", "$cfgpath");
- $gho->{CfgPath}= $cfgpath;
-
- target_putfilecontents_root_stash($ho,30,$xencfg, $cfgpath);
-
- return $cfgpath;
-}
-
-sub more_prepareguest_hvm ($$$$;@) {
- my ($ho, $gho, $ram_mb, $disk_mb, %xopts) = @_;
-
- my $passwd= 'xenvnc';
-
- prepareguest_part_lvmdisk($ho, $gho, $disk_mb);
-
- my $specimage= $r{"$gho->{Guest}_image"};
- die "$gho->{Guest} ?" unless $specimage;
- my $limage= $specimage =~ m,^/, ? $specimage : "$c{Images}/$specimage";
- $gho->{Rimage}= "/root/$flight.$job.".basename($specimage);
- target_putfile_root($ho, 1000, $limage,$gho->{Rimage}, '-p');
-
- my $postimage_hook= $xopts{PostImageHook};
- $postimage_hook->() if $postimage_hook;
-
- my $cfg = <<END;
-kernel = 'hvmloader'
-builder = 'hvm'
-#
-disk = [
- 'phy:$gho->{Lvdev},hda,w',
- 'file:$gho->{Rimage},hdc:cdrom,r'
- ]
-#
-usb=1
-usbdevice='tablet'
-#
-#stdvga=1
-keymap='en-gb';
-#
-sdl=0
-opengl=0
-vnc=1
-vncunused=1
-vncdisplay=0
-vnclisten='$ho->{Ip}'
-vncpasswd='$passwd'
-
-serial='file:/dev/stderr'
-#
-boot = 'dc'
-END
-
- my $devmodel = $r{'device_model_version'};
- if (defined $devmodel) {
- $cfg .= "device_model_version='$devmodel'\n";
- }
-
- my $cfgpath= prepareguest_part_xencfg($ho, $gho, $ram_mb, \%xopts, $cfg);
- target_cmd_root($ho, <<END);
- (echo $passwd; echo $passwd) | vncpasswd $gho->{Guest}.vncpw
-END
-
- return $cfgpath;
-}
-
-sub guest_check_via_ssh ($) {
- my ($gho) = @_;
- return $r{"$gho->{Guest}_tcpcheckport"} == 22;
-}
-
-sub guest_check_up_quick ($) {
- my ($gho) = @_;
- if (guest_check_via_ssh($gho)) {
- target_cmd_root($gho, "date");
- } else {
- target_ping_check_up($gho);
- }
-}
-
-sub guest_check_up ($) {
- my ($gho) = @_;
- guest_await_dhcp_tcp($gho,20);
- target_ping_check_up($gho);
- target_cmd_root($gho, "echo guest $gho->{Name}: ok")
- if guest_check_via_ssh($gho);
-}
-
-sub guest_get_state ($$) {
- my ($ho,$gho) = @_;
- my $domains= target_cmd_output_root($ho, toolstack()->{Command}." list");
- $domains =~ s/^Name.*\n//;
- foreach my $l (split /\n/, $domains) {
- $l =~ m/^(\S+) (?: \s+ \d+ ){3} \s+ ([-a-z]+) \s/x or die "$l ?";
- next unless $1 eq $gho->{Name};
- my $st= $2;
- $st =~ s/\-//g;
- $st='-' if !length $st;
- logm("guest $gho->{Name} state is $st");
- return $st;
- }
- logm("guest $gho->{Name} not present on this host");
- return '';
-}
-
-our $guest_state_running_re= '[-rb]+';
-
-sub guest_checkrunning ($$) {
- my ($ho,$gho) = @_;
- my $s= guest_get_state($ho,$gho);
- return $s =~ m/^$guest_state_running_re$/o;
-}
-
-sub guest_await_dhcp_tcp ($$) {
- my ($gho,$timeout) = @_;
- guest_find_tcpcheckport($gho);
- poll_loop($timeout,1,
- "guest $gho->{Name} $gho->{Ether} $gho->{TcpCheckPort}".
- " link/ip/tcp",
- sub {
- my $err= guest_check_ip($gho);
- return $err if defined $err;
-
- return
- ($gho->{PingBroken} ? undef : target_ping_check_up($gho))
- ||
- target_tcp_check($gho,5)
- ||
- undef;
- });
-}
-
-sub guest_check_remus_ok {
- my ($gho, @hos) = @_;
- my @sts;
- logm("remus check $gho->{Name}...");
- foreach my $ho (@hos) {
- my $st;
- if (!eval {
- $st= guest_get_state($ho, $gho)
- }) {
- $st= '_';
- logm("could not get guest $gho->{Name} state on $ho->{Name}: $@");
- }
- push @sts, [ $ho, $st ];
- }
- my @ststrings= map { $_->[1] } @sts;
- my $compound= join ',', @ststrings;
- my $msg= "remus check $gho->{Name}: result \"$compound\":";
- $msg .= " $_->[0]{Name}=$_->[1]" foreach @sts;
- logm($msg);
- my $runnings= scalar grep { m/$guest_state_running_re/o } @ststrings;
- die "running on multiple hosts $compound" if $runnings > 1;
- die "not running anywhere $compound" unless $runnings;
- die "crashed somewhere $compound" if grep { m/c/ } @ststrings;
-}
-
-sub file_link_contents ($$) {
- my ($fn, $contents) = @_;
- # $contents as for file_write_contents
- my ($dir, $base, $ext) =
- $fn =~ m,^( (?: .*/ )? )( [^/]+? )( (?: \.[^./]+ )? )$,x
- or die "$fn ?";
- my $real= "$dir$base--osstest$ext";
- my $linktarg= "$base--osstest$ext";
-
- file_simple_write_contents($real, $contents);
-
- my $newlink= "$dir$base--newlink$ext";
-
- if (!lstat "$fn") {
- $!==&ENOENT or die "$fn $!";
- } elsif (!-l _) {
- die "$fn not a symlink";
- unlink $fn or die "$fn $!";
- }
- symlink $linktarg, $newlink or die "$newlink $!";
- rename $newlink, $fn or die "$newlink $fn $!";
- logm("wrote $fn");
-}
-
-sub host_pxedir ($) {
- my ($ho) = @_;
- my $dir= $ho->{Ether};
- $dir =~ y/A-Z/a-z/;
- $dir =~ y/0-9a-f//cd;
- length($dir)==12 or die "$dir";
- $dir =~ s/../$&-/g;
- $dir =~ s/\-$//;
- return $dir;
-}
-
-sub setup_pxeboot ($$) {
- my ($ho, $bootfile) = @_;
- my $dir= host_pxedir($ho);
- file_link_contents($c{Tftp}."/$dir/pxelinux.cfg", $bootfile);
-}
-
-sub setup_pxeboot_local ($) {
- my ($ho) = @_;
- setup_pxeboot($ho, <<END);
-serial 0 $c{Baud}
-timeout 5
-label local
- LOCALBOOT 0
-default local
-END
-}
-
-sub target_umount_lv ($$$) {
- my ($ho,$vg,$lv) = @_;
- my $dev= "/dev/$vg/$lv";
- for (;;) {
- my $link= target_cmd_output_root($ho, "readlink $dev");
- return if $link =~ m,^/dev/nbd,; # can't tell if it's open
- $lv= target_cmd_output_root($ho, "lvdisplay --colon $dev");
- $lv =~ s/^\s+//; $lv =~ s/\s+$//;
- my @lv = split /:/, $lv;
- die "@lv ?" unless $lv[0] eq $dev;
- return unless $lv[5]; # "open"
- logm("lvdisplay output says device is still open: $lv");
- target_cmd_root($ho, "umount $dev");
- }
-}
-
-sub guest_umount_lv ($$) {
- my ($ho,$gho) = @_;
- target_umount_lv($ho, $gho->{Vg}, $gho->{Lv});
-}
-
-sub await_webspace_fetch_byleaf ($$$$$) {
- my ($maxwait,$interval,$logtailer, $ho, $url) = @_;
- my $leaf= $url;
- $leaf =~ s,.*/,,;
- poll_loop($maxwait,$interval, "fetch $leaf", sub {
- my ($line, $last);
- $last= '(none)';
- while (defined($line= $logtailer->getline())) {
- my ($ip, $got) = $line =~
- m,^([0-9.]+) \S+ \S+ \[[^][]+\] \"GET \S*/(\S+) ,
- or next;
- next unless $ip eq $ho->{Ip};
- $last= $got;
- next unless $got eq $leaf;
- return undef;
- }
- return $last;
- });
-}
-
-sub target_tcp_check ($$) {
- my ($ho,$interval) = @_;
- my $ncout= `nc -n -v -z -w $interval $ho->{Ip} $ho->{TcpCheckPort} 2>&1`;
- return undef if !$?;
- $ncout =~ s/\n/ | /g;
- return "nc: $? $ncout";
-}
-
-sub await_tcp ($$$) {
- my ($maxwait,$interval,$ho) = @_;
- poll_loop($maxwait,$interval,
- "await tcp $ho->{Name} $ho->{TcpCheckPort}",
- sub {
- return target_tcp_check($ho,$interval);
- });
-}
-
-sub guest_await ($$) {
- my ($gho,$dhcpwait) = @_;
- guest_await_dhcp_tcp($gho,$dhcpwait);
- target_cmd_root($gho, "echo guest $gho->{Name}: ok")
- if guest_check_via_ssh($gho);
- return $gho;
-}
-
-sub create_webfile ($$$) {
- my ($ho, $tail, $contents) = @_; # $contents as for file_link_contents
- my $wf_common= $c{WebspaceCommon}.$ho->{Name}."_".$tail;
- my $wf_url= $c{WebspaceUrl}.$wf_common;
- my $wf_file= $c{WebspaceFile}.$wf_common;
- file_link_contents($wf_file, $contents);
- return $wf_url;
-}
-
-sub target_var_prefix ($) {
- my ($ho) = @_;
- if (exists $ho->{Guest}) { return $ho->{Guest}.'_'; }
- return '';
-}
-
-sub target_var ($$) {
- my ($ho,$vn) = @_;
- return $r{ target_var_prefix($ho). $vn };
-}
-
-sub target_kernkind_check ($) {
- my ($gho) = @_;
- my $pfx= target_var_prefix($gho);
- my $kernkind= $r{$pfx."kernkind"};
- my $isguest= exists $gho->{Guest};
- if ($kernkind eq 'pvops') {
- store_runvar($pfx."rootdev", 'xvda') if $isguest;
- store_runvar($pfx."console", 'hvc0');
- } elsif ($kernkind !~ m/2618/) {
- store_runvar($pfx."console", 'xvc0') if $isguest;
- }
-}
-
-sub target_kernkind_console_inittab ($$$) {
- my ($ho, $gho, $root) = @_;
-
- my $inittabpath= "$root/etc/inittab";
- my $console= target_var($gho,'console');
-
- if (defined $console && length $console) {
- target_cmd_root($ho, <<END);
- set -ex
- perl -i~ -ne "
- next if m/^xc:/;
- print \\\$_ or die \\\$!;
- next unless s/^1:/xc:/;
- s/tty1/$console/;
- print \\\$_ or die \\\$!;
- " $inittabpath
-END
- }
- return $console;
-}
-
-sub target_extract_jobdistpath ($$$$$) {
- my ($ho, $part, $path, $job, $distpath) = @_;
- $distpath->{$part}= get_stashed($path, $job);
- my $local= $path; $local =~ s/path_//;
- my $distcopy= "/root/extract_$local.tar.gz";
- target_putfile_root($ho, 300, $distpath->{$part}, $distcopy);
- target_cmd_root($ho, "cd / && tar zxf $distcopy", 300);
-}
-
-sub guest_find_domid ($$) {
- my ($ho,$gho) = @_;
- return if defined $gho->{Domid};
- my $list= target_cmd_output_root($ho,
- toolstack()->{Command}." list $gho->{Name}");
- $list =~ m/^(?!Name\s)(\S+)\s+(\d+)\s+(\d+)+(\d+)\s.*$/m
- or die "domain list: $list";
- $1 eq $gho->{Name} or die "domain list name $1 expected $gho->{Name}";
- $gho->{MemUsed}= $3;
- $gho->{Vcpus}= $4;
- return $gho->{Domid}= $2;
-}
-
-sub guest_vncsnapshot_begin ($$) {
- my ($ho,$gho) = @_;
- my $domid= $gho->{Domid};
-
- my $backend= target_cmd_output_root($ho,
- "xenstore-read /local/domain/$domid/device/vfb/0/backend ||:");
-
- if ($backend eq '') {
- my $port= target_cmd_output_root($ho,
- "xenstore-read /local/domain/$domid/console/vnc-port");
- $port =~ m/^\d+/ && $port >= 5900 or die "$port ?";
- return {
- vnclisten => $ho->{Ip},
- vncdisplay => $port-5900,
- };
- }
-
- $backend =~ m,^/local/domain/\d+/backend/vfb/\d+/\d+$,
- or die "$backend ?";
-
- my $v = {};
- foreach my $k (qw(vnclisten vncdisplay)) {
- $v->{$k}= target_cmd_output_root($ho,
- "xenstore-read $backend/$k");
- }
- return $v;
-}
-sub guest_vncsnapshot_stash ($$$$) {
- my ($ho,$gho,$v,$leaf) = @_;
- my $rfile= "/root/$leaf";
- target_cmd_root($ho,
- "vncsnapshot -passwd $gho->{Guest}.vncpw".
- " -nojpeg -allowblank".
- " $v->{vnclisten}:$v->{vncdisplay}".
- " $rfile", 100);
- target_getfile_root($ho,100, "$rfile", "$stash/$leaf");
-}
-
-our %toolstacks=
- ('xend' => {
- NewDaemons => [qw(xend)],
- OldDaemonInitd => 'xend',
- Command => 'xm',
- CfgPathVar => 'cfgpath',
- Dom0MemFixed => 1,
- },
- 'xl' => {
- NewDaemons => [],
- Dom0MemFixed => 1,
- Command => 'xl',
- CfgPathVar => 'cfgpath',
- RestoreNeedsConfig => 1,
- }
- );
-
-sub toolstack () {
- my $tsname= $r{toolstack};
- $tsname= 'xend' if !defined $tsname;
- my $ts= $toolstacks{$tsname};
- die "$tsname ?" unless defined $ts;
- if (!exists $ts->{Name}) {
- logm("toolstack $tsname");
- $ts->{Name}= $tsname;
- }
- return $ts;
-}
-
-sub authorized_keys () {
- my $authkeys= '';
- my @akf= map {
- "$ENV{'HOME'}/.ssh/$_"
- } qw(authorized_keys id_dsa.pub id_rsa.pub);
- push @akf, split ':', $c{AuthorizedKeysFiles};
- push @akf, $c{TestHostKeypairPath}.'.pub';
- foreach my $akf (@akf) {
- next unless $akf =~ m/\S/;
- $authkeys .= get_filecontents($akf, "# $akf ENOENT\n"). "\n";
- }
- $authkeys .= $c{AuthorizedKeysAppend};
- return $authkeys;
-}
-
#---------- logtailer ----------
package Osstest::Logtailer;
@ISA = qw(Exporter);
@EXPORT = qw(
tsreadconfig %r $flight $job $stash
+ ts_get_host_guest
-fail logm
- broken $logm_handle
-
-
-store_runvar get_runvar get_runvar_maybe get_runvar_default need_runvars
- flight_otherjob
+ fail broken logm $logm_handle
+ store_runvar get_runvar get_runvar_maybe
+ get_runvar_default need_runvars flight_otherjob
unique_incrementing_runvar
target_cmd_root target_cmd target_cmd_build
target_editfile_root target_file_exists
target_install_packages target_install_packages_norec
target_extract_jobdistpath
-poll_loop
-selecthost get_hostflags
- get_host_property
+ poll_loop tcpconnect await_tcp
+ contents_make_cpio file_simple_write_contents
-power_state power_cycle power_cycle_time
+ selecthost get_hostflags get_host_property
+ power_state power_cycle power_cycle_time
get_stashed open_unique_stashfile
-
-host_reboot target_reboot target_reboot_hard
-tcpconnect
- contents_make_cpio file_simple_write_contents
-
+ dir_identify_vcs build_clone built_stash
+ hg_dir_revision git_dir_revision vcs_dir_revision
+ store_revision store_vcs_revision
+
+ sshopts authorized_keys
+ remote_perl_script_open remote_perl_script_done
+ host_reboot target_reboot target_reboot_hard
+ target_choose_vg target_umount_lv target_await_down
+
+ target_ping_check_down target_ping_check_up
+ target_kernkind_check target_kernkind_console_inittab
+ target_var target_var_prefix
+ selectguest prepareguest more_prepareguest_hvm
+ guest_var guest_var_commalist
+ prepareguest_part_lvmdisk prepareguest_part_xencfg
+ guest_umount_lv guest_await guest_await_dhcp_tcp
+ guest_checkrunning guest_check_ip guest_find_ether
+ guest_find_domid guest_check_up guest_check_up_quick
+ guest_get_state guest_await_reboot guest_destroy
+ guest_vncsnapshot_begin guest_vncsnapshot_stash
+ guest_check_remus_ok guest_editconfig
+ host_involves_pcipassthrough host_get_pcipassthrough_devs
+ toolstack
+
+ await_webspace_fetch_byleaf create_webfile
+ file_link_contents get_timeout
+ setup_pxeboot setup_pxeboot_local host_pxedir
);
%EXPORT_TAGS = ( );
our (%r,$flight,$job,$stash);
+our %timeout= qw(RebootDown 100
+ RebootUp 400
+ HardRebootUp 600);
+
our $logm_handle= new IO::File ">& STDERR" or die $!;
#---------- test script startup ----------
} or warn $@;
}
+#---------- test script startup ----------
+
+sub ts_get_host_guest { # pass this @ARGV
+ my ($gn,$whhost) = reverse @_;
+ $whhost ||= 'host';
+ $gn ||= 'guest';
+
+ my $ho= selecthost($whhost);
+ my $gho= selectguest($gn,$ho);
+ return ($ho,$gho);
+}
+
#---------- general ----------
sub logm ($) {
close $flc or die "$real $!";
}
+#---------- building, vcs's, etc. ----------
+
+sub build_clone ($$$$) {
+ my ($ho, $which, $builddir, $subdir) = @_;
+
+ need_runvars("tree_$which", "revision_$which");
+
+ my $tree= $r{"tree_$which"};
+ my $timeout= 4000;
+
+ my $vcs = $r{"treevcs_$which"};
+ if (defined $vcs) {
+ } elsif ($tree =~ m/\.hg$/) {
+ $vcs= 'hg';
+ } elsif ($tree =~ m/\.git$/) {
+ $vcs= 'git';
+ } else {
+ die "unknown vcs for $which $tree ";
+ }
+
+ if ($vcs eq 'hg') {
+
+ target_cmd_build($ho, $timeout, $builddir, <<END.
+ hg clone '$tree' $subdir
+ cd $subdir
+END
+ (length($r{"revision_$which"}) ? <<END : ''));
+ hg update '$r{"revision_$which"}'
+END
+ } elsif ($vcs eq 'git') {
+
+ target_cmd_build($ho, $timeout, $builddir, <<END.
+ git clone '$tree' $subdir
+ cd $subdir
+END
+ (length($r{"revision_$which"}) ? <<END : ''));
+ git checkout '$r{"revision_$which"}'
+END
+ } else {
+ die "$vcs $which $tree ?";
+ }
+
+ my $rev= vcs_dir_revision($ho, "$builddir/$subdir", $vcs);
+ store_vcs_revision($which, $rev, $vcs);
+}
+
+sub dir_identify_vcs ($$) {
+ my ($ho,$dir) = @_;
+ return target_cmd_output($ho, <<END);
+ set -e
+ if ! test -e $dir; then echo none; exit 0; fi
+ cd $dir
+ (test -d .git && echo git) ||
+ (test -d .hg && echo hg) ||
+ (echo >&2 'unable to determine vcs'; fail)
+END
+}
+
+sub store_revision ($$$;$) {
+ my ($ho,$which,$dir,$optional) = @_;
+ my $vcs= dir_identify_vcs($ho,$dir);
+ return if $optional && $vcs eq 'none';
+ my $rev= vcs_dir_revision($ho,$dir,$vcs);
+ store_vcs_revision($which,$rev,$vcs);
+}
+
+sub store_vcs_revision ($$$) {
+ my ($which,$rev,$vcs) = @_;
+ store_runvar("built_vcs_$which", $vcs);
+ store_runvar("built_revision_$which", $rev);
+}
+
+sub built_stash ($$$$) {
+ my ($ho, $builddir, $distroot, $item) = @_;
+ target_cmd($ho, <<END, 300);
+ set -xe
+ cd $builddir
+ cd $distroot
+ tar zcf $builddir/$item.tar.gz *
+END
+ my $build= "build";
+ my $stashleaf= "$build/$item.tar.gz";
+ ensuredir("$stash/$build");
+ target_getfile($ho, 300,
+ "$builddir/$item.tar.gz",
+ "$stash/$stashleaf");
+ store_runvar("path_$item", $stashleaf);
+}
+
+sub vcs_dir_revision ($$$) {
+ my ($ho,$builddir,$vcs) = @_;
+ no strict qw(refs);
+ return &{"${vcs}_dir_revision"}($ho,$builddir);
+}
+
+sub hg_dir_revision ($$) {
+ my ($ho,$builddir) = @_;
+ my $rev= target_cmd_output($ho, "cd $builddir && hg identify -ni", 100);
+ $rev =~ m/^([0-9a-f]{10,}\+?) (\d+\+?)$/ or die "$builddir $rev ?";
+ return "$2:$1";
+}
+
+sub git_dir_revision ($$) {
+ my ($ho,$builddir) = @_;
+ my $rev= target_cmd_output($ho, "cd $builddir && git rev-parse HEAD^0");
+ $rev =~ m/^([0-9a-f]{10,})$/ or die "$builddir $rev ?";
+ return "$1";
+}
+
+#---------- hosts and guests ----------
+
+sub get_hostflags ($) {
+ my ($ident) = @_;
+ # may be run outside transaction, or with flights locked
+ my $flags= get_runvar_default('all_hostflags', $job, '').','.
+ get_runvar_default("${ident}_hostflags", $job, '');
+ return grep /./, split /\,/, $flags;
+}
+
+sub host_involves_pcipassthrough ($) {
+ my ($ho) = @_;
+ return !!grep m/^pcipassthrough\-/, get_hostflags($ho->{Ident});
+}
+
+sub host_get_pcipassthrough_devs ($) {
+ my ($ho) = @_;
+ my @devs;
+ foreach my $prop (values %{ $ho->{Properties} }) {
+ next unless $prop->{name} =~ m/^pcipassthrough (\w+)$/;
+ my $devtype= $1;
+ next unless grep { m/^pcipassthrough-$devtype$/ } get_hostflags($ho);
+ $prop->{val} =~ m,^([0-9a-f]+\:[0-9a-f]+\.\d+)/, or
+ die "$ho->{Ident} $prop->{val} ?";
+ push @devs, {
+ DevType => $devtype,
+ Bdf => $1,
+ Info => $' #'
+ };
+ }
+ return @devs;
+}
+
+sub get_timeout ($$$) {
+ my ($ho,$which,$default) = @_;
+ return $default + get_host_property($ho, "$which-time-extra", 0);
+}
+
+sub guest_find_tcpcheckport ($) {
+ my ($gho) = @_;
+ $gho->{TcpCheckPort}= $r{"$gho->{Guest}_tcpcheckport"};
+ $gho->{PingBroken}= $r{"$gho->{Guest}_pingbroken"};
+}
+
+sub selectguest ($$) {
+ my ($gn,$ho) = @_;
+ my $gho= {
+ Guest => $gn,
+ Name => $r{"${gn}_hostname"},
+ CfgPath => $r{"${gn}_cfgpath"},
+ Host => $ho,
+ };
+ foreach my $opt (guest_var_commalist($gho,'options')) {
+ $gho->{Options}{$opt}++;
+ }
+ guest_find_lv($gho);
+ guest_find_ether($gho);
+ guest_find_tcpcheckport($gho);
+ return $gho;
+}
+
+sub guest_find_lv ($) {
+ my ($gho) = @_;
+ my $gn= $gho->{Guest};
+ $gho->{Vg}= $r{"${gn}_vg"};
+ $gho->{Lv}= $r{"${gn}_disk_lv"};
+ $gho->{Lvdev}= (defined $gho->{Vg} && defined $gho->{Lv})
+ ? '/dev/'.$gho->{Vg}.'/'.$gho->{Lv} : undef;
+}
+
+sub guest_find_ether ($) {
+ my ($gho) = @_;
+ $gho->{Ether}= $r{"$gho->{Guest}_ether"};
+}
+
+sub report_once ($$$) {
+ my ($ho, $what, $msg) = @_;
+ my $k= "Lastmsg_$what";
+ return if defined($ho->{$k}) and $ho->{$k} eq $msg;
+ logm($msg);
+ $ho->{$k}= $msg;
+}
+
+sub guest_check_ip ($) {
+ my ($gho) = @_;
+
+ guest_find_ether($gho);
+
+ my $leases;
+ my $leasesfn = $gho->{DhcpLeases} || $gho->{Host}{DhcpLeases};
+
+ if ($leasesfn =~ m,/,) {
+ $leases= new IO::File $leasesfn, 'r';
+ if (!defined $leases) { return "open $leasesfn: $!"; }
+ } else {
+ $leases= new IO::Socket::INET(PeerAddr => $leasesfn);
+ }
+
+ my $lstash= "dhcpleases-$gho->{Guest}";
+ my $inlease;
+ my $props;
+ my $best;
+ my @warns;
+
+ my $copy= new IO::File "$stash/$lstash.new", 'w';
+ $copy or die "$lstash.new $!";
+
+ my $saveas= sub {
+ my ($fn,$keep) = @_;
+
+ while (<$leases>) { print $copy $_ or die $!; }
+ die $! unless $leases->eof;
+
+ my $rename= sub {
+ my ($src,$dst) = @_;
+ rename "$stash/$src", "$stash/$dst"
+ or $!==&ENOENT
+ or die "rename $fn.$keep $!";
+ };
+ while (--$keep>0) {
+ $rename->("$fn.$keep", "$fn.".($keep+1));
+ }
+ if ($keep>=0) {
+ die if $keep;
+ $rename->("$fn", "$fn.$keep");
+ }
+ $copy->close();
+ rename "$stash/$lstash.new", "$stash/$fn" or die "$lstash.new $fn $!";
+ logm("warning: $_") foreach grep { defined } @warns[0..5];
+ logm("$fn: rotated and stashed current leases");
+ };
+
+ my $badleases= sub {
+ my ($m) = @_;
+ $m= "$leasesfn:$.: unknown syntax";
+ $saveas->("$lstash.bad", 7);
+ return $m;
+ };
+
+ while (<$leases>) {
+ print $copy $_ or die $!;
+
+ chomp; s/^\s+//; s/\s+$//;
+ next if m/^\#/; next unless m/\S/;
+ if (m/^lease\s+([0-9.]+)\s+\{$/) {
+ return $badleases->("lease inside lease") if defined $inlease;
+ $inlease= $1;
+ $props= { };
+ next;
+ }
+ if (!m/^\}$/) {
+ s/^( hardware \s+ ethernet |
+ binding \s+ state
+ ) \s+//x
+ or
+ s/^( [-a-z0-9]+
+ ) \s+//x
+ or
+ return $badleases->("unknown syntax");
+ my $prop= $1;
+ s/\s*\;$// or return $badleases->("missing semicolon");
+ $props->{$prop}= $_;
+ next;
+ }
+ return $badleases->("end lease not inside lease")
+ unless defined $inlease;
+
+ $props->{' addr'}= $inlease;
+ undef $inlease;
+
+ # got a lease in $props
+
+ # ignore old leases
+ next if exists $props->{'binding state'} &&
+ lc $props->{'binding state'} ne 'active';
+
+ # ignore leases we don't understand
+ my @missing= grep { !defined $props->{$_} }
+ ('binding state', 'hardware ethernet', 'ends');
+ if (@missing) {
+ push @warns, "$leasesfn:$.: lease without \`$_'"
+ foreach @missing;
+ next;
+ }
+
+ # ignore leases for other hosts
+ next unless lc $props->{'hardware ethernet'} eq lc $gho->{Ether};
+
+ $props->{' ends'}= $props->{'ends'};
+ $props->{' ends'} =~
+ s/^[0-6]\s+(\S+)\s+(\d+)\:(\d+\:\d+)$/
+ sprintf "%s %02d:%s", $1,$2,$3 /e
+ or return $badleases->("unexpected syntax for ends");
+
+ next if $best &&
+ $best->{' ends'} gt $props->{' ends'};
+ $best= $props;
+ }
+
+ if (!$best) {
+ $saveas->("$lstash.nolease", 3);
+ return "no active lease";
+ }
+ $gho->{Ip}= $best->{' addr'};
+
+ report_once($gho, 'guest_check_ip',
+ "guest $gho->{Name}: $gho->{Ether} $gho->{Ip}");
+ return undef;
+}
+
+sub guest_editconfig ($$$) {
+ my ($ho, $gho, $code) = @_;
+ target_editfile_root($ho, "$gho->{CfgPath}", sub {
+ while (<::EI>) {
+ $code->();
+ print ::EO or die $!;
+ }
+ die $! if ::EI->error;
+ });
+}
+
+sub guest_await_reboot ($$$) {
+ my ($ho,$gho, $timeout) = @_;
+ poll_loop($timeout, 30, "await reboot request from $gho->{Guest}", sub {
+ my $st= guest_get_state($ho,$gho);
+ return undef if $st eq 'sr';
+ fail("guest unexpectedly shutdown; state is '$st'")
+ if $st =~ m/^s/ || $st eq '';
+ return "guest state is $st";
+ });
+}
+
+sub guest_destroy ($$) {
+ my ($ho,$gho) = @_;
+ target_cmd_root($ho, toolstack()->{Command}." destroy $gho->{Name}", 40);
+}
+
+sub target_choose_vg ($$) {
+ my ($ho, $mbneeded) = @_;
+ my $vgs= target_cmd_output_root($ho, 'vgdisplay --colon');
+ my $bestkb= 1.0e90;
+ my $bestvg;
+ foreach my $l (split /\n/, $vgs) {
+ $l =~ s/^\s+//; $l =~ s/\s+$//;
+ my @l= split /\:/, $l;
+ my $tvg= $l[0];
+ my $pesize= $l[12];
+ my $freepekb= $l[15];
+ my $tkb= $l[12] * 1.0 * $l[15];
+ if ($tkb < $mbneeded*1024.0) {
+ logm("vg $tvg ${tkb}kb free - too small");
+ next;
+ }
+ if ($tkb < $bestkb) {
+ $bestvg= $tvg;
+ $bestkb= $tkb;
+ }
+ }
+ die "no vg of sufficient size"
+ unless defined $bestvg;
+ logm("vg $bestvg ${bestkb}kb free - will use");
+ return $bestvg;
+}
+
+sub select_ether ($) {
+ my ($vn) = @_;
+ # must be run outside transaction
+ my $ether= $r{$vn};
+ return $ether if defined $ether;
+ my $prefix= sprintf "%s:%02x", $c{GenEtherPrefix}, $flight & 0xff;
+
+ db_retry($flight,'running', $dbh_tests,[qw(flights)], sub {
+ my $previous= $dbh_tests->selectrow_array(<<END, {}, $flight);
+ SELECT max(val) FROM runvars WHERE flight=?
+ AND name LIKE E'%\\_ether'
+ AND val LIKE '$prefix:%'
+END
+ if (defined $previous) {
+ $previous =~ m/^\w+:\w+:\w+:\w+:([0-9a-f]+):([0-9a-f]+)$/i
+ or die "$previous ?";
+ my $val= (hex($1)<<8) | hex($2);
+ $val++; $val &= 0xffff;
+ $ether= sprintf "%s:%02x:%02x", $prefix, $val >> 8, $val & 0xff;
+ logm("select_ether $prefix:... $ether (previous $previous)");
+ } else {
+ $ether= "$prefix:00:01";
+ logm("select_ether $prefix:... $ether (first in flight)");
+ }
+ $dbh_tests->do(<<END, {}, $flight,$job,$vn,$ether);
+ INSERT INTO runvars VALUES (?,?,?,?,'t')
+END
+ my $chkrow= $dbh_tests->selectrow_hashref(<<END,{}, $flight);
+ SELECT val, count(*) FROM runvars WHERE flight=?
+ AND name LIKE E'%\\_ether'
+ AND val LIKE '$prefix:%'
+ GROUP BY val
+ HAVING count(*) <> 1
+ LIMIT 1
+END
+ die "$chkrow->{val} $chkrow->{count}" if $chkrow;
+ });
+ $r{$vn}= $ether;
+ return $ether;
+}
+
+sub guest_var ($$$) {
+ my ($gho, $runvartail, $default) = @_;
+ my $val= $r{ $gho->{Guest}."_".$runvartail }; return $val if defined $val;
+ $val= $r{ "guests_$runvartail" }; return $val if defined $val;
+ return $default;
+}
+
+sub guest_var_commalist ($$) {
+ my ($gho,$runvartail) = @_;
+ return split /\,/, guest_var($gho,$runvartail,'');
+}
+
+sub prepareguest ($$$$$$) {
+ my ($ho, $gn, $hostname, $tcpcheckport, $mb,
+ $boot_timeout) = @_;
+ # must be run outside transaction
+
+ # If we are passing through a nic, use its mac address not a generated one
+ my $ptnichostident= $r{"${gn}_pcipassthrough_nic"};
+ if (!$ptnichostident) {
+ select_ether("${gn}_ether");
+ } else {
+ my $ptnicho= selecthost($ptnichostident);
+ my $ptnicinfo= get_host_property($ptnicho,'pcipassthrough nic');
+ $ptnicinfo =~ m,/, or die "$ptnichostident $ptnicinfo ?";
+ my $ptether= $'; #'
+ $r{"${gn}_ether"}= $ptether;
+ logm("passthrough nic from $ptnichostident ether $ptether");
+ }
+
+ store_runvar("${gn}_hostname", $hostname);
+ store_runvar("${gn}_disk_lv", $r{"${gn}_hostname"}.'-disk');
+ store_runvar("${gn}_tcpcheckport", $tcpcheckport);
+ store_runvar("${gn}_boot_timeout", $boot_timeout);
+
+ my $gho= selectguest($gn, $ho);
+ store_runvar("${gn}_domname", $gho->{Name});
+
+ store_runvar("${gn}_vg", '');
+ if (!length $r{"${gn}_vg"}) {
+ store_runvar("${gn}_vg", target_choose_vg($ho, $mb));
+ }
+
+ guest_find_lv($gho);
+ guest_find_ether($gho);
+ guest_find_tcpcheckport($gho);
+ return $gho;
+}
+
+sub prepareguest_part_lvmdisk ($$$) {
+ my ($ho, $gho, $disk_mb) = @_;
+ target_cmd_root($ho, "lvremove -f $gho->{Lvdev} ||:");
+ target_cmd_root($ho, "lvcreate -L ${disk_mb}M -n $gho->{Lv} $gho->{Vg}");
+ target_cmd_root($ho, "dd if=/dev/zero of=$gho->{Lvdev} count=10");
+}
+
+sub prepareguest_part_xencfg ($$$$$) {
+ my ($ho, $gho, $ram_mb, $xopts, $cfgrest) = @_;
+ my $onreboot= $xopts->{OnReboot} || 'restart';
+ my $vcpus= guest_var($gho, 'vcpus', $xopts->{DefVcpus} || 2);
+ my $xoptcfg= $xopts->{ExtraConfig};
+ $xoptcfg='' unless defined $xoptcfg;
+ my $xencfg= <<END;
+name = '$gho->{Name}'
+memory = ${ram_mb}
+vif = [ 'type=ioemu,mac=$gho->{Ether}' ]
+#
+on_poweroff = 'destroy'
+on_reboot = '$onreboot'
+on_crash = 'preserve'
+#
+vcpus = $vcpus
+#
+$cfgrest
+#
+$xoptcfg
+END
+
+ my $cfgpath= "/etc/xen/$gho->{Name}.cfg";
+ store_runvar("$gho->{Guest}_cfgpath", "$cfgpath");
+ $gho->{CfgPath}= $cfgpath;
+
+ target_putfilecontents_root_stash($ho,30,$xencfg, $cfgpath);
+
+ return $cfgpath;
+}
+
+sub more_prepareguest_hvm ($$$$;@) {
+ my ($ho, $gho, $ram_mb, $disk_mb, %xopts) = @_;
+
+ my $passwd= 'xenvnc';
+
+ prepareguest_part_lvmdisk($ho, $gho, $disk_mb);
+
+ my $specimage= $r{"$gho->{Guest}_image"};
+ die "$gho->{Guest} ?" unless $specimage;
+ my $limage= $specimage =~ m,^/, ? $specimage : "$c{Images}/$specimage";
+ $gho->{Rimage}= "/root/$flight.$job.".basename($specimage);
+ target_putfile_root($ho, 1000, $limage,$gho->{Rimage}, '-p');
+
+ my $postimage_hook= $xopts{PostImageHook};
+ $postimage_hook->() if $postimage_hook;
+
+ my $cfg = <<END;
+kernel = 'hvmloader'
+builder = 'hvm'
+#
+disk = [
+ 'phy:$gho->{Lvdev},hda,w',
+ 'file:$gho->{Rimage},hdc:cdrom,r'
+ ]
+#
+usb=1
+usbdevice='tablet'
+#
+#stdvga=1
+keymap='en-gb';
+#
+sdl=0
+opengl=0
+vnc=1
+vncunused=1
+vncdisplay=0
+vnclisten='$ho->{Ip}'
+vncpasswd='$passwd'
+
+serial='file:/dev/stderr'
+#
+boot = 'dc'
+END
+
+ my $devmodel = $r{'device_model_version'};
+ if (defined $devmodel) {
+ $cfg .= "device_model_version='$devmodel'\n";
+ }
+
+ my $cfgpath= prepareguest_part_xencfg($ho, $gho, $ram_mb, \%xopts, $cfg);
+ target_cmd_root($ho, <<END);
+ (echo $passwd; echo $passwd) | vncpasswd $gho->{Guest}.vncpw
+END
+
+ return $cfgpath;
+}
+
+sub guest_check_via_ssh ($) {
+ my ($gho) = @_;
+ return $r{"$gho->{Guest}_tcpcheckport"} == 22;
+}
+
+sub guest_check_up_quick ($) {
+ my ($gho) = @_;
+ if (guest_check_via_ssh($gho)) {
+ target_cmd_root($gho, "date");
+ } else {
+ target_ping_check_up($gho);
+ }
+}
+
+sub guest_check_up ($) {
+ my ($gho) = @_;
+ guest_await_dhcp_tcp($gho,20);
+ target_ping_check_up($gho);
+ target_cmd_root($gho, "echo guest $gho->{Name}: ok")
+ if guest_check_via_ssh($gho);
+}
+
+sub guest_get_state ($$) {
+ my ($ho,$gho) = @_;
+ my $domains= target_cmd_output_root($ho, toolstack()->{Command}." list");
+ $domains =~ s/^Name.*\n//;
+ foreach my $l (split /\n/, $domains) {
+ $l =~ m/^(\S+) (?: \s+ \d+ ){3} \s+ ([-a-z]+) \s/x or die "$l ?";
+ next unless $1 eq $gho->{Name};
+ my $st= $2;
+ $st =~ s/\-//g;
+ $st='-' if !length $st;
+ logm("guest $gho->{Name} state is $st");
+ return $st;
+ }
+ logm("guest $gho->{Name} not present on this host");
+ return '';
+}
+
+our $guest_state_running_re= '[-rb]+';
+
+sub guest_checkrunning ($$) {
+ my ($ho,$gho) = @_;
+ my $s= guest_get_state($ho,$gho);
+ return $s =~ m/^$guest_state_running_re$/o;
+}
+
+sub guest_await_dhcp_tcp ($$) {
+ my ($gho,$timeout) = @_;
+ guest_find_tcpcheckport($gho);
+ poll_loop($timeout,1,
+ "guest $gho->{Name} $gho->{Ether} $gho->{TcpCheckPort}".
+ " link/ip/tcp",
+ sub {
+ my $err= guest_check_ip($gho);
+ return $err if defined $err;
+
+ return
+ ($gho->{PingBroken} ? undef : target_ping_check_up($gho))
+ ||
+ target_tcp_check($gho,5)
+ ||
+ undef;
+ });
+}
+
+sub guest_check_remus_ok {
+ my ($gho, @hos) = @_;
+ my @sts;
+ logm("remus check $gho->{Name}...");
+ foreach my $ho (@hos) {
+ my $st;
+ if (!eval {
+ $st= guest_get_state($ho, $gho)
+ }) {
+ $st= '_';
+ logm("could not get guest $gho->{Name} state on $ho->{Name}: $@");
+ }
+ push @sts, [ $ho, $st ];
+ }
+ my @ststrings= map { $_->[1] } @sts;
+ my $compound= join ',', @ststrings;
+ my $msg= "remus check $gho->{Name}: result \"$compound\":";
+ $msg .= " $_->[0]{Name}=$_->[1]" foreach @sts;
+ logm($msg);
+ my $runnings= scalar grep { m/$guest_state_running_re/o } @ststrings;
+ die "running on multiple hosts $compound" if $runnings > 1;
+ die "not running anywhere $compound" unless $runnings;
+ die "crashed somewhere $compound" if grep { m/c/ } @ststrings;
+}
+
+sub target_umount_lv ($$$) {
+ my ($ho,$vg,$lv) = @_;
+ my $dev= "/dev/$vg/$lv";
+ for (;;) {
+ my $link= target_cmd_output_root($ho, "readlink $dev");
+ return if $link =~ m,^/dev/nbd,; # can't tell if it's open
+ $lv= target_cmd_output_root($ho, "lvdisplay --colon $dev");
+ $lv =~ s/^\s+//; $lv =~ s/\s+$//;
+ my @lv = split /:/, $lv;
+ die "@lv ?" unless $lv[0] eq $dev;
+ return unless $lv[5]; # "open"
+ logm("lvdisplay output says device is still open: $lv");
+ target_cmd_root($ho, "umount $dev");
+ }
+}
+
+sub guest_umount_lv ($$) {
+ my ($ho,$gho) = @_;
+ target_umount_lv($ho, $gho->{Vg}, $gho->{Lv});
+}
+
+sub target_tcp_check ($$) {
+ my ($ho,$interval) = @_;
+ my $ncout= `nc -n -v -z -w $interval $ho->{Ip} $ho->{TcpCheckPort} 2>&1`;
+ return undef if !$?;
+ $ncout =~ s/\n/ | /g;
+ return "nc: $? $ncout";
+}
+
+sub await_tcp ($$$) {
+ my ($maxwait,$interval,$ho) = @_;
+ poll_loop($maxwait,$interval,
+ "await tcp $ho->{Name} $ho->{TcpCheckPort}",
+ sub {
+ return target_tcp_check($ho,$interval);
+ });
+}
+
+sub guest_await ($$) {
+ my ($gho,$dhcpwait) = @_;
+ guest_await_dhcp_tcp($gho,$dhcpwait);
+ target_cmd_root($gho, "echo guest $gho->{Name}: ok")
+ if guest_check_via_ssh($gho);
+ return $gho;
+}
+
+sub target_var_prefix ($) {
+ my ($ho) = @_;
+ if (exists $ho->{Guest}) { return $ho->{Guest}.'_'; }
+ return '';
+}
+
+sub target_var ($$) {
+ my ($ho,$vn) = @_;
+ return $r{ target_var_prefix($ho). $vn };
+}
+
+sub target_kernkind_check ($) {
+ my ($gho) = @_;
+ my $pfx= target_var_prefix($gho);
+ my $kernkind= $r{$pfx."kernkind"};
+ my $isguest= exists $gho->{Guest};
+ if ($kernkind eq 'pvops') {
+ store_runvar($pfx."rootdev", 'xvda') if $isguest;
+ store_runvar($pfx."console", 'hvc0');
+ } elsif ($kernkind !~ m/2618/) {
+ store_runvar($pfx."console", 'xvc0') if $isguest;
+ }
+}
+
+sub target_kernkind_console_inittab ($$$) {
+ my ($ho, $gho, $root) = @_;
+
+ my $inittabpath= "$root/etc/inittab";
+ my $console= target_var($gho,'console');
+
+ if (defined $console && length $console) {
+ target_cmd_root($ho, <<END);
+ set -ex
+ perl -i~ -ne "
+ next if m/^xc:/;
+ print \\\$_ or die \\\$!;
+ next unless s/^1:/xc:/;
+ s/tty1/$console/;
+ print \\\$_ or die \\\$!;
+ " $inittabpath
+END
+ }
+ return $console;
+}
+
+sub target_extract_jobdistpath ($$$$$) {
+ my ($ho, $part, $path, $job, $distpath) = @_;
+ $distpath->{$part}= get_stashed($path, $job);
+ my $local= $path; $local =~ s/path_//;
+ my $distcopy= "/root/extract_$local.tar.gz";
+ target_putfile_root($ho, 300, $distpath->{$part}, $distcopy);
+ target_cmd_root($ho, "cd / && tar zxf $distcopy", 300);
+}
+
+sub guest_find_domid ($$) {
+ my ($ho,$gho) = @_;
+ return if defined $gho->{Domid};
+ my $list= target_cmd_output_root($ho,
+ toolstack()->{Command}." list $gho->{Name}");
+ $list =~ m/^(?!Name\s)(\S+)\s+(\d+)\s+(\d+)+(\d+)\s.*$/m
+ or die "domain list: $list";
+ $1 eq $gho->{Name} or die "domain list name $1 expected $gho->{Name}";
+ $gho->{MemUsed}= $3;
+ $gho->{Vcpus}= $4;
+ return $gho->{Domid}= $2;
+}
+
+sub guest_vncsnapshot_begin ($$) {
+ my ($ho,$gho) = @_;
+ my $domid= $gho->{Domid};
+
+ my $backend= target_cmd_output_root($ho,
+ "xenstore-read /local/domain/$domid/device/vfb/0/backend ||:");
+
+ if ($backend eq '') {
+ my $port= target_cmd_output_root($ho,
+ "xenstore-read /local/domain/$domid/console/vnc-port");
+ $port =~ m/^\d+/ && $port >= 5900 or die "$port ?";
+ return {
+ vnclisten => $ho->{Ip},
+ vncdisplay => $port-5900,
+ };
+ }
+
+ $backend =~ m,^/local/domain/\d+/backend/vfb/\d+/\d+$,
+ or die "$backend ?";
+
+ my $v = {};
+ foreach my $k (qw(vnclisten vncdisplay)) {
+ $v->{$k}= target_cmd_output_root($ho,
+ "xenstore-read $backend/$k");
+ }
+ return $v;
+}
+sub guest_vncsnapshot_stash ($$$$) {
+ my ($ho,$gho,$v,$leaf) = @_;
+ my $rfile= "/root/$leaf";
+ target_cmd_root($ho,
+ "vncsnapshot -passwd $gho->{Guest}.vncpw".
+ " -nojpeg -allowblank".
+ " $v->{vnclisten}:$v->{vncdisplay}".
+ " $rfile", 100);
+ target_getfile_root($ho,100, "$rfile", "$stash/$leaf");
+}
+
+our %toolstacks=
+ ('xend' => {
+ NewDaemons => [qw(xend)],
+ OldDaemonInitd => 'xend',
+ Command => 'xm',
+ CfgPathVar => 'cfgpath',
+ Dom0MemFixed => 1,
+ },
+ 'xl' => {
+ NewDaemons => [],
+ Dom0MemFixed => 1,
+ Command => 'xl',
+ CfgPathVar => 'cfgpath',
+ RestoreNeedsConfig => 1,
+ }
+ );
+
+sub toolstack () {
+ my $tsname= $r{toolstack};
+ $tsname= 'xend' if !defined $tsname;
+ my $ts= $toolstacks{$tsname};
+ die "$tsname ?" unless defined $ts;
+ if (!exists $ts->{Name}) {
+ logm("toolstack $tsname");
+ $ts->{Name}= $tsname;
+ }
+ return $ts;
+}
+
+sub authorized_keys () {
+ my $authkeys= '';
+ my @akf= map {
+ "$ENV{'HOME'}/.ssh/$_"
+ } qw(authorized_keys id_dsa.pub id_rsa.pub);
+ push @akf, split ':', $c{AuthorizedKeysFiles};
+ push @akf, $c{TestHostKeypairPath}.'.pub';
+ foreach my $akf (@akf) {
+ next unless $akf =~ m/\S/;
+ $authkeys .= get_filecontents($akf, "# $akf ENOENT\n"). "\n";
+ }
+ $authkeys .= $c{AuthorizedKeysAppend};
+ return $authkeys;
+}
+
+#---------- webspace for installer ----------
+
+sub await_webspace_fetch_byleaf ($$$$$) {
+ my ($maxwait,$interval,$logtailer, $ho, $url) = @_;
+ my $leaf= $url;
+ $leaf =~ s,.*/,,;
+ poll_loop($maxwait,$interval, "fetch $leaf", sub {
+ my ($line, $last);
+ $last= '(none)';
+ while (defined($line= $logtailer->getline())) {
+ my ($ip, $got) = $line =~
+ m,^([0-9.]+) \S+ \S+ \[[^][]+\] \"GET \S*/(\S+) ,
+ or next;
+ next unless $ip eq $ho->{Ip};
+ $last= $got;
+ next unless $got eq $leaf;
+ return undef;
+ }
+ return $last;
+ });
+}
+
+sub create_webfile ($$$) {
+ my ($ho, $tail, $contents) = @_; # $contents as for file_link_contents
+ my $wf_common= $c{WebspaceCommon}.$ho->{Name}."_".$tail;
+ my $wf_url= $c{WebspaceUrl}.$wf_common;
+ my $wf_file= $c{WebspaceFile}.$wf_common;
+ file_link_contents($wf_file, $contents);
+ return $wf_url;
+}
+
+#---------- pxe handling ----------
+
+sub file_link_contents ($$) {
+ my ($fn, $contents) = @_;
+ # $contents as for file_write_contents
+ my ($dir, $base, $ext) =
+ $fn =~ m,^( (?: .*/ )? )( [^/]+? )( (?: \.[^./]+ )? )$,x
+ or die "$fn ?";
+ my $real= "$dir$base--osstest$ext";
+ my $linktarg= "$base--osstest$ext";
+
+ file_simple_write_contents($real, $contents);
+
+ my $newlink= "$dir$base--newlink$ext";
+
+ if (!lstat "$fn") {
+ $!==&ENOENT or die "$fn $!";
+ } elsif (!-l _) {
+ die "$fn not a symlink";
+ unlink $fn or die "$fn $!";
+ }
+ symlink $linktarg, $newlink or die "$newlink $!";
+ rename $newlink, $fn or die "$newlink $fn $!";
+ logm("wrote $fn");
+}
+
+sub host_pxedir ($) {
+ my ($ho) = @_;
+ my $dir= $ho->{Ether};
+ $dir =~ y/A-Z/a-z/;
+ $dir =~ y/0-9a-f//cd;
+ length($dir)==12 or die "$dir";
+ $dir =~ s/../$&-/g;
+ $dir =~ s/\-$//;
+ return $dir;
+}
+
+sub setup_pxeboot ($$) {
+ my ($ho, $bootfile) = @_;
+ my $dir= host_pxedir($ho);
+ file_link_contents($c{Tftp}."/$dir/pxelinux.cfg", $bootfile);
+}
+
+sub setup_pxeboot_local ($) {
+ my ($ho) = @_;
+ setup_pxeboot($ho, <<END);
+serial 0 $c{Baud}
+timeout 5
+label local
+ LOCALBOOT 0
+default local
+END
+}
+
1;
projects / people / iwj / osstest.git / commitdiff