Rev 35 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
#!/usr/bin/env perl
# All functions related to maniplating domains
# part of havirt.
# Copyright 2024 Daily Data, Inc.
#
# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
# conditions are met:
#
# Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
# Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer
# in the documentation and/or other materials provided with the distribution.
# Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT
# NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
# THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# v0.0.1 20240602 RWR
# Initial setup
#
# v1.2.0 20240826 RWR
# Added some code to migrate domains if node placed in maintenance mode
# Added a lot of 'verbose' print lines, and modified for new flag structure
#
package domain;
use warnings;
use strict;
# define the version number
# see https://metacpan.org/pod/release/JPEACOCK/version-0.97/lib/version.pod
use version;
our $VERSION = version->declare("1.2.0");
use Data::Dumper;
use Exporter;
our @ISA = qw( Exporter );
our @EXPORT = qw(
&list
);
sub help {
my @return;
push @return, "domain update [domainname|-t domainname]";
push @return, "\tUpdates capabilities on one or more domains, default is all domains";
push @return, "domain list [--format|-f screen|tsv]";
push @return, "\tLists all domains with some statistics about them as screen or tsv (default screen)";
push @return, "domain start domainname [node]";
push @return, "\tstarts domainname on node. If node not set, will pick a node.";
push @return, "domain shutdown domainname";
push @return, "\tInitiates a shutdown on a running domain and puts it in to manual mode";
push @return, "domain migrate domainname [node]";
push @return, "\tmigrates domain from current node to target. If target node not specified";
push @return, "\twill be automatically selected";
push @return, "domain new [domainname]";
push @return, "\tgenerates a virt-install command that will fill in several blanks";
push @return, "\tNOTE: MAC address not guaranteed to be unique";
push @return, "domain migrate domainname targetnode";
push @return, "\tMigates a domain from its current location to targetnode";
push @return, "domain maintenance domainname [on|off]";
push @return, "\tSet/Unset/display maintenance flag on domain";
push @return, "\tIf maintenance flag is set, no havirt will refuse any actions";
return join( "\n", @return ) . "\n";
}
# dipslay a list of domains, which node they are on and some information on them
sub list {
&main::readDB();
print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::config->{'flags'}->{'debug'} > 2;
my @header;
my @data;
my @found;
foreach my $node ( sort keys %{$main::statusDB->{'nodePopulation'}} ) {
foreach my $virt (sort keys %{$main::statusDB->{'nodePopulation'}->{$node}->{'running'}} ) {
unless ( @header ) {
# if we don't have a header yet, create it from the keys in this one. Assumes every entry has same keys
@header = sort keys %{ $main::statusDB->{'virt'}->{$virt} };
unshift @header, 'Domain';
unshift @header, 'Node';
} # unless
push @found, $virt;
my @line;
push @line, $node;
push @line, $virt;
foreach my $column ( sort keys %{ $main::statusDB->{'virt'}->{$virt} } ) {
push @line, $main::statusDB->{'virt'}->{$virt}->{$column};
}
push @data, \@line;
}
}
my @allDomains = keys %{$main::statusDB->{'virt'} };
my $notRunning = &main::diffArray( \@allDomains, \@found );
my @padding;
while ( @padding < @header - 2 ) {
push @padding, '';
}
for ( my $i = 0; $i < @$notRunning; $i++ ) {
my @line;
push @line, 'Down';
push @line, $notRunning->[$i];
push @line, @padding;
push @data, \@line;
}
return &main::report( \@header, \@data );
}
# reread the domain definition file and freshen the database
sub update {
my @requiredFields = ( 'maintenance' );
&main::readDB(1); # loading it for write, so lock
unless ( @_ ) {
# they didn't pass in anything, so do everything
@_ = keys %{ $main::statusDB->{'virt'} }
} # unless
print "Preparing to update " . join( "\n", @_ ) . "\n"
if $main::config->{'flags'}->{'debug'} > 1 or $main::config->{'flags'}->{'verbose'};
while ( my $virt = shift ) { # for every domain they passed in
&parseDomain( $virt ); # parse it and update definition
foreach my $field ( @requiredFields ) { # make sure the required fields are in there
$main::statusDB->{'virt'}->{$virt}->{$field} = ''
unless defined ( $main::statusDB->{'virt'}->{$virt}->{$field} );
} # foreach
} # while
&main::writeDB( $main::domainDBName, $main::statusDB->{'virt'} );
return "Domain(s) updated\n";
}
# finds one xml value in file.
# since libvirt does not use good xml which can be parsed by
# several libraries, we must do it manually with regex's
sub getXMLValue {
my ( $key, $string ) = @_;
print "getXMLValue: looking for [$key] $string\n" if $main::config->{'flags'}->{'debug'} > 2;
my $start = "<$key";
my $end = "</$key>";
$string =~ m/$start([^>]*)>([^<]+)$end/;
return ($1,$2);
}
# parse an xml file to find the values we want to save
# if config file exists in conf, just read it. If it does not
# exist, or if force is set, do a dumpxml on the running
# domain, put it into conf/ and load it.
sub parseDomain {
my ($virt, $nodePopulations ) = @_;
print "Parsing domain $virt in domain.pm:parseDomain\n" if $main::config->{'flags'}->{'debug'};
print "\tParsing domain $virt\n" if $main::config->{'flags'}->{'verbose'};
my @keysToSave = ( 'uuid', 'memory', 'vcpu','vnc' );
my $filename = "$main::config->{'conf dir'}/$virt.xml";
my $xml = &getVirtConfig( $virt, $filename );
my ($param,$value) = &getXMLValue( 'uuid', $xml );
$main::statusDB->{'virt'}->{$virt}->{'uuid'} = $value;
($param,$value) = &getXMLValue( 'memory', $xml );
$main::statusDB->{'virt'}->{$virt}->{'memory'} = $value;
($param,$value) = &getXMLValue( 'vcpu', $xml );
$main::statusDB->{'virt'}->{$virt}->{'vcpu'} = $value;
$xml =~ m/type='vnc' port='(\d+)'/;
$main::statusDB->{'virt'}->{$virt}->{'vnc'} = $1;
print "After Parsing $virt in domain.pm:parseDomain\n" . Dumper($main::statusDB->{'virt'}->{$virt}) . "\n" if $main::config->{'flags'}->{'debug'} > 2;
}
# returns xml definition of a domain
# if the definition exists in conf/, simply open and read
# if the definition file does not exist, or if $force is set, find the
# running domain, perform an xml dump of it, save it to conf/, then
# return it.
sub getVirtConfig {
my ($virt,$filename) = @_;
my $return;
print "In getVirtConfig looking for $virt with file $filename, force is $main::config->{'flags'}->{'yes'}\n" if $main::config->{'flags'}->{'debug'};
if ( -f $filename && ! $main::config->{'flags'}->{'force'}) {
open XML, "<$filename" or die "Could not read from $filename: $!\n";
$return = join( '', <XML> );
close XML;
} else {
&main::readDB();
foreach my $node ( keys %{$main::statusDB->{'nodePopulation'}} ) {
print "getVirtConfig Looking on $node for $virt\n" if $main::config->{'flags'}->{'debug'} > 1;;
if ( exists( $main::statusDB->{'nodePopulation'}->{$node}->{'running'}->{$virt} ) ) { # we found it
print "Getting copy of XML file for $virt from $node\n" if $main::config->{'flags'}->{'verbose'};
print "Found $virt on node $node\n" if $main::config->{'flags'}->{'debug'};;
my $command = &main::makeCommand($node, "virsh dumpxml $virt");
$return = `$command`;
print "Writing config for $virt from $node into $filename\n" if $main::config->{'flags'}->{'debug'};
open XML,">$filename" or die "Could not write to $filename: $!\n";
print XML $return;
close XML;
} # if
} # foreach
} # if..else
return $return;
} # sub getVirtConfig
# start a domain
sub start {
my ( $virt, $node ) = @_;
my $return;
$node = `hostname` unless $node;
chomp $node;
return "Domain $virt in maintenance mode, can not start\n" if $main::statusDB->{'virt'}->{$virt}->{'maintenance'};
return "Node $node in maintenance mode, can not start\n" if $main::statusDB->{'node'}->{$node}->{'maintenance'};
if ( my $foundNode = &main::findDomain( $virt ) ) {
die "$virt already running on $foundNode, not starting\n";
}
die "I do not have a definition for $virt\n" unless exists( $main::statusDB->{'virt'}->{$virt} );
print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::config->{'flags'}->{'debug'} > 2;
if ( my $error = &main::validateResources( $node, $virt ) ) {
die $error;
}
my $filename = "$main::config->{'conf dir'}/$virt.xml";
my $command = &main::makeCommand( $node, "virsh create $filename" );
print "Starting $virt on $node\n" if $main::config->{'flags'}->{'verbose'};
if ( $main::config->{'flags'}->{'dryrun'} ) { # we'll actually do it
$return = $command;;
} else {
$return = ( &main::executeAndWait( $command, $node, $virt, 1 ) ? 'Success' : 'Can not start');
&main::forceScan();
}
return "$return\n";
}
sub shutdown {
my $virt = shift;
my $node = '';
my $return;
$node = &main::findDomain( $virt );
die "I could not find the domain $virt running\n" unless $node;
print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::config->{'flags'}->{'debug'} > 2;
die "I can not find $virt on any node\n" unless $node;
my $command = &main::makeCommand( $node, "virsh shutdown $virt" );
print "Attempting to shut down $virt currently on $node\n" if $main::config->{'flags'}->{'verbose'};
if ( $main::config->{'flags'}->{'dryrun'} ) { # they want us to actually do it
$return = $command;
} else {
$return = ( &main::executeAndWait( $command, $node, $virt, 0 ) ? 'Success' : 'Time Out waiting for shutdown');
&main::forceScan();
}
return "$return\n";
}
# Migrate a single domain
# this is defined in havirt.pm, which is set up to migrate multiple domains
# but has an entry point here for just one
# domain is domain to migrate, target is where to put it
sub migrate {
my ( $domain, $target ) = @_;
if ( my $error = &main::validateResources( $target, $domain ) ) {
die $error;
}
return &main::migrate( $domain, $target );
}
# find an unused VNC port
sub findVNCPort {
my $currentPorts = shift;
my $return = 5900;
while ( $currentPorts->{$return} ) {
$return++;
}
return $return;
}
# print MAC address in the correct format
# two character hex digits separated by colons, lower case
sub printMac {
my $mac = shift;
my @return;
my $separator = ':';
for ( my $i = 0; $i < length( $mac ); $i += 2 ) {
push @return, substr( $mac, $i, 2 );
}
return join( $separator, @return );
}
# generate a random MAC address for new function.
# NOTE: this is not checked for duplication at this time
sub makeMac {
my $numDigits = 12; # 12 hex digits in a mac address
my $macBaseXen = '00163e'; # Xen has 00:16:3E* assigned to it.
my $hexDigits = '0123456789abcdef';
my $baseMac = $macBaseXen;
while (length( $baseMac ) < $numDigits ) {
$baseMac .= substr($hexDigits, int(rand(length($hexDigits))),1 );
}
return &printMac( $baseMac );
}
# generate a virt-install statement, verifying things are not already being used
sub new {
my %config;
$config{'name'} = shift;
my $return;
my $template = $main::config->{'script dir'} . '/virt-install.template';
&main::readDB();
my %current;
foreach my $virt ( keys %{$main::statusDB->{'virt'} } ) {
$current{'vnc'}{$main::statusDB->{'virt'}->{$virt}->{'vnc'}} = 1;
#$current{'mac'}{'null'} = 1;
}
$config{'vnc'} = &findVNCPort( \%{$current{'vnc'}} );
$config{'mac'} = &makeMac();
$config{'uuid'} = `uuidgen`;
chomp $config{'uuid'};
if ( open TEMPLATE, "<$template" ) {
$return = join( '', <TEMPLATE> );
close TEMPLATE;
foreach my $key ( keys %config ) {
$return =~ s/<$key>/$config{$key}/gi if $config{$key};
}
} else {
$return = "Template $template not found, the following values should be used\n";
foreach my $key ( keys %config ) {
$return .= "$key: $config{$key}\n";
}
}
return $return;
}
# put domain in maintenance mode
# in maintenance mode, it can not be started, stopped or migrated by havirt
sub maintenance {
my ( $domain, $action ) = @_;
&main::readDB(1);
if ( $action ) {
$main::statusDB->{'virt'}->{$domain}->{'maintenance'} = ( lc( $action ) eq 'on' ) ? 1 : 0;
}
&main::writeDB();
return "Maintenance set to " . ( $main::statusDB->{'virt'}->{$domain}->{'maintenance'} ? 'On' : 'Off' ) . "\n";
}