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

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("0.0.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";
   return join( "\n", @return ) . "\n";
}


# find node a domain is on
# first parameter is the domain name
# rest of @_ is list of nodes to search
# if no nodes passed in, will search all known nodes
# returns first node found with the domain, or an empty string if not found
sub findDomain {
   my $domainName = shift;
   my @node = @_;
   my $foundNode = '';
   unless ( @node ) {
      @node = keys %{$main::statusDB->{'node'} };
   }
   foreach my $thisNode ( @node ) {
      my $output = `ssh $thisNode 'virsh list'`;
      return $thisNode if ( $output =~ m/domainName/ );
   }
   return '';
}

sub list {
   &main::readDB();
   print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::DEBUG > 2;

   my @header;
   my @data;
   
   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
         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;
      }
   }
   
   return &main::report( \@header, \@data );
}

sub update {
   &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::DEBUG > 1;
   while ( my $virt = shift ) {
      &parseDomain( $virt );
   } # while
   &main::writeDB( $main::domainDBName, $main::statusDB->{'virt'} );
   return "Updated\n";
}

sub getXMLValue {
   my ( $key, $string ) = @_;
   print "getXMLValue: looking for [$key] $string\n" if $main::DEBUG > 2;
   my $start = "<$key";
   my $end = "</$key>";
   $string =~ m/$start([^>]*)>([^<]+)$end/;
   return ($1,$2);
}

sub parseDomain {
   my ($virt, $nodePopulations ) = @_;

   my @keysToSave = ( 'uuid', 'memory', 'vcpu','vnc' );
   my $filename = "$main::confDir/$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;
}

# get the XML definition file of a running domain off of whatever
# node it is running on, and save it to disk
sub getVirtConfig {
   my ($virt,$filename) = @_;
   my $return;
   print "In getVirtConfig looking for $virt with file $filename\n" if $main::DEBUG;
   if ( -f $filename ) {
      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::DEBUG > 1;;
         if ( exists( $main::statusDB->{'nodePopulation'}->{$node}->{'running'}->{$virt} ) ) { # we found it
            print "Found $virt on node $node\n" if $main::DEBUG;;
            $return = `ssh $node 'virsh dumpxml $virt'`;
            print "Writing config for $virt from $node into $filename\n" if $main::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 ) = @_;
   $node = `hostname` unless $node;
   chomp $node;
   if ( my $alreadyRunning = &findDomain( $node ) ) {
      die "$virt already running on $alreadyRunning; not starting\n";
   }
   &main::readDB();
   for my $myNode ( keys %{$main::statusDB->{'nodePopulation'} } ) {
      die "$virt already running on $myNode, not starting\n" if ( $main::statusDB->{'nodePopulation'}->{$myNode}->{'running'}->{$virt} );
   }
   die "I do not have a definition for $virt\n" unless exists( $main::statusDB->{'virt'}->{$virt} );
   print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::DEBUG > 2;
   my $filename = "$main::confDir/$virt.xml";
   return "ssh $node 'virsh create $filename'\n";
}

sub shutdown {
   my $virt = shift;
   my $node = '';
   &main::readDB();
   for my $myNode ( keys %{$main::statusDB->{'nodePopulation'} } ) {
      if ( $main::statusDB->{'nodePopulation'}->{$myNode}->{'running'}->{$virt} ) {
         $node = $myNode;
         last;
      }
   }
   print Dumper( $main::statusDB->{'nodePopulation'} ) if $main::DEBUG > 2;
   die "I can not find $virt on any node\n" unless $node;
   return "ssh $node 'virsh shutdown $virt'\n";
}

sub migrate {
   my ( $virt, $target ) = @_;
   return "I don't know how to migrate yet\n";
}

# find an unused VNC port
sub findVNCPort {
   my $currentPorts = shift;
   my $return = 5900;
   while ( $currentPorts->{$return} ) {
      $return++;
   }
   return $return;
}


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 );
}
      
      
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::scriptDir . '/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;
}