Subversion Repositories havirt

#!/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

#

# v1.2.1 20240828 RWR

# force rescan after domain migrate (pulled out of havirt.pm:scan)

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.1");

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";

   push @return, "domain pin domainname node [node]";

   push @return, "\tPin a domain to one or more nodes. Restricts a node to only run on specific node(s)";

   return join( "\n", @return ) . "\n";

}

# dipslay a list of domains, which node they are on and some information on them

sub list {

   &main::readDB();

   #@_ = keys %{$main::statusDB->{'nodes'} } unless ( @_ );

   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'}} ) {

   #while ( my $node = shift ) {

      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'}->{'force'}\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;

   }

   my $return = &main::migrate( $domain, $target );

   &main::forceScan();

   return $return;

}

# 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";

}

sub pin {

   my $domain = shift;

   &main::readDB(1);

   while ( my $node = shift ) {

      $main::statusDB->{'virt'}->{$domain}->{'pin'}->{$node} = 1;

   }

   &main::writeDB();

   return "domain pin functionality not yet implemented\n";

}