2009-02-15 22:42:22 +00:00
#!/usr/bin/env perl
# IBM(c) 2007 EPL license http://www.eclipse.org/legal/epl-v10.html
package xCAT_plugin::kvm ;
BEGIN
{
$ ::XCATROOT = $ ENV { 'XCATROOT' } ? $ ENV { 'XCATROOT' } : '/opt/xcat' ;
}
use lib "$::XCATROOT/lib/perl" ;
use xCAT::GlobalDef ;
use xCAT::NodeRange ;
use xCAT_monitoring::monitorctrl ;
use xCAT::Table ;
use XML::Simple qw( XMLout ) ;
use Thread qw( yield ) ;
2009-10-20 00:44:16 +00:00
use File::Basename qw/fileparse/ ;
use File::Path qw/mkpath/ ;
2009-02-15 22:42:22 +00:00
use IO::Socket ;
use IO::Select ;
use strict ;
#use warnings;
2009-10-20 00:44:16 +00:00
my $ use_xhrm = 0 ; #xCAT Hypervisor Resource Manager, to satisfy networking and storage prerequisites, default to not using it for the moment
2009-02-15 22:42:22 +00:00
my % vm_comm_pids ;
2009-10-19 22:47:48 +00:00
my % offlinehyps ;
my % offlinevms ;
2009-02-15 22:42:22 +00:00
my @ destblacklist ;
my $ vmhash ;
2009-03-14 15:45:07 +00:00
my $ nthash ; #to store nodetype data
2009-02-15 22:42:22 +00:00
my $ hmhash ;
use XML::Simple ;
2009-07-30 19:42:29 +00:00
$ XML:: Simple:: PREFERRED_PARSER = 'XML::Parser' ;
2009-02-15 22:42:22 +00:00
use Data::Dumper ;
use POSIX "WNOHANG" ;
use Storable qw( freeze thaw ) ;
use IO::Select ;
use IO::Handle ;
use Time::HiRes qw( gettimeofday sleep ) ;
use xCAT::DBobjUtils ;
use Getopt::Long ;
2009-03-20 21:36:49 +00:00
use xCAT::SvrUtils ;
2009-02-15 22:42:22 +00:00
my % runningstates ;
my $ vmmaxp = 64 ;
my $ mactab ;
my $ nrtab ;
my $ machash ;
2009-04-17 16:35:54 +00:00
my % usedmacs ;
2009-02-15 22:42:22 +00:00
my $ status_noop = "XXXno-opXXX" ;
sub handled_commands {
#unless ($libvirtsupport) {
# return {};
#}
return {
rpower = > 'nodehm:power,mgt' ,
2009-02-21 12:58:41 +00:00
mkvm = > 'nodehm:power,mgt' ,
2009-02-15 22:42:22 +00:00
rmigrate = > 'nodehm:mgt' ,
2009-03-13 23:58:29 +00:00
getcons = > 'nodehm:mgt' ,
2009-02-15 22:42:22 +00:00
#rvitals => 'nodehm:mgt',
#rinv => 'nodehm:mgt',
getrvidparms = > 'nodehm:mgt' ,
rbeacon = > 'nodehm:mgt' ,
2009-10-19 18:16:07 +00:00
revacuate = > 'hypervisor:type' ,
2009-10-20 01:45:04 +00:00
vmstatenotify = > 'hypervisor:type' ,
2009-02-15 22:42:22 +00:00
#rspreset => 'nodehm:mgt',
#rspconfig => 'nodehm:mgt',
#rbootseq => 'nodehm:mgt',
#reventlog => 'nodehm:mgt',
} ;
}
my $ vmhash ;
my $ hypconn ;
my $ hyp ;
my $ doreq ;
my % hyphash ;
my $ node ;
my $ vmtab ;
2009-10-20 00:44:16 +00:00
sub get_path_for_nfsuri {
my $ diskname = shift ;
$ diskname =~ /nfs:\/\/([^\/]*)(\/.*)/ ;
my $ server = $ 1 ;
my $ path = $ 2 ;
print $ diskname . " $server $path \n" ;
if ( xCAT::Utils:: thishostisnot ( $ server ) ) {
my $ foundmount ;
my @ mounts = `mount` ;
foreach ( @ mounts ) {
if ( /^$server:$path/ ) {
s/ on (\S*) type nfs/$1/ ;
return $ _ ;
}
}
die "$diskname must be mounted on the xCAT server for this operation" ; #TODO: correctly return
} else { #I am the server
return $ path ;
}
}
2009-10-20 23:22:04 +00:00
sub nodesockopen {
my $ node = shift ;
my $ port = shift ;
2009-10-20 23:56:40 +00:00
unless ( $ node ) { return 0 ; }
2009-10-20 23:22:04 +00:00
my $ socket ;
my $ addr = gethostbyname ( $ node ) ;
my $ sin = sockaddr_in ( $ port , $ addr ) ;
my $ proto = getprotobyname ( 'tcp' ) ;
socket ( $ socket , PF_INET , SOCK_STREAM , $ proto ) || return 0 ;
connect ( $ socket , $ sin ) || return 0 ;
return 1 ;
}
2009-10-20 00:44:16 +00:00
2009-02-15 22:42:22 +00:00
sub waitforack {
my $ sock = shift ;
my $ select = new IO:: Select ;
$ select - > add ( $ sock ) ;
my $ str ;
2009-04-03 19:12:56 +00:00
if ( $ select - > can_read ( 60 ) ) { # Continue after 10 seconds, even if not acked...
2009-02-15 22:42:22 +00:00
if ( $ str = <$sock> ) {
} else {
$ select - > remove ( $ sock ) ; #Block until parent acks data
}
}
}
sub build_oshash {
my % rethash ;
$ rethash { type } - > { content } = 'hvm' ;
if ( defined $ vmhash - > { $ node } - > [ 0 ] - > { bootorder } ) {
my $ bootorder = $ vmhash - > { $ node } - > [ 0 ] - > { bootorder } ;
2009-03-18 18:59:41 +00:00
my @ bootdevs = split ( /[:,]/ , $ bootorder ) ;
2009-02-15 22:42:22 +00:00
my $ bootnum = 0 ;
foreach ( @ bootdevs ) {
2009-11-04 16:25:59 +00:00
if ( "net" eq $ _ or "n" eq $ _ ) {
$ rethash { boot } - > [ $ bootnum ] - > { dev } = "network" ;
} else {
$ rethash { boot } - > [ $ bootnum ] - > { dev } = $ _ ;
}
2009-02-15 22:42:22 +00:00
$ bootnum + + ;
}
} else {
$ rethash { boot } - > [ 0 ] - > { dev } = 'network' ;
$ rethash { boot } - > [ 1 ] - > { dev } = 'hd' ;
}
return \ % rethash ;
}
sub build_diskstruct {
2009-03-14 22:17:24 +00:00
my $ cdloc = shift ;
2009-02-15 22:42:22 +00:00
my @ returns = ( ) ;
my $ currdev ;
2009-03-14 22:17:24 +00:00
my @ suffixes = ( 'a' , 'b' , 'd' .. 'z' ) ;
2009-02-15 22:42:22 +00:00
my $ suffidx = 0 ;
2009-03-14 22:17:24 +00:00
if ( $ cdloc ) {
my $ cdhash ;
$ cdhash - > { device } = 'cdrom' ;
if ( $ cdloc =~ /^\/dev/ ) {
$ cdhash - > { type } = 'block' ;
} else {
$ cdhash - > { type } = 'file' ;
}
$ cdhash - > { source } - > { file } = $ cdloc ;
$ cdhash - > { readonly } ;
$ cdhash - > { target } - > { dev } = 'hdc' ;
push @ returns , $ cdhash ;
}
2009-02-15 22:42:22 +00:00
if ( defined $ vmhash - > { $ node } - > [ 0 ] - > { storage } ) {
my $ disklocs = $ vmhash - > { $ node } - > [ 0 ] - > { storage } ;
2009-10-20 00:44:16 +00:00
my @ locations = split /\|/ , $ disklocs ;
2009-02-15 22:42:22 +00:00
foreach my $ disk ( @ locations ) {
#Setting default values of a virtual disk backed by a file at hd*.
my $ diskhash ;
$ diskhash - > { type } = 'file' ;
$ diskhash - > { device } = 'disk' ;
$ diskhash - > { target } - > { dev } = 'hd' . $ suffixes [ $ suffidx ] ;
my @ disk_parts = split ( /,/ , $ disk ) ;
#Find host file and determine if it is a file or a block device.
if ( substr ( $ disk_parts [ 0 ] , 0 , 4 ) eq 'phy:' ) {
$ diskhash - > { type } = 'block' ;
$ diskhash - > { source } - > { dev } = substr ( $ disk_parts [ 0 ] , 4 ) ;
2009-10-20 00:44:16 +00:00
} elsif ( $ disk_parts [ 0 ] =~ m/^nfs:\/\/(.*)$/ ) {
$ diskhash - > { source } - > { file } = "/var/lib/xcat/vmnt/nfs_" . $ 1 . "/$node/" . $ diskhash - > { target } - > { dev } ;
2009-02-15 22:42:22 +00:00
} else {
$ diskhash - > { source } - > { file } = $ disk_parts [ 0 ] ;
}
#See if there are any other options. If not, increment suffidx because the already determined device node was used.
2009-10-20 00:44:16 +00:00
#evidently, we support specificying explicitly how to target the system..
2009-02-15 22:42:22 +00:00
if ( @ disk_parts gt 1 ) {
my @ disk_opts = split ( /:/ , $ disk_parts [ 1 ] ) ;
if ( $ disk_opts [ 0 ] ne '' ) {
$ diskhash - > { target } - > { dev } = $ disk_opts [ 0 ] ;
} else {
$ suffidx + + ;
}
if ( $ disk_opts [ 1 ] eq 'cdrom' ) {
$ diskhash - > { device } = 'cdrom' ;
}
} else {
$ suffidx + + ;
}
push @ returns , $ diskhash ;
}
}
return \ @ returns ;
}
sub getNodeUUID {
my $ node = shift ;
return xCAT::Utils:: genUUID ( ) ;
}
sub build_nicstruct {
my $ rethash ;
my $ node = shift ;
my @ macs = ( ) ;
2009-03-13 23:58:29 +00:00
my @ nics = ( ) ;
if ( $ vmhash - > { $ node } - > [ 0 ] - > { nics } ) {
@ nics = split /,/ , $ vmhash - > { $ node } - > [ 0 ] - > { nics } ;
} else {
@ nics = ( 'virbr0' ) ;
}
2009-02-15 22:42:22 +00:00
if ( $ machash - > { $ node } - > [ 0 ] - > { mac } ) {
my $ macdata = $ machash - > { $ node } - > [ 0 ] - > { mac } ;
foreach my $ macaddr ( split /\|/ , $ macdata ) {
$ macaddr =~ s/\!.*// ;
push @ macs , $ macaddr ;
}
}
2009-04-17 16:35:54 +00:00
unless ( scalar ( @ macs ) >= scalar ( @ nics ) ) {
my $ neededmacs = scalar ( @ nics ) - scalar ( @ macs ) ;
my $ macstr ;
my $ tmac ;
my $ leading ;
2009-10-20 01:02:01 +00:00
srand ;
2009-04-17 16:35:54 +00:00
while ( $ neededmacs - - ) {
my $ allbutmult = 65279 ; # & mask for bitwise clearing of the multicast bit of mac
my $ localad = 512 ; # | to set the bit for locally admnistered mac address
$ leading = int ( rand ( 65535 ) ) ;
$ leading = $ leading | 512 ;
$ leading = $ leading & 65279 ;
my $ n = inet_aton ( $ node ) ;
my $ tail ;
if ( $ n ) {
$ tail = unpack ( "N" , $ n ) ;
}
unless ( $ tail ) {
$ tail = int ( rand ( 4294967295 ) ) ;
}
$ tmac = sprintf ( "%04x%08x" , $ leading , $ tail ) ;
$ tmac =~ s/(..)(..)(..)(..)(..)(..)/$1:$2:$3:$4:$5:$6/ ;
if ( $ usedmacs { $ tmac } ) { #If we have a collision we can actually perceive, retry the generation of this mac
$ neededmacs + + ;
next ;
}
$ usedmacs { $ tmac } = 1 ;
push @ macs , $ tmac ;
2009-02-15 22:42:22 +00:00
}
2009-04-17 16:35:54 +00:00
$ mactab - > setNodeAttribs ( $ node , { mac = > join ( '|' , @ macs ) } ) ;
2009-02-15 22:42:22 +00:00
$ nrtab - > setNodeAttribs ( $ node , { netboot = > 'pxe' } ) ;
$ doreq - > ( { command = > [ 'makedhcp' ] , node = > [ $ node ] } ) ;
}
my @ rethashes ;
foreach ( @ macs ) {
my $ rethash ;
2009-03-13 23:58:29 +00:00
my $ nic = shift @ nics ;
my $ type = 'e1000' ; #better default fake nic than rtl8139, relevant to most
unless ( $ nic ) {
last ; #Don't want to have multiple vnics tied to the same switch
}
2009-10-20 01:02:01 +00:00
$ nic =~ s/.*:// ; #the detail of how the bridge was built is of no
#interest to this segment of code
2009-03-13 23:58:29 +00:00
if ( $ nic =~ /=/ ) {
( $ nic , $ type ) = split /=/ , $ nic , 2 ;
}
2009-02-15 22:42:22 +00:00
$ rethash - > { type } = 'bridge' ;
$ rethash - > { mac } - > { address } = $ _ ;
2009-03-13 23:58:29 +00:00
$ rethash - > { source } - > { bridge } = $ nic ;
$ rethash - > { model } - > { type } = $ type ;
2009-02-15 22:42:22 +00:00
push @ rethashes , $ rethash ;
}
return \ @ rethashes ;
}
sub getUnits {
my $ amount = shift ;
my $ defunit = shift ;
my $ divisor = shift ;
unless ( $ divisor ) {
$ divisor = 1 ;
}
if ( $ amount =~ /(\D)$/ ) { #If unitless, add unit
$ defunit = $ 1 ;
chop $ amount ;
}
if ( $ defunit =~ /k/i ) {
return $ amount * 1024 / $ divisor ;
} elsif ( $ defunit =~ /m/i ) {
return $ amount * 1048576 / $ divisor ;
} elsif ( $ defunit =~ /g/i ) {
return $ amount * 1073741824 / $ divisor ;
}
}
sub build_xmldesc {
my $ node = shift ;
2009-03-14 22:17:24 +00:00
my $ cdloc = shift ;
2009-02-15 22:42:22 +00:00
my % xtree = ( ) ;
$ xtree { type } = 'kvm' ;
$ xtree { name } - > { content } = $ node ;
$ xtree { uuid } - > { content } = getNodeUUID ( $ node ) ;
$ xtree { os } = build_oshash ( ) ;
if ( defined $ vmhash - > { $ node } - > [ 0 ] - > { memory } ) {
$ xtree { memory } - > { content } = getUnits ( $ vmhash - > { $ node } - > [ 0 ] - > { memory } , "M" , 1024 ) ;
} else {
$ xtree { memory } - > { content } = 524288 ;
}
2009-03-14 00:37:20 +00:00
if ( defined $ vmhash - > { $ node } - > [ 0 ] - > { cpus } ) {
$ xtree { vcpu } - > { content } = $ vmhash - > { $ node } - > [ 0 ] - > { cpus } ;
} else {
$ xtree { vcpu } - > { content } = 1 ;
}
2009-03-14 16:44:02 +00:00
if ( defined ( $ vmhash - > { $ node } - > [ 0 ] - > { clockoffset } ) ) {
#If user requested a specific behavior, give it
$ xtree { clock } - > { offset } = $ vmhash - > { $ node } - > [ 0 ] - > { clockoffset } ;
2009-03-14 16:37:49 +00:00
} else {
2009-03-14 16:44:02 +00:00
#Otherwise, only do local time for things that look MS
if ( defined ( $ nthash - > { $ node } - > [ 0 ] - > { os } ) and $ nthash - > { $ node } - > [ 0 ] - > { os } =~ /win.*/ ) {
$ xtree { clock } - > { offset } = 'localtime' ;
} else { #For everyone else, utc is preferred generally
$ xtree { clock } - > { offset } = 'utc' ;
}
2009-03-14 16:37:49 +00:00
}
2009-02-15 22:42:22 +00:00
$ xtree { features } - > { pae } = { } ;
$ xtree { features } - > { acpi } = { } ;
$ xtree { features } - > { apic } = { } ;
$ xtree { features } - > { content } = "\n" ;
2009-03-14 22:17:24 +00:00
$ xtree { devices } - > { disk } = build_diskstruct ( $ cdloc ) ;
2009-02-15 22:42:22 +00:00
$ xtree { devices } - > { interface } = build_nicstruct ( $ node ) ;
2009-03-14 00:14:29 +00:00
$ xtree { devices } - > { input } - > { type } = 'tablet' ;
$ xtree { devices } - > { input } - > { bus } = 'usb' ;
2009-02-15 22:42:22 +00:00
$ xtree { devices } - > { graphics } - > { type } = 'vnc' ;
$ xtree { devices } - > { console } - > { type } = 'pty' ;
$ xtree { devices } - > { console } - > { target } - > { port } = '1' ;
return XMLout ( \ % xtree , RootName = > "domain" ) ;
}
sub refresh_vm {
my $ dom = shift ;
my $ newxml = XMLin ( $ dom - > get_xml_description ( ) ) ;
my $ vncport = $ newxml - > { devices } - > { graphics } - > { port } ;
my $ stty = $ newxml - > { devices } - > { console } - > { tty } ;
$ vmtab - > setNodeAttribs ( $ node , { vncport = > $ vncport , textconsole = > $ stty } ) ;
return { vncport = > $ vncport , textconsole = > $ stty } ;
}
2009-03-13 23:58:29 +00:00
sub getcons {
2009-02-15 22:42:22 +00:00
my $ node = shift ( ) ;
my $ type = shift ( ) ;
my $ dom ;
eval {
$ dom = $ hypconn - > get_domain_by_name ( $ node ) ;
} ;
unless ( $ dom ) {
return 1 , "Unable to query running VM" ;
}
my $ consdata = refresh_vm ( $ dom ) ;
my $ hyper = $ vmhash - > { $ node } - > [ 0 ] - > { host } ;
if ( $ type eq "text" ) {
my $ serialspeed ;
if ( $ hmhash ) {
$ serialspeed = $ hmhash - > { $ node } - > [ 0 ] - > { serialspeed } ;
}
my $ sconsparms = { node = > [ { name = > [ $ node ] } ] } ;
$ sconsparms - > { node } - > [ 0 ] - > { sshhost } = [ $ hyper ] ;
$ sconsparms - > { node } - > [ 0 ] - > { psuedotty } = [ $ consdata - > { textconsole } ] ;
$ sconsparms - > { node } - > [ 0 ] - > { baudrate } = [ $ serialspeed ] ;
return ( 0 , $ sconsparms ) ;
} elsif ( $ type eq "vnc" ) {
2009-03-13 23:58:29 +00:00
return ( 0 , 'ssh+vnc@' . $ hyper . ": localhost:" . $ consdata - > { vncport } ) ; #$consdata->{vncport});
2009-02-15 22:42:22 +00:00
}
}
sub getrvidparms {
my $ node = shift ;
2009-03-13 23:58:29 +00:00
my $ location = getcons ( $ node , "vnc" ) ;
2009-02-15 22:42:22 +00:00
if ( $ location =~ /ssh\+vnc@([^:]*):([^:]*):(\d+)/ ) {
my @ output = (
"method: kvm" ,
"server: $1" ,
"vncdisplay: $2:$3" ,
2009-04-10 13:53:39 +00:00
"virturi: " . $ hypconn - > get_uri ( ) ,
2009-04-10 14:09:03 +00:00
"virtname: $node" ,
2009-02-15 22:42:22 +00:00
) ;
return 0 , @ output ;
} else {
return ( 1 , "Error: Unable to determine rvid destination for $node" ) ;
}
}
sub pick_target {
my $ node = shift ;
2009-03-18 20:00:51 +00:00
my $ addmemory = shift ;
2009-02-15 22:42:22 +00:00
my $ target ;
2009-10-20 23:56:40 +00:00
my $ mostfreememory = undef ;
my $ currentfreememory ;
2009-02-15 22:42:22 +00:00
my $ candidates = $ vmhash - > { $ node } - > [ 0 ] - > { migrationdest } ;
my $ currhyp = $ vmhash - > { $ node } - > [ 0 ] - > { host } ;
unless ( $ candidates ) {
return undef ;
}
foreach ( noderange ( $ candidates ) ) {
my $ targconn ;
my $ cand = $ _ ;
if ( $ _ eq $ currhyp ) { next ; } #skip current node
2009-10-20 23:22:04 +00:00
if ( $ offlinehyps { $ _ } ) { next } ; #skip already offlined nodes
2009-04-10 13:39:57 +00:00
if ( grep { "$_" eq $ cand } @ destblacklist ) { next ; } #skip blacklisted destinations
2009-10-20 23:22:04 +00:00
if ( not nodesockopen ( $ _ , 22 ) ) { $ offlinehyps { $ _ } = 1 ; next ; } #skip unusable destinations
2009-02-15 22:42:22 +00:00
eval { #Sys::Virt has bugs that cause it to die out in weird ways some times, contain it here
2009-04-10 13:53:39 +00:00
$ targconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1&netcat=nc" ) ;
2009-02-15 22:42:22 +00:00
} ;
unless ( $ targconn ) {
eval { #Sys::Virt has bugs that cause it to die out in weird ways some times, contain it here
2009-04-10 13:53:39 +00:00
$ targconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1" ) ;
2009-02-15 22:42:22 +00:00
} ;
}
unless ( $ targconn ) { next ; } #skip unreachable destinations
2009-10-20 23:56:40 +00:00
$ currentfreememory = $ targconn - > get_node_info ( ) - > { memory } ;
2009-02-15 22:42:22 +00:00
foreach ( $ targconn - > list_domains ( ) ) {
if ( $ _ - > get_name ( ) eq 'Domain-0' ) { next ; } #Dom0 memory usage is elastic, we are interested in HVM DomU memory, which is inelastic
2009-10-20 23:56:40 +00:00
$ currentfreememory -= $ _ - > get_info ( ) - > { memory } ;
2009-02-15 22:42:22 +00:00
}
2009-03-18 20:00:51 +00:00
if ( $ addmemory and $ addmemory - > { $ _ } ) {
2009-10-20 23:56:40 +00:00
$ currentfreememory -= $ addmemory - > { $ _ } ;
2009-03-18 20:00:51 +00:00
}
2009-10-20 23:56:40 +00:00
if ( not defined ( $ mostfreememory ) ) {
$ mostfreememory = $ currentfreememory ;
2009-02-15 22:42:22 +00:00
$ target = $ _ ;
2009-10-20 23:56:40 +00:00
} elsif ( $ currentfreememory > $ mostfreememory ) {
$ mostfreememory = $ currentfreememory ;
2009-02-15 22:42:22 +00:00
$ target = $ _ ;
}
}
return $ target ;
}
sub migrate {
2009-10-19 22:47:48 +00:00
$ node = shift ( ) ;
2009-02-15 22:42:22 +00:00
my $ targ = shift ( ) ;
2009-10-19 22:47:48 +00:00
if ( $ offlinevms { $ node } ) {
return power ( "on" ) ;
}
2009-02-15 22:42:22 +00:00
unless ( $ targ ) {
$ targ = pick_target ( $ node ) ;
}
unless ( $ targ ) {
return ( 1 , "Unable to identify a suitable target host for guest $node" ) ;
}
2009-10-20 01:02:01 +00:00
if ( $ use_xhrm ) {
xhrm_satisfy ( $ node , $ targ ) ;
}
2009-02-15 22:42:22 +00:00
my $ prevhyp ;
2009-04-10 13:53:39 +00:00
my $ target = "qemu+ssh://root@" . $ targ . "/system?no_tty=1" ;
my $ currhyp = "qemu+ssh://root@" ;
2009-02-15 22:42:22 +00:00
if ( $ vmhash - > { $ node } - > [ 0 ] - > { host } ) {
$ prevhyp = $ vmhash - > { $ node } - > [ 0 ] - > { host } ;
$ currhyp . = $ prevhyp ;
} else {
return ( 1 , "Unable to find current location of $node" ) ;
}
$ currhyp . = "/system?no_tty=1" ;
if ( $ currhyp eq $ target ) {
return ( 0 , "Guest is already on host $targ" ) ;
}
2009-04-10 13:39:57 +00:00
my $ srchypconn ;
my $ desthypconn ;
2009-10-20 23:22:04 +00:00
unless ( $ offlinehyps { $ prevhyp } or nodesockopen ( $ prevhyp , 22 ) ) {
$ offlinehyps { $ prevhyp } = 1 ;
}
2009-02-15 22:42:22 +00:00
my $ srcnetcatadd = "&netcat=nc" ;
2009-10-20 23:22:04 +00:00
unless ( $ offlinehyps { $ prevhyp } ) {
2009-02-15 22:42:22 +00:00
eval { #Contain Sys::Virt bugs
2009-10-20 23:22:04 +00:00
$ srchypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ prevhyp . "/system?no_tty=1$srcnetcatadd" ) ;
2009-02-15 22:42:22 +00:00
} ;
2009-10-20 23:22:04 +00:00
unless ( $ srchypconn ) {
$ srcnetcatadd = "" ;
eval { #Contain Sys::Virt bugs
$ srchypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ prevhyp . "/system?no_tty=1" ) ;
} ;
}
2009-02-15 22:42:22 +00:00
}
2009-04-10 13:39:57 +00:00
unless ( $ srchypconn ) {
2009-02-15 22:42:22 +00:00
return ( 1 , "Unable to reach $prevhyp to perform operation of $node, use nodech to change vm.host if certain of no split-brain possibility exists" ) ;
}
2009-10-20 23:22:04 +00:00
unless ( $ offlinehyps { $ targ } or nodesockopen ( $ targ , 22 ) ) {
$ offlinehyps { $ targ } = 1 ;
}
2009-02-15 22:42:22 +00:00
my $ destnetcatadd = "&netcat=nc" ;
2009-10-20 23:22:04 +00:00
unless ( $ offlinehyps { $ targ } ) {
2009-02-15 22:42:22 +00:00
eval { #Contain Sys::Virt bugs
2009-10-20 23:22:04 +00:00
$ desthypconn = Sys::Virt - > new ( uri = > $ target . $ destnetcatadd ) ;
2009-02-15 22:42:22 +00:00
} ;
2009-10-20 23:22:04 +00:00
unless ( $ desthypconn ) {
$ destnetcatadd = "" ;
eval { #Contain Sys::Virt bugs
$ desthypconn = Sys::Virt - > new ( uri = > $ target ) ;
} ;
}
2009-02-15 22:42:22 +00:00
}
2009-04-10 13:39:57 +00:00
unless ( $ desthypconn ) {
2009-02-15 22:42:22 +00:00
return ( 1 , "Unable to reach $targ to perform operation of $node, destination unusable." ) ;
}
my $ sock = IO::Socket::INET - > new ( Proto = > 'udp' ) ;
my $ ipa = inet_aton ( $ node ) ;
my $ pa = sockaddr_in ( 7 , $ ipa ) ; #UDP echo service, not needed to be actually
#serviced, we just want to trigger MAC move in the switch forwarding dbs
2009-04-10 13:39:57 +00:00
my $ nomadomain ;
eval {
$ nomadomain = $ srchypconn - > get_domain_by_name ( $ node ) ;
} ;
unless ( $ nomadomain ) {
return ( 1 , "Unable to find $node on $prevhyp, vm.host may be incorrect or a split-brain condition, such as libvirt forgetting a guest due to restart or bug." ) ;
}
my $ newdom ;
my $ errstr ;
eval {
$ newdom = $ nomadomain - > migrate ( $ desthypconn , & Sys::Virt::Domain:: MIGRATE_LIVE , undef , undef , 0 ) ;
} ;
if ( $@ ) { $ errstr = $@ ; }
#TODO: If it looks like it failed to migrate, ensure the guest exists only in one place
if ( $ errstr ) {
return ( 1 , "Failed migration of $node from $prevhyp to $targ: $errstr" ) ;
}
unless ( $ newdom ) {
return ( 1 , "Failed migration from $prevhyp to $targ" ) ;
}
2009-02-15 22:42:22 +00:00
system ( "arp -d $node" ) ; #Make ethernet fabric take note of change
send ( $ sock , "dummy" , 0 , $ pa ) ; #UDP packet to force forwarding table update in switches, ideally a garp happened, but just in case...
2009-04-10 13:39:57 +00:00
#BTW, this should all be moot since the underlying kvm seems good about gratuitous traffic, but it shouldn't hurt anything
refresh_vm ( $ newdom ) ;
#The migration seems tohave suceeded, but to be sure...
close ( $ sock ) ;
if ( $ desthypconn - > get_domain_by_name ( $ node ) ) {
2009-02-15 22:42:22 +00:00
$ vmtab - > setNodeAttribs ( $ node , { host = > $ targ } ) ;
return ( 0 , "migrated to $targ" ) ;
2009-04-10 13:39:57 +00:00
} else { #This *should* not be possible
return ( 1 , "Failed migration from $prevhyp to $targ, despite normal looking run..." ) ;
2009-02-15 22:42:22 +00:00
}
}
sub getpowstate {
my $ dom = shift ;
my $ vmstat ;
if ( $ dom ) {
$ vmstat = $ dom - > get_info ;
}
if ( $ vmstat and $ runningstates { $ vmstat - > { state } } ) {
return "on" ;
} else {
return "off" ;
}
}
2009-10-20 00:44:16 +00:00
sub xhrm_satisfy {
2009-10-20 01:02:01 +00:00
my $ node = shift ;
my $ hyp = shift ;
my @ nics = ( ) ;
my @ storage = ( ) ;
if ( $ vmhash - > { $ node } - > [ 0 ] - > { nics } ) {
@ nics = split /,/ , $ vmhash - > { $ node } - > [ 0 ] - > { nics } ;
}
if ( $ vmhash - > { $ node } - > [ 0 ] - > { storage } ) {
@ storage = split /\|/ , $ vmhash - > { $ node } - > [ 0 ] - > { storage } ;
}
foreach ( @ nics ) {
s/=.*// ; #this code cares not about the model of virtual nic
system ( "ssh $hyp xHRM bridgeprereq $_" ) ;
}
foreach ( @ storage ) {
if ( /^nfs:\/\// ) {
system ( "ssh $hyp xHRM storageprereq $_" ) ;
}
}
2009-10-20 00:44:16 +00:00
}
2009-02-15 22:42:22 +00:00
sub makedom {
my $ node = shift ;
2009-03-14 22:17:24 +00:00
my $ cdloc = shift ;
2009-02-15 22:42:22 +00:00
my $ dom ;
2009-03-14 22:17:24 +00:00
my $ xml = build_xmldesc ( $ node , $ cdloc ) ;
2009-02-15 22:42:22 +00:00
my $ errstr ;
eval { $ dom = $ hypconn - > create_domain ( $ xml ) ; } ;
if ( $@ ) { $ errstr = $@ ; }
if ( ref $ errstr ) {
$ errstr = ":" . $ errstr - > { message } ;
}
if ( $ errstr ) { return ( undef , $ errstr ) ; }
if ( $ dom ) {
refresh_vm ( $ dom ) ;
}
return $ dom , undef ;
}
2009-03-17 00:49:55 +00:00
sub createstorage {
my $ filename = shift ;
my $ mastername = shift ;
my $ size = shift ;
2009-10-20 00:44:16 +00:00
my $ basename ;
my $ dirname ;
( $ basename , $ dirname ) = fileparse ( $ filename ) ;
mkpath ( $ dirname ) ;
2009-03-17 00:49:55 +00:00
if ( $ mastername and $ size ) {
return 1 , "Can not specify both a master to clone and a size" ;
}
if ( $ mastername ) {
unless ( $ mastername =~ /^\// ) {
$ mastername = $ xCAT_plugin:: kvm:: masterdir . '/' . $ mastername ;
}
2009-10-20 23:22:04 +00:00
chdir ( $ dirname ) ;
2009-03-17 00:49:55 +00:00
my $ rc = system ( "qemu-img create -f qcow2 -b $mastername $filename" ) ;
if ( $ rc ) {
return $ rc , "Failure creating image $filename from $mastername" ;
}
}
if ( $ size ) {
my $ rc = system ( "qemu-img create -f qcow2 $filename " . getUnits ( $ size , "g" , 1024 ) ) ;
if ( $ rc ) {
return $ rc , "Failure creating image $filename of size $size\n" ;
}
}
}
2009-02-15 22:42:22 +00:00
2009-02-21 12:58:41 +00:00
sub mkvm {
2009-03-17 00:49:55 +00:00
shift ; #Throuw away first argument
@ ARGV = @ _ ;
my $ disksize ;
my $ mastername ;
my $ force = 0 ;
require Getopt::Long ;
GetOptions (
'master|m=s' = > \ $ mastername ,
'size|s=s' = > \ $ disksize ,
'force|f' = > \ $ force
) ;
2009-02-21 12:58:41 +00:00
build_xmldesc ( $ node ) ;
2009-10-20 00:44:16 +00:00
my $ diskstruct = build_diskstruct ( ) ;
2009-03-17 00:49:55 +00:00
if ( defined $ vmhash - > { $ node } - > [ 0 ] - > { storage } ) {
my $ diskname = $ vmhash - > { $ node } - > [ 0 ] - > { storage } ;
if ( $ diskname =~ /^phy:/ ) { #in this case, mkvm should have no argumens
if ( $ mastername or $ disksize ) {
return 1 , "mkvm management of block device storage not implemented" ;
}
2009-10-20 00:44:16 +00:00
} elsif ( $ diskname =~ /^nfs:/ ) {
$ diskname = get_path_for_nfsuri ( $ diskname ) . "/$node/" . fileparse ( $ diskstruct - > [ 0 ] - > { source } - > { file } ) ;
}
if ( - f $ diskname ) {
2009-03-17 00:49:55 +00:00
if ( $ mastername or $ disksize ) {
if ( $ force ) {
unlink $ diskname ;
} else {
return 1 , "Storage already exists, delete manually or use --force" ;
}
createstorage ( $ diskname , $ mastername , $ disksize ) ;
}
} else {
if ( $ mastername or $ disksize ) {
createstorage ( $ diskname , $ mastername , $ disksize ) ;
} else {
#TODO: warn they may have no disk? the mgt may not have visibility....
}
}
} else {
if ( $ mastername or $ disksize ) {
return 1 , "Requested initialization of storage, but vm.storage has no value for node" ;
}
}
2009-02-21 12:58:41 +00:00
}
2009-02-15 22:42:22 +00:00
sub power {
2009-03-14 22:17:24 +00:00
@ ARGV = @ _ ;
require Getopt::Long ;
my $ cdloc ;
GetOptions ( 'cdrom|iso|c|i=s' = > \ $ cdloc ) ;
my $ subcommand = shift @ ARGV ;
2009-02-15 22:42:22 +00:00
my $ retstring ;
my $ dom ;
eval {
$ dom = $ hypconn - > get_domain_by_name ( $ node ) ;
} ;
if ( $ subcommand eq "boot" ) {
my $ currstate = getpowstate ( $ dom ) ;
$ retstring = $ currstate . " " ;
if ( $ currstate eq "off" ) {
$ subcommand = "on" ;
} elsif ( $ currstate eq "on" ) {
$ subcommand = "reset" ;
}
}
my $ errstr ;
if ( $ subcommand eq 'on' ) {
unless ( $ dom ) {
2009-10-20 01:02:01 +00:00
if ( $ use_xhrm ) {
xhrm_satisfy ( $ node , $ hyp ) ;
}
2009-03-14 22:17:24 +00:00
( $ dom , $ errstr ) = makedom ( $ node , $ cdloc ) ;
2009-02-15 22:42:22 +00:00
if ( $ errstr ) { return ( 1 , $ errstr ) ; }
} else {
2009-04-13 13:14:46 +00:00
$ retstring . = "$status_noop" ;
2009-02-15 22:42:22 +00:00
}
} elsif ( $ subcommand eq 'off' ) {
if ( $ dom ) {
$ dom - > destroy ( ) ;
2009-04-13 13:16:58 +00:00
undef $ dom ;
2009-04-13 13:14:46 +00:00
} else { $ retstring . = "$status_noop" ; }
2009-02-15 22:42:22 +00:00
} elsif ( $ subcommand eq 'softoff' ) {
if ( $ dom ) {
$ dom - > shutdown ( ) ;
2009-04-13 13:14:46 +00:00
} else { $ retstring . = "$status_noop" ; }
2009-02-15 22:42:22 +00:00
} elsif ( $ subcommand eq 'reset' ) {
if ( $ dom ) {
$ dom - > destroy ( ) ;
2009-04-13 13:16:58 +00:00
undef $ dom ;
2009-10-20 01:02:01 +00:00
if ( $ use_xhrm ) {
xhrm_satisfy ( $ node , $ hyp ) ;
}
2009-03-14 22:17:24 +00:00
( $ dom , $ errstr ) = makedom ( $ node , $ cdloc ) ;
2009-02-15 22:42:22 +00:00
if ( $ errstr ) { return ( 1 , $ errstr ) ; }
$ retstring . = "reset" ;
2009-04-13 13:14:46 +00:00
} else { $ retstring . = "$status_noop" ; }
2009-02-15 22:42:22 +00:00
} else {
unless ( $ subcommand =~ /^stat/ ) {
return ( 1 , "Unsupported power directive '$subcommand'" ) ;
}
}
unless ( $ retstring =~ /reset/ ) {
2009-03-14 22:17:24 +00:00
$ retstring = $ retstring . getpowstate ( $ dom ) ;
2009-02-15 22:42:22 +00:00
}
return ( 0 , $ retstring ) ;
}
sub guestcmd {
$ hyp = shift ;
$ node = shift ;
my $ command = shift ;
my @ args = @ _ ;
my $ error ;
if ( $ command eq "rpower" ) {
return power ( @ args ) ;
2009-02-21 12:58:41 +00:00
} elsif ( $ command eq "mkvm" ) {
2009-03-17 00:49:55 +00:00
return mkvm ( $ node , @ args ) ;
2009-02-15 22:42:22 +00:00
} elsif ( $ command eq "rmigrate" ) {
return migrate ( $ node , @ args ) ;
} elsif ( $ command eq "getrvidparms" ) {
return getrvidparms ( $ node , @ args ) ;
2009-03-13 23:58:29 +00:00
} elsif ( $ command eq "getcons" ) {
return getcons ( $ node , @ args ) ;
2009-02-15 22:42:22 +00:00
}
= cut
} elsif ( $ command eq "rvitals" ) {
return vitals ( @ args ) ;
} elsif ( $ command =~ /r[ms]preset/ ) {
return resetmp ( @ args ) ;
} elsif ( $ command eq "rspconfig" ) {
return mpaconfig ( $ mpa , $ user , $ pass , $ node , $ slot , @ args ) ;
} elsif ( $ command eq "rbootseq" ) {
return bootseq ( @ args ) ;
} elsif ( $ command eq "switchblade" ) {
return switchblade ( @ args ) ;
} elsif ( $ command eq "getmacs" ) {
return getmacs ( @ args ) ;
} elsif ( $ command eq "rinv" ) {
return inv ( @ args ) ;
} elsif ( $ command eq "reventlog" ) {
return eventlog ( @ args ) ;
} elsif ( $ command eq "rscan" ) {
return rscan ( \ @ args ) ;
}
= cut
return ( 1 , "$command not a supported command by kvm method" ) ;
}
sub preprocess_request {
my $ request = shift ;
2009-07-15 15:10:54 +00:00
if ( $ request - > { _xcatpreprocessed } - > [ 0 ] == 1 ) { return [ $ request ] ; }
2009-02-15 22:42:22 +00:00
my $ callback = shift ;
my @ requests ;
my $ noderange = $ request - > { node } ; #Should be arrayref
my $ command = $ request - > { command } - > [ 0 ] ;
my $ extrargs = $ request - > { arg } ;
my @ exargs = ( $ request - > { arg } ) ;
if ( ref ( $ extrargs ) ) {
@ exargs = @$ extrargs ;
}
my $ usage_string = xCAT::Usage - > parseCommand ( $ command , @ exargs ) ;
if ( $ usage_string ) {
$ callback - > ( { data = > $ usage_string } ) ;
$ request = { } ;
return ;
}
if ( ! $ noderange ) {
$ usage_string = xCAT::Usage - > getUsage ( $ command ) ;
$ callback - > ( { data = > $ usage_string } ) ;
$ request = { } ;
return ;
}
#print "noderange=@$noderange\n";
# find service nodes for requested nodes
# build an individual request for each service node
my $ service = "xcat" ;
my $ sn = xCAT::Utils - > get_ServiceNode ( $ noderange , $ service , "MN" ) ;
# build each request for each service node
foreach my $ snkey ( keys %$ sn )
{
#print "snkey=$snkey\n";
my $ reqcopy = { %$ request } ;
$ reqcopy - > { node } = $ sn - > { $ snkey } ;
$ reqcopy - > { '_xcatdest' } = $ snkey ;
2009-07-15 15:10:54 +00:00
$ reqcopy - > { _xcatpreprocessed } - > [ 0 ] = 1 ;
2009-02-15 22:42:22 +00:00
push @ requests , $ reqcopy ;
}
return \ @ requests ;
}
sub adopt {
2009-03-18 20:00:51 +00:00
my $ orphash = shift ;
my $ hyphash = shift ;
my % hypsethash ;
my % addmemory = ( ) ;
my $ node ;
my $ target ;
foreach $ node ( keys % { $ orphash } ) {
$ target = pick_target ( $ node , \ % addmemory ) ;
unless ( $ target ) {
next ;
}
2009-10-20 04:30:08 +00:00
if ( $ vmhash - > { $ node } - > [ 0 ] - > { memory } ) {
$ addmemory { $ target } += getUnits ( $ vmhash - > { $ node } - > [ 0 ] - > { memory } , "M" , 1024 ) ;
} else {
$ addmemory { $ target } += getUnits ( "512" , "M" , 1024 ) ;
}
2009-03-18 20:00:51 +00:00
$ hyphash { $ target } - > { nodes } - > { $ node } = 1 ;
delete $ orphash - > { $ node } ;
push @ { $ hypsethash { $ target } } , $ node ;
}
foreach ( keys % hypsethash ) {
$ vmtab - > setNodesAttribs ( $ hypsethash { $ _ } , { 'host' = > $ _ } ) ;
}
if ( keys % { $ orphash } ) {
return 0 ;
} else {
return 1 ;
}
2009-02-15 22:42:22 +00:00
}
2009-03-18 20:00:51 +00:00
#TODO: adopt orphans into suitable homes if possible
# return 0;
#}
2009-02-15 22:42:22 +00:00
sub grab_table_data { #grab table data relevent to VM guest nodes
my $ noderange = shift ;
my $ callback = shift ;
$ vmtab = xCAT::Table - > new ( "vm" ) ;
2009-03-14 15:45:07 +00:00
my $ hmtab = xCAT::Table - > new ( "nodehm" ) ;
my $ nttab = xCAT::Table - > new ( "nodetype" ) ;
2009-02-15 22:42:22 +00:00
if ( $ hmtab ) {
$ hmhash = $ hmtab - > getNodesAttribs ( $ noderange , [ 'serialspeed' ] ) ;
}
2009-03-14 15:45:07 +00:00
if ( $ nttab ) {
2009-03-14 16:37:49 +00:00
$ nthash = $ nttab - > getNodesAttribs ( $ noderange , [ 'os' ] ) ; #allow us to guess RTC config
2009-03-14 15:45:07 +00:00
}
2009-02-15 22:42:22 +00:00
unless ( $ vmtab ) {
$ callback - > ( { data = > [ "Cannot open vm table" ] } ) ;
return ;
}
2009-03-14 00:37:20 +00:00
$ vmhash = $ vmtab - > getNodesAttribs ( $ noderange , [ 'node' , 'host' , 'migrationdest' , 'storage' , 'memory' , 'cpus' , 'nics' , 'bootorder' , 'virtflags' ] ) ;
2009-02-15 22:42:22 +00:00
$ mactab = xCAT::Table - > new ( "mac" , - create = > 1 ) ;
$ nrtab = xCAT::Table - > new ( "noderes" , - create = > 1 ) ;
2009-04-17 16:35:54 +00:00
$ machash = $ mactab - > getAllNodeAttribs ( [ 'mac' ] , 1 ) ;
my $ macs ;
my $ mac ;
foreach ( keys %$ machash ) {
$ macs = $ machash - > { $ _ } - > [ 0 ] - > { mac } ;
foreach $ mac ( split /\|/ , $ macs ) {
$ mac =~ s/\!.*// ;
$ usedmacs { lc ( $ mac ) } = 1 ;
}
}
2009-02-15 22:42:22 +00:00
}
sub process_request {
$ SIG { INT } = $ SIG { TERM } = sub {
foreach ( keys % vm_comm_pids ) {
kill 2 , $ _ ;
}
exit 0 ;
} ;
2009-10-19 22:47:48 +00:00
% offlinehyps = ( ) ;
% offlinevms = ( ) ;
2009-02-15 22:42:22 +00:00
my $ request = shift ;
my $ callback = shift ;
2009-04-09 14:10:38 +00:00
my $ libvirtsupport = eval {
require Sys::Virt ;
if ( Sys::Virt - > VERSION < "0.2.0" ) {
die ;
}
1 ;
} ;
2009-03-14 15:45:07 +00:00
unless ( $ libvirtsupport ) { #Still no Sys::Virt module
2009-04-09 14:10:38 +00:00
$ callback - > ( { error = > "Sys::Virt perl module missing or older than 0.2.0, unable to fulfill KVM plugin requirements" , errorcode = > [ 42 ] } ) ;
2009-03-14 15:45:07 +00:00
return [] ;
}
require Sys::Virt::Domain ;
% runningstates = ( & Sys::Virt::Domain:: STATE_NOSTATE = > 1 , & Sys::Virt::Domain:: STATE_RUNNING = > 1 , & Sys::Virt::Domain:: STATE_BLOCKED = > 1 ) ;
2009-02-15 22:42:22 +00:00
$ doreq = shift ;
my $ level = shift ;
my $ noderange = $ request - > { node } ;
my $ command = $ request - > { command } - > [ 0 ] ;
my @ exargs ;
unless ( $ command ) {
return ; #Empty request
}
if ( ref ( $ request - > { arg } ) ) {
@ exargs = @ { $ request - > { arg } } ;
} else {
@ exargs = ( $ request - > { arg } ) ;
}
2009-10-19 22:47:48 +00:00
my $ forcemode = 0 ;
my % orphans = ( ) ;
2009-10-20 01:45:04 +00:00
if ( $ command eq 'vmstatenotify' ) {
print "I see the command $command " . $ exargs [ 0 ] . " " . $ exargs [ 1 ] . "\n" ;
unless ( $ vmtab ) { $ vmtab = new xCAT:: Table ( 'vm' , - create = > 1 ) ; }
my $ state = $ exargs [ 0 ] ;
if ( $ state eq 'vmoff' ) {
$ vmtab - > setNodeAttribs ( $ exargs [ 1 ] , { powerstate = > 'off' } ) ;
print "Completion?\n" ;
return ;
} elsif ( $ state eq 'vmon' ) {
print "Completion?\n" ;
$ vmtab - > setNodeAttribs ( $ exargs [ 1 ] , { powerstate = > 'on' } ) ;
return ;
} elsif ( $ state eq 'hypshutdown' ) { #turn this into an evacuate
$ command = "revacuate" ;
@ exargs = ( ) ;
} elsif ( $ state eq 'hypstartup' ) { #if starting up, check for nodes on this hypervisor and start them up
my @ tents = $ vmtab - > getAttribs ( { host = > $ noderange - > [ 0 ] , power = > 'on' } , [ 'node' ] ) ;
$ noderange = [] ;
foreach ( @ tents ) {
push @$ noderange , noderange ( $ _ - > { node } ) ;
}
print "I'm thinking about " . $ noderange - > [ 0 ] . "\n" ;
$ command = "rpower" ;
@ exargs = ( "on" ) ;
}
}
2009-02-15 22:42:22 +00:00
if ( $ command eq 'revacuate' ) {
my $ newnoderange ;
2009-10-19 22:47:48 +00:00
if ( grep { $ _ eq '-f' } @ exargs ) {
$ forcemode = 1 ;
}
2009-02-15 22:42:22 +00:00
foreach ( @$ noderange ) {
2009-10-19 22:47:48 +00:00
my $ hyp = $ _ ; #I used $_ too much here... sorry
2009-02-15 22:42:22 +00:00
$ hypconn = undef ;
push @ destblacklist , $ _ ;
2009-10-20 23:22:04 +00:00
if ( ( not $ offlinehyps { $ _ } ) and nodesockopen ( $ _ , 22 ) ) {
2009-02-15 22:42:22 +00:00
eval { #Contain bugs that won't be in $@
2009-10-20 23:22:04 +00:00
$ hypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1&netcat=nc" ) ;
2009-02-15 22:42:22 +00:00
} ;
2009-10-20 23:22:04 +00:00
unless ( $ hypconn ) { #retry for socat
eval { #Contain bugs that won't be in $@
$ hypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1" ) ;
} ;
}
2009-02-15 22:42:22 +00:00
}
unless ( $ hypconn ) {
2009-10-20 23:22:04 +00:00
$ offlinehyps { $ hyp } = 1 ;
2009-10-19 22:47:48 +00:00
if ( $ forcemode ) { #forcemode indicates the hypervisor is probably already dead, and to clear vm.host of all the nodes, and adopt the ones that are supposed to be 'on', power them on
unless ( $ vmtab ) { $ vmtab = new xCAT:: Table ( 'vm' , - create = > 0 ) ; }
unless ( $ vmtab ) { next ; }
my @ vents = $ vmtab - > getAttribs ( { host = > $ hyp } , [ 'node' , 'powerstate' ] ) ;
my $ vent ;
my $ nodestozap ;
foreach $ vent ( @ vents ) {
my @ nodes = noderange ( $ vent - > { node } ) ;
if ( $ vent - > { powerstate } eq 'on' ) {
foreach ( @ nodes ) {
$ offlinevms { $ _ } = 1 ;
$ orphans { $ _ } = 1 ;
push @$ newnoderange , $ _ ;
}
}
push @$ nodestozap , @ nodes ;
}
$ vmtab - > setNodesAttribs ( $ nodestozap , { host = > '|^.*$||' } ) ;
} else {
$ callback - > ( { node = > [ { name = > [ $ _ ] , error = > [ "Cannot communicate via libvirt to node" ] } ] } ) ;
}
2009-02-15 22:42:22 +00:00
next ;
}
2009-10-19 22:47:48 +00:00
if ( $ hypconn ) {
foreach ( $ hypconn - > list_domains ( ) ) {
my $ guestname = $ _ - > get_name ( ) ;
if ( $ guestname eq 'Domain-0' ) {
next ;
}
push @$ newnoderange , $ guestname ;
2009-02-15 22:42:22 +00:00
}
}
}
$ hypconn = undef ;
$ noderange = $ newnoderange ;
$ command = 'rmigrate' ;
}
2009-03-17 18:00:44 +00:00
my $ sitetab = xCAT::Table - > new ( 'site' ) ;
2009-10-20 01:02:01 +00:00
if ( $ sitetab ) {
2009-10-20 01:45:04 +00:00
my $ xhent = $ sitetab - > getAttribs ( { key = > 'usexhrm' } , [ 'value' ] ) ;
2009-10-20 01:02:01 +00:00
if ( $ xhent and $ xhent - > { value } and $ xhent - > { value } !~ /no/i and $ xhent - > { value } !~ /disable/i ) {
$ use_xhrm = 1 ;
}
}
2009-02-15 22:42:22 +00:00
grab_table_data ( $ noderange , $ callback ) ;
if ( $ command eq 'revacuate' or $ command eq 'rmigrate' ) {
$ vmmaxp = 1 ; #for now throttle concurrent migrations, requires more sophisticated heuristics to ensure sanity
} else {
my $ tmp ;
if ( $ sitetab ) {
( $ tmp ) = $ sitetab - > getAttribs ( { 'key' = > 'vmmaxp' } , 'value' ) ;
if ( defined ( $ tmp ) ) { $ vmmaxp = $ tmp - > { value } ; }
}
}
my $ children = 0 ;
2009-04-07 18:42:57 +00:00
$ SIG { CHLD } = sub { my $ cpid ; while ( ( $ cpid = waitpid ( - 1 , WNOHANG ) ) > 0 ) { if ( $ vm_comm_pids { $ cpid } ) { delete $ vm_comm_pids { $ cpid } ; $ children - - ; } } } ;
2009-02-15 22:42:22 +00:00
my $ inputs = new IO:: Select ; ;
my $ sub_fds = new IO:: Select ;
% hyphash = ( ) ;
foreach ( keys % { $ vmhash } ) {
if ( $ vmhash - > { $ _ } - > [ 0 ] - > { host } ) {
$ hyphash { $ vmhash - > { $ _ } - > [ 0 ] - > { host } } - > { nodes } - > { $ _ } = 1 ;
} else {
$ orphans { $ _ } = 1 ;
}
}
if ( keys % orphans ) {
2009-03-18 20:00:51 +00:00
if ( $ command eq "rpower" ) {
if ( grep /^on$/ , @ exargs or grep /^boot$/ , @ exargs ) {
unless ( adopt ( \ % orphans , \ % hyphash ) ) {
$ callback - > ( { error = > "Can't find " . join ( "," , keys % orphans ) , errorcode = > [ 1 ] } ) ;
return 1 ;
}
} else {
foreach ( keys % orphans ) {
$ callback - > ( { node = > [ { name = > [ $ _ ] , data = > [ { contents = > [ 'off' ] } ] } ] } ) ;
}
2009-02-15 22:42:22 +00:00
}
} elsif ( $ command eq "rmigrate" ) {
2009-10-19 22:47:48 +00:00
if ( $ forcemode ) {
unless ( adopt ( \ % orphans , \ % hyphash ) ) {
$ callback - > ( { error = > "Can't find " . join ( "," , keys % orphans ) , errorcode = > [ 1 ] } ) ;
return 1 ;
}
} else {
$ callback - > ( { error = > "Can't find " . join ( "," , keys % orphans ) , errorcode = > [ 1 ] } ) ;
return ;
}
2009-09-04 16:17:12 +00:00
} elsif ( $ command eq "mkvm" ) { #mkvm can happen devoid of any hypervisor, make a fake hypervisor entry to allow this to occur
foreach ( keys % orphans ) {
$ hyphash { '!@!XCATDUMMYHYPERVISOR!@!' } - > { nodes } - > { $ _ } = 1 ;
}
2009-02-15 22:42:22 +00:00
} else {
$ callback - > ( { error = > "Can't find " . join ( "," , keys % orphans ) , errorcode = > [ 1 ] } ) ;
return ;
}
}
if ( $ command eq "rbeacon" ) {
my % req = ( ) ;
$ req { command } = [ 'rbeacon' ] ;
$ req { arg } = \ @ exargs ;
$ req { node } = [ keys % hyphash ] ;
$ doreq - > ( \ % req , $ callback ) ;
return ;
}
#get new node status
2009-03-25 02:56:58 +00:00
my % oldnodestatus = ( ) ; #saves the old node status
my @ allerrornodes = ( ) ;
2009-02-15 22:42:22 +00:00
my $ check = 0 ;
2009-03-24 03:12:03 +00:00
my $ global_check = 1 ;
if ( $ sitetab ) {
2009-03-24 19:44:23 +00:00
( my $ ref ) = $ sitetab - > getAttribs ( { key = > 'nodestatus' } , 'value' ) ;
2009-03-24 23:56:42 +00:00
if ( $ ref ) {
2009-03-24 19:44:23 +00:00
if ( $ ref - > { value } =~ /0|n|N/ ) { $ global_check = 0 ; }
2009-03-24 03:12:03 +00:00
}
}
2009-03-25 02:56:58 +00:00
2009-02-15 22:42:22 +00:00
if ( $ command eq 'rpower' ) {
my $ subcommand = $ exargs [ 0 ] ;
2009-03-24 03:12:03 +00:00
if ( ( $ global_check ) && ( $ subcommand ne 'stat' ) && ( $ subcommand ne 'status' ) ) {
2009-02-15 22:42:22 +00:00
$ check = 1 ;
my @ allnodes = @$ noderange ;
2009-03-25 02:56:58 +00:00
#save the old status
my $ nodelisttab = xCAT::Table - > new ( 'nodelist' ) ;
if ( $ nodelisttab ) {
my $ tabdata = $ nodelisttab - > getNodesAttribs ( \ @ allnodes , [ 'node' , 'status' ] ) ;
foreach my $ node ( @ allnodes )
{
my $ tmp1 = $ tabdata - > { $ node } - > [ 0 ] ;
if ( $ tmp1 ) {
if ( $ tmp1 - > { status } ) { $ oldnodestatus { $ node } = $ tmp1 - > { status } ; }
else { $ oldnodestatus { $ node } = "" ; }
}
}
}
#print "oldstatus:" . Dumper(\%oldnodestatus);
#set the new status to the nodelist.status
my % newnodestatus = ( ) ;
my $ newstat ;
if ( ( $ subcommand eq 'off' ) || ( $ subcommand eq 'softoff' ) ) {
my $ newstat = $ ::STATUS_POWERING_OFF ;
$ newnodestatus { $ newstat } = \ @ allnodes ;
} else {
2009-02-15 22:42:22 +00:00
#get the current nodeset stat
if ( @ allnodes > 0 ) {
my $ nsh = { } ;
2009-03-20 21:36:49 +00:00
my ( $ ret , $ msg ) = xCAT::SvrUtils - > getNodesetStates ( \ @ allnodes , $ nsh ) ;
2009-02-15 22:42:22 +00:00
if ( ! $ ret ) {
foreach ( keys %$ nsh ) {
2009-03-25 02:56:58 +00:00
my $ newstat = xCAT_monitoring::monitorctrl - > getNodeStatusFromNodesetState ( $ _ , "rpower" ) ;
$ newnodestatus { $ newstat } = $ nsh - > { $ _ } ;
2009-02-15 22:42:22 +00:00
}
2009-03-25 02:56:58 +00:00
} else {
$ callback - > ( { data = > $ msg } ) ;
2009-02-15 22:42:22 +00:00
}
}
}
2009-03-25 02:56:58 +00:00
#print "newstatus" . Dumper(\%newnodestatus);
xCAT_monitoring::monitorctrl:: setNodeStatusAttributes ( \ % newnodestatus , 1 ) ;
2009-02-15 22:42:22 +00:00
}
}
2009-03-17 00:49:55 +00:00
my $ sent = $ sitetab - > getAttribs ( { key = > 'masterimgdir' } , 'value' ) ;
if ( $ sent ) {
$ xCAT_plugin:: kvm:: masterdir = $ sent - > { value } ;
}
2009-02-15 22:42:22 +00:00
foreach $ hyp ( sort ( keys % hyphash ) ) {
while ( $ children > $ vmmaxp ) {
2009-03-25 02:56:58 +00:00
my $ handlednodes = { } ;
forward_data ( $ callback , $ sub_fds , $ handlednodes ) ;
2009-02-15 22:42:22 +00:00
#update the node status to the nodelist.status table
if ( $ check ) {
2009-03-25 02:56:58 +00:00
updateNodeStatus ( $ handlednodes , \ @ allerrornodes ) ;
2009-02-15 22:42:22 +00:00
}
}
$ children + + ;
my $ cfd ;
my $ pfd ;
socketpair ( $ pfd , $ cfd , AF_UNIX , SOCK_STREAM , PF_UNSPEC ) or die "socketpair: $!" ;
$ cfd - > autoflush ( 1 ) ;
$ pfd - > autoflush ( 1 ) ;
my $ cpid = xCAT::Utils - > xfork ;
unless ( defined ( $ cpid ) ) { die "Fork error" ; }
unless ( $ cpid ) {
close ( $ cfd ) ;
dohyp ( $ pfd , $ hyp , $ command , - args = > \ @ exargs ) ;
exit ( 0 ) ;
}
$ vm_comm_pids { $ cpid } = 1 ;
close ( $ pfd ) ;
$ sub_fds - > add ( $ cfd ) ;
}
while ( $ sub_fds - > count > 0 or $ children > 0 ) {
2009-03-25 02:56:58 +00:00
my $ handlednodes = { } ;
forward_data ( $ callback , $ sub_fds , $ handlednodes ) ;
2009-02-15 22:42:22 +00:00
#update the node status to the nodelist.status table
if ( $ check ) {
2009-03-25 02:56:58 +00:00
updateNodeStatus ( $ handlednodes , \ @ allerrornodes ) ;
2009-02-15 22:42:22 +00:00
}
}
#Make sure they get drained, this probably is overkill but shouldn't hurt
my $ rc = 1 ;
while ( $ rc > 0 ) {
2009-03-25 02:56:58 +00:00
my $ handlednodes = { } ;
$ rc = forward_data ( $ callback , $ sub_fds , $ handlednodes ) ;
2009-02-15 22:42:22 +00:00
#update the node status to the nodelist.status table
if ( $ check ) {
2009-03-25 02:56:58 +00:00
updateNodeStatus ( $ handlednodes , \ @ allerrornodes ) ;
2009-02-15 22:42:22 +00:00
}
2009-03-25 02:56:58 +00:00
}
if ( $ check ) {
#print "allerrornodes=@allerrornodes\n";
#revert the status back for there is no-op for the nodes
my % old = ( ) ;
foreach my $ node ( @ allerrornodes ) {
my $ stat = $ oldnodestatus { $ node } ;
if ( exists ( $ old { $ stat } ) ) {
my $ pa = $ old { $ stat } ;
push ( @$ pa , $ node ) ;
}
else {
$ old { $ stat } = [ $ node ] ;
}
}
xCAT_monitoring::monitorctrl:: setNodeStatusAttributes ( \ % old , 1 ) ;
2009-02-15 22:42:22 +00:00
}
}
sub updateNodeStatus {
2009-03-25 02:56:58 +00:00
my $ handlednodes = shift ;
my $ allerrornodes = shift ;
foreach my $ node ( keys ( %$ handlednodes ) ) {
if ( $ handlednodes - > { $ node } == - 1 ) { push ( @$ allerrornodes , $ node ) ; }
2009-02-15 22:42:22 +00:00
}
}
sub forward_data {
my $ callback = shift ;
my $ fds = shift ;
my $ errornodes = shift ;
my @ ready_fds = $ fds - > can_read ( 1 ) ;
my $ rfh ;
my $ rc = @ ready_fds ;
foreach $ rfh ( @ ready_fds ) {
my $ data ;
if ( $ data = <$rfh> ) {
while ( $ data !~ /ENDOFFREEZE6sK4ci/ ) {
$ data . = <$rfh> ;
}
2009-04-03 19:12:56 +00:00
eval { print $ rfh "ACK\n" ; } ; #ignore failures to send inter-process ack
2009-02-15 22:42:22 +00:00
my $ responses = thaw ( $ data ) ;
foreach ( @$ responses ) {
#save the nodes that has errors and the ones that has no-op for use by the node status monitoring
my $ no_op = 0 ;
if ( $ _ - > { node } - > [ 0 ] - > { errorcode } ) { $ no_op = 1 ; }
else {
my $ text = $ _ - > { node } - > [ 0 ] - > { data } - > [ 0 ] - > { contents } - > [ 0 ] ;
#print "data:$text\n";
if ( ( $ text ) && ( $ text =~ /$status_noop/ ) ) {
$ no_op = 1 ;
#remove the symbols that meant for use by node status
2009-04-13 13:14:46 +00:00
$ _ - > { node } - > [ 0 ] - > { data } - > [ 0 ] - > { contents } - > [ 0 ] =~ s/$status_noop// ;
2009-02-15 22:42:22 +00:00
}
}
#print "data:". $_->{node}->[0]->{data}->[0]->{contents}->[0] . "\n";
if ( $ no_op ) {
if ( $ errornodes ) { $ errornodes - > { $ _ - > { node } - > [ 0 ] - > { name } - > [ 0 ] } = - 1 ; }
} else {
if ( $ errornodes ) { $ errornodes - > { $ _ - > { node } - > [ 0 ] - > { name } - > [ 0 ] } = 1 ; }
}
$ callback - > ( $ _ ) ;
}
} else {
$ fds - > remove ( $ rfh ) ;
close ( $ rfh ) ;
}
}
yield ( ) ; #Try to avoid useless iterations as much as possible
return $ rc ;
}
sub dohyp {
my $ out = shift ;
$ hyp = shift ;
my $ command = shift ;
my % namedargs = @ _ ;
my @ exargs = @ { $ namedargs { - args } } ;
my $ node ;
my $ args = \ @ exargs ;
$ vmtab = xCAT::Table - > new ( "vm" ) ;
2009-10-20 23:56:40 +00:00
unless ( $ offlinehyps { $ hyp } or ( $ hyp eq '!@!XCATDUMMYHYPERVISOR!@!' ) or nodesockopen ( $ hyp , 22 ) ) {
2009-10-20 23:22:04 +00:00
$ offlinehyps { $ hyp } = 1 ;
}
2009-02-15 22:42:22 +00:00
eval { #Contain Sys::Virt bugs that make $@ useless
2009-09-04 16:17:12 +00:00
if ( $ hyp eq '!@!XCATDUMMYHYPERVISOR!@!' ) { #Fake connection for commands that have a fake hypervisor key
$ hypconn = 1 ;
2009-10-20 23:22:04 +00:00
} elsif ( not $ offlinehyps { $ hyp } ) {
2009-09-04 16:17:12 +00:00
$ hypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ hyp . "/system?no_tty=1&netcat=nc" ) ;
}
2009-02-15 22:42:22 +00:00
} ;
2009-10-20 23:22:04 +00:00
unless ( $ hypconn or $ offlinehyps { $ hyp } ) {
2009-02-15 22:42:22 +00:00
eval { #Contain Sys::Virt bugs that make $@ useless
2009-04-10 13:53:39 +00:00
$ hypconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ hyp . "/system?no_tty=1" ) ;
2009-02-15 22:42:22 +00:00
} ;
}
unless ( $ hypconn ) {
my % err = ( node = > [] ) ;
foreach ( keys % { $ hyphash { $ hyp } - > { nodes } } ) {
2009-03-18 20:00:51 +00:00
push ( @ { $ err { node } } , { name = > [ $ _ ] , error = > [ "Cannot communicate via libvirt to $hyp" ] , errorcode = > [ 1 ] } ) ;
2009-02-15 22:42:22 +00:00
}
print $ out freeze ( [ \ % err ] ) ;
print $ out "\nENDOFFREEZE6sK4ci\n" ;
yield ( ) ;
waitforack ( $ out ) ;
return 1 , "General error establishing libvirt communication" ;
}
foreach $ node ( sort ( keys % { $ hyphash { $ hyp } - > { nodes } } ) ) {
my ( $ rc , @ output ) = guestcmd ( $ hyp , $ node , $ command , @$ args ) ;
foreach ( @ output ) {
my % output ;
if ( ref ( $ _ ) ) {
print $ out freeze ( [ $ _ ] ) ;
print $ out "\nENDOFFREEZE6sK4ci\n" ;
yield ( ) ;
waitforack ( $ out ) ;
next ;
}
( my $ desc , my $ text ) = split ( /:/ , $ _ , 2 ) ;
unless ( $ text ) {
$ text = $ desc ;
} else {
$ desc =~ s/^\s+// ;
$ desc =~ s/\s+$// ;
if ( $ desc ) {
$ output { node } - > [ 0 ] - > { data } - > [ 0 ] - > { desc } - > [ 0 ] = $ desc ;
}
}
$ text =~ s/^\s+// ;
$ text =~ s/\s+$// ;
$ output { node } - > [ 0 ] - > { errorcode } = $ rc ;
$ output { node } - > [ 0 ] - > { name } - > [ 0 ] = $ node ;
$ output { node } - > [ 0 ] - > { data } - > [ 0 ] - > { contents } - > [ 0 ] = $ text ;
print $ out freeze ( [ \ % output ] ) ;
print $ out "\nENDOFFREEZE6sK4ci\n" ;
yield ( ) ;
waitforack ( $ out ) ;
}
yield ( ) ;
}
#my $msgtoparent=freeze(\@outhashes); # = XMLout(\%output,RootName => 'xcatresponse');
#print $out $msgtoparent; #$node.": $_\n";
}
1 ;