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 ;
2009-11-28 00:50:14 +00:00
use xCAT::VMCommon ;
2009-02-15 22:42:22 +00:00
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-11-22 19:41:52 +00:00
my $ imgfmt = 'raw' ; #use raw format by default
my $ clonemethod = 'qemu-img' ; #use qemu-img command
2009-02-15 22:42:22 +00:00
my % vm_comm_pids ;
2009-10-19 22:47:48 +00:00
my % offlinehyps ;
2009-12-02 00:37:04 +00:00
my % hypstats ;
2009-10-19 22:47:48 +00:00
my % offlinevms ;
2009-02-15 22:42:22 +00:00
my @ destblacklist ;
2009-11-27 18:55:13 +00:00
my $ updatetable ; #when a function is performing per-node operations, it can queue up a table update by populating parts of this hash
2009-11-28 00:50:14 +00:00
my $ confdata ; #a reference to serve as a common pointer betweer VMCommon functions and this plugin
my $ libvirtsupport ;
$ libvirtsupport = eval {
require Sys::Virt ;
if ( Sys::Virt - > VERSION < "0.2.0" ) {
die ;
}
1 ;
} ;
2009-02-15 22:42:22 +00:00
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 ;
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' ,
2010-07-21 15:23:37 +00:00
chvm = > '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' ,
2010-08-25 18:39:42 +00:00
lsvm = > [ 'hypervisor:type' , 'nodetype:os=(rhel.*)' ] ,
2009-02-15 22:42:22 +00:00
rbeacon = > 'nodehm:mgt' ,
2010-08-25 18:39:42 +00:00
revacuate = > [ 'hypervisor:type' , 'nodetype:os=(rhel.*)|(sles11.*)|(centos.*)|(fedora.*)' ] ,
vmstatenotify = > [ 'hypervisor:type' , 'nodetype:os=(rhel.*)|(sles11.*)|(centos.*)|(fedora.*)' ] ,
2009-02-15 22:42:22 +00:00
#rspreset => 'nodehm:mgt',
#rspconfig => 'nodehm:mgt',
#rbootseq => 'nodehm:mgt',
#reventlog => 'nodehm:mgt',
} ;
}
my $ hypconn ;
my $ hyp ;
my $ doreq ;
my % hyphash ;
my $ node ;
my $ vmtab ;
2010-08-12 18:30:41 +00:00
my $ kvmdatatab ;
2009-02-15 22:42:22 +00:00
2010-07-01 21:03:00 +00:00
sub build_pool_xml {
my $ url = shift ;
2010-07-22 13:55:50 +00:00
my $ mounthost = shift ;
unless ( $ mounthost ) { $ mounthost = $ hyp ; }
2010-07-01 21:03:00 +00:00
my $ pool ;
my $ host = $ url ;
$ host =~ s/.*:\/\/// ;
$ host =~ s/(\/.*)// ;
my $ srcpath = $ 1 ;
2010-07-19 17:43:15 +00:00
my $ uuid = xCAT::Utils:: genUUID ( url = > $ url ) ;
2010-07-01 21:03:00 +00:00
my $ pooldesc = '<pool type="netfs">' ;
2010-07-21 15:23:37 +00:00
$ pooldesc . = '<name>' . $ url . '</name>' ; #Hey, at least libvirt doesn't have stupid name restrictions...
2010-07-19 17:43:15 +00:00
$ pooldesc . = '<uuid>' . $ uuid . '</uuid>>' ;
2010-07-01 21:03:00 +00:00
$ pooldesc . = '<source>' ;
$ pooldesc . = '<host name="' . $ host . '"/>' ;
$ pooldesc . = '<dir path="' . $ srcpath . '"/>' ;
$ pooldesc . = '</source>' ;
2010-07-21 15:23:37 +00:00
$ pooldesc . = '<target><path>/var/lib/xcat/pools/' . $ uuid . '</path></target></pool>' ;
2010-07-22 13:55:50 +00:00
system ( "ssh $mounthost mkdir -p /var/lib/xcat/pools/$uuid" ) ; #ok, so not *technically* just building XML, but here is the cheapest
2010-07-21 15:23:37 +00:00
#place to know uuid... And yes, we must be allowed to ssh in
#libvirt just isn't capable enough for this sort of usage
2010-07-01 21:03:00 +00:00
return $ pooldesc ;
}
2010-07-02 20:41:29 +00:00
sub get_storage_pool_by_url {
2010-07-01 21:03:00 +00:00
my $ url = shift ;
2010-07-22 13:55:50 +00:00
my $ virtconn = shift ;
my $ mounthost = shift ;
unless ( $ virtconn ) { $ virtconn = $ hypconn ; }
my @ currpools = $ virtconn - > list_storage_pools ( ) ;
2010-07-01 21:03:00 +00:00
my $ poolobj ;
my $ pool ;
foreach my $ poolo ( @ currpools ) {
$ poolobj = $ poolo ;
$ pool = XMLin ( $ poolobj - > get_xml_description ( ) ) ;
if ( $ pool - > { name } eq $ url ) {
last ;
}
$ pool = undef ;
}
2010-07-02 20:41:29 +00:00
if ( $ pool ) { return $ poolobj ; }
2010-07-22 13:55:50 +00:00
$ poolobj = $ virtconn - > create_storage_pool ( build_pool_xml ( $ url , $ mounthost ) ) ;
2010-07-02 20:41:29 +00:00
return $ poolobj ;
}
2010-07-06 14:51:19 +00:00
sub get_multiple_paths_by_url {
my % args = @ _ ;
my $ url = $ args { url } ;
my $ node = $ args { node } ;
my $ poolobj = get_storage_pool_by_url ( $ url ) ;
unless ( $ poolobj ) { die "Cound not get storage pool for $url" ; }
2010-07-30 12:48:47 +00:00
$ poolobj - > refresh ( ) ; #if volumes change on nfs storage, libvirt is too dumb to notice
2010-07-06 14:51:19 +00:00
my @ volobjs = $ poolobj - > list_volumes ( ) ;
my % paths ;
foreach ( @ volobjs ) {
2010-07-30 14:53:45 +00:00
if ( $ _ - > get_name ( ) =~ /^$node\.([^\.]*)\.([^\.]*)$/ ) {
$ paths { $ _ - > get_path ( ) } = { device = > $ 1 , format = > $ 2 } ;
2010-07-30 14:58:49 +00:00
} elsif ( $ _ - > get_name ( ) =~ /^$node\.([^\.]*)$/ ) {
2010-07-30 14:53:45 +00:00
$ paths { $ _ - > get_path ( ) } = { device = > $ 1 , format = > 'raw' } ;
#this requires any current user of qcow2 to migrate, unfortunate to escape
#a vulnerability where raw user could write malicious qcow2 to header
#and use that to get at files on the hypervisor os with escalated privilege
2010-07-06 14:51:19 +00:00
}
}
return \ % paths ;
}
sub get_filepath_by_url { #at the end of the day, the libvirt storage api gives the following capability:
#mount, limited ls, and qemu-img
#it does not frontend mkdir, and does not abstract away any nitty-gritty detail, you must know:
#the real mountpoint, and the real full path to storage
#in addition to this, subdirectories are not allowed, and certain extra metadata must be created
#not a big fan compared to ssh and run the commands myself, but it's the most straightforward path
#to avoid ssh for users who dislike that style access
2010-07-02 20:41:29 +00:00
my % args = @ _ ;
my $ url = $ args { url } ;
my $ dev = $ args { dev } ;
my $ create = $ args { create } ;
my $ force = $ args { force } ;
my $ format = $ args { format } ;
unless ( $ format ) {
$ format = 'qcow2' ;
2010-07-01 21:03:00 +00:00
}
#ok, now that we have the pool, we need the storage volume from the pool for the node/dev
2010-07-02 20:41:29 +00:00
my $ poolobj = get_storage_pool_by_url ( $ url ) ;
unless ( $ poolobj ) { die "Could not get storage pool for $url" ; }
2010-07-30 12:48:47 +00:00
$ poolobj - > refresh ( ) ; #if volumes change on nfs storage, libvirt is too dumb to notice
2010-07-01 21:03:00 +00:00
my @ volobjs = $ poolobj - > list_volumes ( ) ;
2010-07-30 14:53:45 +00:00
my $ desiredname = $ node . '.' . $ dev . '.' . $ format ;
2010-07-01 21:03:00 +00:00
foreach ( @ volobjs ) {
if ( $ _ - > get_name ( ) eq $ desiredname ) {
2010-07-02 20:41:29 +00:00
if ( $ create ) {
if ( $ force ) { #must destroy the storage
$ _ - > delete ( ) ;
} else {
die "Path already exists" ;
}
} else {
return $ _ - > get_path ( ) ;
}
2010-07-01 21:03:00 +00:00
}
}
2010-07-02 20:41:29 +00:00
if ( $ create ) {
if ( $ create =~ /^clone=/ ) {
} else {
my $ vol = $ poolobj - > create_volume ( "<volume><name>" . $ desiredname . "</name><target><format type='$format'/></target><capacity>" . getUnits ( $ create , "G" , 1 ) . "</capacity><allocation>0</allocation></volume>" ) ;
if ( $ vol ) { return $ vol - > get_path ( ) ; }
}
} else {
return undef ;
2009-10-20 00:44:16 +00:00
}
}
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' ;
2009-11-28 00:50:14 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { bootorder } ) {
my $ bootorder = $ confdata - > { vm } - > { $ 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-11-28 00:50:14 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ) {
my $ disklocs = $ confdata - > { vm } - > { $ 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 ;
2010-07-02 20:41:29 +00:00
$ disk =~ s/=(.*)// ;
my $ model = $ 1 ;
2010-08-25 15:42:36 +00:00
unless ( $ model ) {
#if not defined, model will stay undefined like above
2010-08-25 15:48:14 +00:00
$ model = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storagemodel } ;
2010-08-25 15:42:36 +00:00
unless ( $ model ) { $ model = 'ide' ; } #if still not defined, ide
}
2010-07-02 20:41:29 +00:00
my $ prefix = 'hd' ;
if ( $ model eq 'virtio' ) {
$ prefix = 'vd' ;
} elsif ( $ model eq 'scsi' ) {
$ prefix = 'sd' ;
}
2009-02-15 22:42:22 +00:00
$ diskhash - > { type } = 'file' ;
$ diskhash - > { device } = 'disk' ;
2010-07-02 20:41:29 +00:00
$ diskhash - > { target } - > { dev } = $ prefix . $ suffixes [ $ suffidx ] ;
$ diskhash - > { target } - > { bus } = $ model ;
2009-02-15 22:42:22 +00:00
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:\/\/(.*)$/ ) {
2010-07-06 14:51:19 +00:00
my % disks = % { get_multiple_paths_by_url ( url = > $ disk_parts [ 0 ] , node = > $ node ) } ;
unless ( keys % disks ) {
die "Unable to find any persistent disks at " . $ disk_parts [ 0 ] ;
}
foreach ( keys % disks ) {
my $ tdiskhash ;
$ tdiskhash - > { type } ;
$ tdiskhash - > { device } = 'disk' ;
2010-07-30 14:53:45 +00:00
$ tdiskhash - > { driver } - > { name } = 'qemu' ;
$ tdiskhash - > { driver } - > { type } = $ disks { $ _ } - > { format } ;
2010-07-06 14:51:19 +00:00
$ tdiskhash - > { source } - > { file } = $ _ ;
2010-07-30 14:53:45 +00:00
$ tdiskhash - > { target } - > { dev } = $ disks { $ _ } - > { device } ;
2010-07-06 14:51:19 +00:00
if ( $ disks { $ _ } =~ /^vd/ ) {
$ tdiskhash - > { target } - > { bus } = 'virtio' ;
} elsif ( $ disks { $ _ } =~ /^hd/ ) {
$ tdiskhash - > { target } - > { bus } = 'ide' ;
} elsif ( $ disks { $ _ } =~ /^sd/ ) {
$ tdiskhash - > { target } - > { bus } = 'scsi' ;
}
push @ returns , $ tdiskhash ;
2010-07-02 19:09:49 +00:00
}
2010-07-06 14:51:19 +00:00
next ; #nfs:// skips the other stuff
#$diskhash->{source}->{file} = get_filepath_by_url(url=>$disk_parts[0],dev=>$diskhash->{target}->{dev}); #"/var/lib/xcat/vmnt/nfs_".$1."/$node/".$diskhash->{target}->{dev};
2010-07-21 15:23:37 +00:00
} else { #currently, this would be a bare file to slap in as a disk
2009-02-15 22:42:22 +00:00
$ 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 ;
2010-05-16 23:03:33 +00:00
if ( $ confdata - > { vpd } - > { $ node } - > [ 0 ] and $ confdata - > { vpd } - > { $ node } - > [ 0 ] - > { uuid } ) {
return $ confdata - > { vpd } - > { $ node } - > [ 0 ] - > { uuid } ;
}
2010-05-16 23:08:49 +00:00
if ( $ confdata - > { mac } - > { $ node } - > [ 0 ] - > { mac } ) { #a uuidv1 is possible, generate that for absolute uniqueness guarantee
my $ mac = $ confdata - > { mac } - > { $ node } - > [ 0 ] - > { mac } ;
2010-05-16 18:54:46 +00:00
$ mac =~ s/\|.*// ;
$ mac =~ s/!.*// ;
2010-05-16 23:03:33 +00:00
$ updatetable - > { vpd } - > { $ node } = { uuid = > xCAT::Utils:: genUUID ( mac = > $ mac ) } ;
2010-05-16 18:54:46 +00:00
} else {
2010-05-16 23:03:33 +00:00
$ updatetable - > { vpd } - > { $ node } = { uuid = > xCAT::Utils:: genUUID ( ) } ;
2010-05-16 18:54:46 +00:00
}
2010-05-16 23:03:33 +00:00
return $ updatetable - > { vpd } - > { $ node } ;
2010-05-16 18:54:46 +00:00
2009-02-15 22:42:22 +00:00
}
sub build_nicstruct {
my $ rethash ;
my $ node = shift ;
my @ macs = ( ) ;
2009-03-13 23:58:29 +00:00
my @ nics = ( ) ;
2009-11-28 00:50:14 +00:00
if ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nics } ) {
@ nics = split /,/ , $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nics } ;
2009-03-13 23:58:29 +00:00
} else {
@ nics = ( 'virbr0' ) ;
}
2009-11-28 00:50:14 +00:00
if ( $ confdata - > { mac } - > { $ node } - > [ 0 ] - > { mac } ) {
my $ macdata = $ confdata - > { mac } - > { $ node } - > [ 0 ] - > { mac } ;
2009-02-15 22:42:22 +00:00
foreach my $ macaddr ( split /\|/ , $ macdata ) {
$ macaddr =~ s/\!.*// ;
push @ macs , $ macaddr ;
}
}
2009-04-17 16:35:54 +00:00
unless ( scalar ( @ macs ) >= scalar ( @ nics ) ) {
2009-11-27 18:55:13 +00:00
#TODO: MUST REPLACE WITH VMCOMMON CODE
2009-04-17 16:35:54 +00:00
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-11-28 00:50:14 +00:00
#$mactab->setNodeAttribs($node,{mac=>join('|',@macs)});
#$nrtab->setNodeAttribs($node,{netboot=>'pxe'});
#$doreq->({command=>['makedhcp'],node=>[$node]});
2009-02-15 22:42:22 +00:00
}
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
2010-08-25 15:42:36 +00:00
if ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nicmodel } ) {
$ type = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nicmodel } ;
}
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 ( ) ;
2009-11-28 00:50:14 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { memory } ) {
$ xtree { memory } - > { content } = getUnits ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { memory } , "M" , 1024 ) ;
2009-02-15 22:42:22 +00:00
} else {
$ xtree { memory } - > { content } = 524288 ;
}
2009-11-28 00:50:14 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { cpus } ) {
$ xtree { vcpu } - > { content } = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { cpus } ;
2009-03-14 00:37:20 +00:00
} else {
$ xtree { vcpu } - > { content } = 1 ;
}
2009-11-28 00:50:14 +00:00
if ( defined ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { clockoffset } ) ) {
2009-03-14 16:44:02 +00:00
#If user requested a specific behavior, give it
2009-11-28 00:50:14 +00:00
$ xtree { clock } - > { offset } = $ confdata - > { vm } - > { $ 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
2009-11-28 00:50:14 +00:00
if ( defined ( $ confdata - > { nodetype } - > { $ node } - > [ 0 ] - > { os } ) and $ confdata - > { nodetype } - > { $ node } - > [ 0 ] - > { os } =~ /win.*/ ) {
2009-03-14 16:44:02 +00:00
$ 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 ) ;
2010-05-17 19:04:36 +00:00
#use content to force xml simple to not make model the 'name' of video
$ xtree { devices } - > { video } = [ { 'content' = > '' , 'model' = > { type = > 'vga' , vram = > 8192 } } ] ;
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 ;
2010-08-13 12:26:17 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
2010-08-12 18:30:41 +00:00
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
2010-08-13 12:26:17 +00:00
$ newxml = XMLin ( $ newxml ) ;
2009-02-15 22:42:22 +00:00
my $ vncport = $ newxml - > { devices } - > { graphics } - > { port } ;
my $ stty = $ newxml - > { devices } - > { console } - > { tty } ;
2009-11-27 18:55:13 +00:00
$ updatetable - > { vm } - > { $ node } = { vncport = > $ vncport , textconsole = > $ stty } ;
#$vmtab->setNodeAttribs($node,{vncport=>$vncport,textconsole=>$stty});
2009-02-15 22:42:22 +00:00
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 ) ;
2009-11-28 00:50:14 +00:00
my $ hyper = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { host } ;
2009-02-15 22:42:22 +00:00
if ( $ type eq "text" ) {
my $ serialspeed ;
2009-11-28 00:50:14 +00:00
if ( $ confdata - > { nodehm } ) {
$ serialspeed = $ confdata - > { nodehm } - > { $ node } - > [ 0 ] - > { serialspeed } ;
2009-02-15 22:42:22 +00:00
}
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-11-28 00:50:14 +00:00
my $ candidates = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { migrationdest } ;
my $ currhyp = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { host } ;
2010-02-15 16:54:06 +00:00
#caching strategy is implicit on whether $addmemory is passed.
2009-02-15 22:42:22 +00:00
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
2010-02-15 16:54:06 +00:00
if ( $ addmemory and defined $ hypstats { $ _ } - > { freememory } ) { #only used cache results when addmemory suggests caching can make sense
2009-12-02 00:37:04 +00:00
$ currentfreememory = $ hypstats { $ _ } - > { freememory }
} else {
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-12-02 00:37:04 +00:00
$ targconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1&netcat=nc" ) ;
2009-02-15 22:42:22 +00:00
} ;
2009-12-02 00:37:04 +00:00
unless ( $ targconn ) {
eval { #Sys::Virt has bugs that cause it to die out in weird ways some times, contain it here
$ targconn = Sys::Virt - > new ( uri = > "qemu+ssh://root@" . $ _ . "/system?no_tty=1" ) ;
} ;
}
unless ( $ targconn ) { next ; } #skip unreachable destinations
$ currentfreememory = $ targconn - > get_node_info ( ) - > { memory } ;
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
$ currentfreememory -= $ _ - > get_info ( ) - > { memory } ;
2009-02-15 22:42:22 +00:00
}
2009-12-02 00:37:04 +00:00
$ hypstats { $ cand } - > { freememory } = $ currentfreememory ;
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" ) ;
}
2010-02-15 16:54:06 +00:00
#TODO: currently, we completely serialize migration events. Some IO fabrics can facilitate concurrent migrations
#One trivial example is an ethernet port aggregation where a single conversation may likely be unable to utilize all the links
#because traffic is balanced by a mac address hashing algorithim, but talking to several hypervisors would have
#distinct peers that can be balanced more effectively.
#The downside is that migration is sufficiently slow that a lot can change in the intervening time on a target hypervisor, but
#this should not be an issue if:
#xCAT is the only path a configuration is using to make changes in the virtualization stack
#xCAT implements a global semaphore mechanism that this plugin can use to assure migration targets do not change by our own hand..
#failing that.. flock.
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-11-28 00:50:14 +00:00
if ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { host } ) {
$ prevhyp = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { host } ;
2009-02-15 22:42:22 +00:00
$ 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." ) ;
}
2010-07-22 13:55:50 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } and $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } =~ /^nfs:/ ) {
my $ urls = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } and $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ;
foreach ( split /,/ , $ urls ) {
s/=.*// ;
get_storage_pool_by_url ( $ _ , $ desthypconn , $ targ ) ;
}
}
2009-02-15 22:42:22 +00:00
my $ sock = IO::Socket::INET - > new ( Proto = > 'udp' ) ;
my $ ipa = inet_aton ( $ node ) ;
2010-02-11 22:13:54 +00:00
my $ pa ;
if ( $ ipa ) {
$ pa = sockaddr_in ( 7 , $ ipa ) ; #UDP echo service, not needed to be actually
}
2009-02-15 22:42:22 +00:00
#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" ) ;
}
2010-02-11 22:13:54 +00:00
if ( $ ipa ) {
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 ) ) {
2010-02-15 16:54:06 +00:00
#$updatetable->{vm}->{$node}->{host} = $targ;
$ vmtab - > setNodeAttribs ( $ node , { host = > $ targ } ) ;
2009-02-15 22:42:22 +00:00
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 ;
2009-11-22 19:41:52 +00:00
my $ rc = 0 ;
2009-10-20 01:02:01 +00:00
my @ nics = ( ) ;
my @ storage = ( ) ;
2009-11-28 00:50:14 +00:00
if ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nics } ) {
@ nics = split /,/ , $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { nics } ;
2009-10-20 01:02:01 +00:00
}
foreach ( @ nics ) {
s/=.*// ; #this code cares not about the model of virtual nic
2009-11-22 19:41:52 +00:00
$ rc |= system ( "ssh $hyp xHRM bridgeprereq $_" ) ;
2009-10-20 01:02:01 +00:00
}
2009-11-22 19:41:52 +00:00
return $ rc ;
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 ;
2010-08-13 12:34:32 +00:00
my $ xml = shift ;
2009-02-15 22:42:22 +00:00
my $ dom ;
2010-08-13 12:34:32 +00:00
if ( not $ xml and $ confdata - > { kvmnodedata } - > { $ node } and $ confdata - > { kvmnodedata } - > { $ node } - > [ 0 ] and $ confdata - > { kvmnodedata } - > { $ node } - > [ 0 ] - > { xml } ) {
2010-08-12 18:55:38 +00:00
$ xml = $ confdata - > { kvmnodedata } - > { $ node } - > [ 0 ] - > { xml } ;
2010-08-13 12:34:32 +00:00
} elsif ( not $ xml ) {
2010-08-12 18:30:41 +00:00
$ 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 {
2010-07-02 20:41:29 +00:00
#svn rev 6638 held the older vintage of createstorage
2009-03-17 00:49:55 +00:00
my $ filename = shift ;
my $ mastername = shift ;
my $ size = shift ;
2009-11-22 19:41:52 +00:00
my $ cfginfo = shift ;
my $ force = shift ;
2010-07-02 20:41:29 +00:00
#my $diskstruct = shift;
2009-11-22 19:41:52 +00:00
my $ node = $ cfginfo - > { node } ;
my @ flags = split /,/ , $ cfginfo - > { virtflags } ;
foreach ( @ flags ) {
if ( /^imageformat=(.*)\z/ ) {
$ imgfmt = $ 1 ;
} elsif ( /^clonemethod=(.*)\z/ ) {
$ clonemethod = $ 1 ;
}
}
my $ mountpath ;
2009-11-30 19:51:33 +00:00
my $ pathappend ;
2009-11-22 19:41:52 +00:00
#for nfs paths and qemu-img, we do the magic locally only for now
2009-11-30 19:51:33 +00:00
my $ basename ;
my $ dirname ;
2010-07-02 20:41:29 +00:00
if ( $ mastername and $ size ) {
return 1 , "Can not specify both a master to clone and size(s)" ;
2009-11-22 19:41:52 +00:00
}
2010-07-02 20:41:29 +00:00
$ filename =~ s/=(.*)// ;
my $ model = $ 1 ;
2010-08-25 15:42:36 +00:00
unless ( $ model ) {
#if not defined, model will stay undefined like above
$ model = $ cfginfo - > { storagemodel } ;
}
2010-07-02 20:41:29 +00:00
my $ prefix = 'hd' ;
if ( $ model eq 'scsi' ) {
$ prefix = 'sd' ;
} elsif ( $ model eq 'virtio' ) {
$ prefix = 'vd' ;
2009-11-22 19:41:52 +00:00
}
2010-07-02 20:41:29 +00:00
my @ suffixes = ( 'a' , 'b' , 'd' .. 'z' ) ;
if ( $ filename =~ /^nfs:/ ) { #libvirt storage pool to be used for this
my @ sizes = split /,/ , $ size ;
foreach ( @ sizes ) {
get_filepath_by_url ( url = > $ filename , dev = > $ prefix . shift ( @ suffixes ) , create = > $ _ ) ;
}
2009-03-17 00:49:55 +00:00
}
2009-11-22 19:41:52 +00:00
my $ masterserver ;
2010-07-02 20:41:29 +00:00
if ( $ mastername ) { #cloning
2009-03-17 00:49:55 +00:00
}
2010-07-02 20:41:29 +00:00
if ( $ size ) { #new volume
2009-03-17 00:49:55 +00:00
}
}
2009-02-15 22:42:22 +00:00
2010-07-06 20:52:24 +00:00
sub chvm {
shift ;
my @ addsizes ;
my % resize ;
my $ cpucount ;
my @ purge ;
my @ derefdisks ;
my $ memory ;
@ ARGV = @ _ ;
require Getopt::Long ;
2010-07-21 15:23:37 +00:00
GetOptions (
2010-07-06 20:52:24 +00:00
"a=s" = > \ @ addsizes ,
"d=s" = > \ @ derefdisks ,
"mem=s" = > \ $ memory ,
"p=s" = > \ @ purge ,
"resize=s%" = > \ % resize ,
"cpu=s" = > \ $ cpucount ,
) ;
my % useddisks ;
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ) {
my $ store ;
foreach $ store ( split /\|/ , $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ) {
$ store =~ s/,.*// ;
$ store =~ s/=.*// ;
if ( $ store =~ /^nfs:\/\// ) {
my % disks = % { get_multiple_paths_by_url ( url = > $ store , node = > $ node ) } ;
foreach ( keys % disks ) {
2010-07-30 19:12:45 +00:00
$ useddisks { $ disks { $ _ } - > { device } } = 1 ;
2010-07-06 20:52:24 +00:00
}
}
}
}
if ( @ addsizes ) { #need to add disks, first identify used devnames
my @ diskstoadd ;
my $ location = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ;
$ location =~ s/.*\|// ; #use the rightmost location for making new devices
$ location =~ s/,.*// ; #no comma specified parameters are valid
$ location =~ s/=(.*)// ; #store model if specified here
my $ model = $ 1 ;
2010-08-25 15:42:36 +00:00
unless ( $ model ) {
#if not defined, model will stay undefined like above
$ model = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storagemodel }
}
2010-07-06 20:52:24 +00:00
my $ prefix = 'hd' ;
if ( $ model eq 'scsi' ) {
$ prefix = 'sd' ;
} elsif ( $ model eq 'virtio' ) {
$ prefix = 'vd' ;
}
my @ suffixes ;
if ( $ prefix eq 'hd' ) {
@ suffixes = ( 'a' , 'b' , 'd' .. 'z' ) ;
} else {
@ suffixes = ( 'a' .. 'z' ) ;
}
my @ newsizes ;
foreach ( @ addsizes ) {
push @ newsizes , split /,/ , $ _ ;
}
foreach ( @ newsizes ) {
my $ dev ;
do {
$ dev = $ prefix . shift ( @ suffixes ) ;
} while ( $ useddisks { $ dev } ) ;
#ok, now I need a volume created to attach
push @ diskstoadd , get_filepath_by_url ( url = > $ location , dev = > $ dev , create = > $ _ ) ;
}
#now that the volumes are made, must build xml for each and attempt attach if and only if the VM is live
my $ dom = $ hypconn - > get_domain_by_name ( $ node ) ;
my $ currstate = getpowstate ( $ dom ) ;
if ( $ currstate eq 'on' ) { #attempt live attach
2010-07-21 15:23:37 +00:00
foreach ( @ diskstoadd ) {
2010-07-30 19:12:45 +00:00
my $ suffix ;
my $ format ;
if ( /^[^\.]*\.([^\.]*)\.([^\.]*)/ ) {
$ suffix = $ 1 ;
$ format = $ 2 ;
} elsif ( /^[^\.]*\.([^\.]*)/ ) {
$ suffix = $ 1 ;
$ format = 'raw' ;
}
2010-07-21 15:23:37 +00:00
my $ bus ;
if ( $ suffix =~ /^sd/ ) {
$ bus = 'scsi' ;
} elsif ( $ suffix =~ /^hd/ ) {
sendmsg ( "Reboot required to add IDE drives" , $ node ) ;
next ;
} elsif ( $ suffix =~ /vd/ ) {
$ bus = 'virtio' ;
}
2010-07-30 19:12:45 +00:00
my $ xml = "<disk type='file' device='disk'><driver name='qemu' type='$format'/><source file='$_'/><target dev='$suffix' bus='$bus'/></disk>" ;
2010-07-21 15:23:37 +00:00
$ dom - > attach_device ( $ xml ) ;
}
2010-08-13 12:26:17 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
2010-08-12 18:30:41 +00:00
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
} else { #TODO: chvm to modify offline xml structure
2010-07-06 20:52:24 +00:00
}
2010-07-21 20:33:50 +00:00
} elsif ( @ purge ) {
my $ dom = $ hypconn - > get_domain_by_name ( $ node ) ;
my $ vmxml = $ dom - > get_xml_description ( ) ;
my $ currstate = getpowstate ( $ dom ) ;
foreach ( get_disks_by_userspecs ( \ @ purge , $ vmxml ) ) {
my $ devxml = $ _ - > [ 0 ] ;
my $ file = $ _ - > [ 1 ] ;
$ file =~ m !/([^/]*)/($node\..*)\z! ;
my $ pooluuid = $ 1 ;
my $ volname = $ 2 ;
#first, detach the device.
eval {
2010-08-12 18:30:41 +00:00
if ( $ currstate eq 'on' ) {
$ dom - > detach_device ( $ devxml ) ;
2010-08-13 12:26:17 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
2010-08-12 18:30:41 +00:00
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
} else {
#TODO: manipulate offline xml data
}
2010-07-21 20:33:50 +00:00
} ;
if ( $@ ) {
sendmsg ( [ 1 , "Unable to remove device" ] , $ node ) ;
} else {
#if that worked, remove the disk..
my $ pool = $ hypconn - > get_storage_pool_by_uuid ( $ pooluuid ) ;
if ( $ pool ) {
2010-07-30 12:48:47 +00:00
$ pool - > refresh ( ) ; #Amazingly, libvirt maintains a cached view of the volume rather than scan on demand
2010-07-21 20:33:50 +00:00
my $ vol = $ pool - > get_volume_by_name ( $ volname ) ;
if ( $ vol ) {
$ vol - > delete ( ) ;
}
}
}
}
}
}
sub get_disks_by_userspecs {
my $ specs = shift ;
my $ xml = shift ;
2010-08-25 19:04:52 +00:00
my $ struct = XMLin ( $ xml , forcearray = > 1 ) ;
2010-07-21 20:33:50 +00:00
my @ returnxmls ;
foreach my $ spec ( @$ specs ) {
2010-08-25 19:04:52 +00:00
foreach ( @ { $ struct - > { devices } - > [ 0 ] - > { disk } } ) {
2010-07-21 20:33:50 +00:00
if ( $ spec =~ /^.d./ ) { #vda, hdb, sdc, etc, match be equality to target->{dev}
2010-08-25 19:04:52 +00:00
if ( $ _ - > { target } - > [ 0 ] - > { dev } eq $ spec ) {
push @ returnxmls , [ XMLout ( $ _ , RootName = > 'disk' ) , $ _ - > { source } - > [ 0 ] - > { file } ] ;
2010-07-21 20:33:50 +00:00
}
} elsif ( $ spec =~ /^d(.*)/ ) { #delete by scsi unit number..
if ( $ _ - > { address } - > { unit } == $ 1 ) {
push @ returnxmls , [ XMLout ( $ _ , RootName = > "disk" ) , $ _ - > { source } - > { file } ] ;
}
} #other formats TBD
}
2010-07-06 20:52:24 +00:00
}
2010-07-21 20:33:50 +00:00
return @ returnxmls ;
2010-07-06 20:52:24 +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-11-28 00:50:14 +00:00
if ( defined $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ) {
my $ diskname = $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { storage } ;
2009-03-17 00:49:55 +00:00
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
}
2009-11-22 19:41:52 +00:00
if ( $ mastername or $ disksize ) {
2010-07-02 20:41:29 +00:00
return createstorage ( $ diskname , $ mastername , $ disksize , $ confdata - > { vm } - > { $ node } - > [ 0 ] , $ force ) ;
2009-03-17 00:49:55 +00:00
}
} 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 ) {
2009-11-22 19:41:52 +00:00
if ( xhrm_satisfy ( $ node , $ hyp ) ) {
return ( 1 , "Failure satisfying networking and storage requirements on $hyp for $node" ) ;
}
2009-10-20 01:02:01 +00:00
}
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 ) {
2010-08-13 12:34:32 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
2009-02-15 22:42:22 +00:00
$ 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 ) {
2010-08-13 12:34:32 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
2009-02-15 22:42:22 +00:00
$ 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 ) {
2010-08-13 12:34:32 +00:00
my $ newxml = $ dom - > get_xml_description ( ) ;
$ updatetable - > { kvm_nodedata } - > { $ node } = { xml = > $ newxml } ;
2009-02-15 22:42:22 +00:00
$ 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 ) ;
}
2010-08-13 12:34:32 +00:00
( $ dom , $ errstr ) = makedom ( $ node , $ cdloc , $ newxml ) ;
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 ) ;
}
2010-08-13 13:23:19 +00:00
sub lsvm {
my $ node = shift ;
my @ doms = $ hypconn - > list_domains ( ) ;
my @ vms ;
foreach ( @ doms ) {
push @ vms , $ _ - > get_name ( ) ;
}
return ( 0 , @ vms ) ;
}
2009-02-15 22:42:22 +00:00
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 ) ;
2010-07-21 15:23:37 +00:00
} elsif ( $ command eq "chvm" ) {
return chvm ( $ 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 ) ;
2010-08-13 13:23:19 +00:00
} elsif ( $ command eq "lsvm" ) {
return lsvm ( $ 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 % addmemory = ( ) ;
my $ node ;
my $ target ;
2009-11-27 18:55:13 +00:00
my $ vmupdates ;
2009-03-18 20:00:51 +00:00
foreach $ node ( keys % { $ orphash } ) {
$ target = pick_target ( $ node , \ % addmemory ) ;
unless ( $ target ) {
next ;
}
2009-11-28 00:50:14 +00:00
if ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { memory } ) {
$ addmemory { $ target } += getUnits ( $ confdata - > { vm } - > { $ node } - > [ 0 ] - > { memory } , "M" , 1024 ) ;
2009-10-20 04:30:08 +00:00
} else {
$ addmemory { $ target } += getUnits ( "512" , "M" , 1024 ) ;
}
2009-03-18 20:00:51 +00:00
$ hyphash { $ target } - > { nodes } - > { $ node } = 1 ;
delete $ orphash - > { $ node } ;
2009-11-27 18:55:13 +00:00
$ vmupdates - > { $ node } - > { host } = $ target ;
2009-03-18 20:00:51 +00:00
}
2009-11-27 18:55:13 +00:00
$ vmtab - > setNodesAttribs ( $ vmupdates ) ;
2009-03-18 20:00:51 +00:00
if ( keys % { $ orphash } ) {
return 0 ;
} else {
return 1 ;
}
2009-02-15 22:42:22 +00:00
}
2009-03-18 20:00:51 +00:00
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 = ( ) ;
2009-12-02 00:37:04 +00:00
% hypstats = ( ) ;
2009-10-19 22:47:48 +00:00
% offlinevms = ( ) ;
2009-02-15 22:42:22 +00:00
my $ request = shift ;
my $ callback = shift ;
2009-11-28 00:50:14 +00:00
unless ( $ libvirtsupport ) {
$ libvirtsupport = eval {
2009-04-09 14:10:38 +00:00
require Sys::Virt ;
if ( Sys::Virt - > VERSION < "0.2.0" ) {
die ;
}
1 ;
2009-11-28 00:50:14 +00:00
} ;
}
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' ) {
unless ( $ vmtab ) { $ vmtab = new xCAT:: Table ( 'vm' , - create = > 1 ) ; }
my $ state = $ exargs [ 0 ] ;
if ( $ state eq 'vmoff' ) {
$ vmtab - > setNodeAttribs ( $ exargs [ 1 ] , { powerstate = > 'off' } ) ;
return ;
} elsif ( $ state eq 'vmon' ) {
$ vmtab - > setNodeAttribs ( $ exargs [ 1 ] , { powerstate = > 'on' } ) ;
return ;
} elsif ( $ state eq 'hypshutdown' ) { #turn this into an evacuate
2009-11-17 18:41:42 +00:00
my $ nodelisttab = xCAT::Table - > new ( 'nodelist' ) ;
my $ appstatus = $ nodelisttab - > getNodeAttribs ( $ noderange - > [ 0 ] , [ 'appstatus' ] ) ;
my @ apps = split /,/ , $ appstatus - > { 'appstatus' } ;
my @ newapps ;
foreach ( @ apps ) {
if ( $ _ eq 'virtualization' ) { next ; }
push @ newapps , $ _ ;
}
$ nodelisttab - > setNodeAttribs ( $ noderange - > [ 0 ] , { appstatus = > join ( ',' , @ newapps ) } ) ;
2009-10-20 01:45:04 +00:00
$ command = "revacuate" ;
@ exargs = ( ) ;
} elsif ( $ state eq 'hypstartup' ) { #if starting up, check for nodes on this hypervisor and start them up
2009-11-17 18:41:42 +00:00
my $ nodelisttab = xCAT::Table - > new ( 'nodelist' ) ;
my $ appstatus = $ nodelisttab - > getNodeAttribs ( $ noderange - > [ 0 ] , [ 'appstatus' ] ) ;
my @ apps = split /,/ , $ appstatus - > { appstatus } ;
unless ( grep { $ _ eq 'virtualization' } @ apps ) {
push @ apps , 'virtualization' ;
$ nodelisttab - > setNodeAttribs ( $ noderange - > [ 0 ] , { appstatus = > join ( ',' , @ apps ) } ) ;
}
2009-10-20 01:45:04 +00:00
my @ tents = $ vmtab - > getAttribs ( { host = > $ noderange - > [ 0 ] , power = > 'on' } , [ 'node' ] ) ;
$ noderange = [] ;
foreach ( @ tents ) {
push @$ noderange , noderange ( $ _ - > { node } ) ;
}
$ 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-11-28 00:50:14 +00:00
$ vmtab = xCAT::Table - > new ( "vm" ) ;
$ confdata = { } ;
xCAT::VMCommon:: grab_table_data ( $ noderange , $ confdata , $ callback ) ;
2010-08-12 18:30:41 +00:00
$ kvmdatatab = xCAT::Table - > new ( "kvm_nodedata" , - create = > 0 ) ; #grab any pertinent pre-existing xml
if ( $ kvmdatatab ) {
$ confdata - > { kvmnodedata } = $ kvmdatatab - > getNodesAttribs ( $ noderange , [ qw/xml/ ] ) ;
} else {
2010-08-12 18:34:06 +00:00
$ confdata - > { kvmnodedata } = { } ;
2010-08-12 18:30:41 +00:00
}
2009-11-28 00:50:14 +00:00
if ( $ command eq 'mkvm' or $ command eq 'rpower' and ( grep { "$_" eq "on" or $ _ eq "boot" or $ _ eq "reset" } @ exargs ) ) {
xCAT::VMCommon:: requestMacAddresses ( $ confdata , $ noderange ) ;
2009-11-30 18:37:01 +00:00
my @ dhcpnodes ;
2009-11-30 18:54:39 +00:00
foreach ( keys % { $ confdata - > { dhcpneeded } } ) {
2009-11-30 18:37:01 +00:00
push @ dhcpnodes , $ _ ;
2009-11-30 18:54:39 +00:00
delete $ confdata - > { dhcpneeded } - > { $ _ } ;
2009-11-30 18:37:01 +00:00
}
2009-11-30 18:54:39 +00:00
$ doreq - > ( { command = > [ 'makedhcp' ] , node = > \ @ dhcpnodes } ) ;
2009-11-28 00:50:14 +00:00
}
2009-02-15 22:42:22 +00:00
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 = ( ) ;
2010-08-13 13:23:19 +00:00
if ( $ command eq 'lsvm' ) { #command intended for hypervisors, not guests
foreach ( @$ noderange ) { $ hyphash { $ _ } - > { nodes } - > { $ _ } = 1 ; }
} else {
foreach ( keys % { $ confdata - > { vm } } ) {
if ( $ confdata - > { vm } - > { $ _ } - > [ 0 ] - > { host } ) {
$ hyphash { $ confdata - > { vm } - > { $ _ } - > [ 0 ] - > { host } } - > { nodes } - > { $ _ } = 1 ;
} else {
$ orphans { $ _ } = 1 ;
}
2009-02-15 22:42:22 +00:00
}
}
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 ;
}
2010-07-19 17:50:38 +00:00
} elsif ( $ command eq "mkvm" ) { #must adopt to create
unless ( adopt ( \ % orphans , \ % hyphash ) ) {
$ callback - > ( { error = > "Can't find " . join ( "," , keys % orphans ) , errorcode = > [ 1 ] } ) ;
return 1 ;
}
#mkvm used to be able to happen devoid of any hypervisor, make a fake hypervisor entry to allow this to occur
#commenting that out for now
# 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 ;
2009-11-23 22:30:09 +00:00
$ output { node } - > [ 0 ] - > { error } = $ text unless $ rc == 0 ;
2009-02-15 22:42:22 +00:00
print $ out freeze ( [ \ % output ] ) ;
print $ out "\nENDOFFREEZE6sK4ci\n" ;
yield ( ) ;
waitforack ( $ out ) ;
}
yield ( ) ;
}
2009-11-27 18:55:13 +00:00
foreach ( keys %$ updatetable ) {
my $ tabhandle = xCAT::Table - > new ( $ _ , - create = > 1 ) ;
$ tabhandle - > setNodesAttribs ( $ updatetable - > { $ _ } ) ;
}
2009-02-15 22:42:22 +00:00
#my $msgtoparent=freeze(\@outhashes); # = XMLout(\%output,RootName => 'xcatresponse');
#print $out $msgtoparent; #$node.": $_\n";
}
1 ;