Rev 8 | Rev 10 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
#! /usr/bin/env perl
use strict;
use warnings;
# havirt
# Basically an extension of virsh which will perform actions on virtuals
# running on multiple, connected hypervisors (virsh calls them nodes)
# existing as a cluster of hypervisors where virtuals can be shut down,
# started and migrated at need.
#
# Progam consists of one executable (havirt) and multiple Perl Modules
# (*.pm), each of which encompasses a function. However, this is NOT
# written as an Object Oriented system.
#
# havirt --help gives a brief help screen.
# 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.
#use experimental "switch";
# requires File::Slurp.
# In Debian derivatives
# apt install libfile-slurp-perl
# apt install libxml-libxml-perl libyaml-tiny-perl
BEGIN {
use FindBin;
use File::Spec;
# use libraries from the directory this script is in
use Cwd 'abs_path';
use File::Basename;
use lib dirname( abs_path( __FILE__ ) );
}
use havirt; # Load all our shared stuff
use Data::Dumper;
use YAML::Tiny;
# 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");
# see https://perldoc.perl.org/Getopt/Long.html
use Getopt::Long;
# allow -vvn (ie, --verbose --verbose --dryrun)
Getopt::Long::Configure ("bundling");
# global variables
my $scriptDir = $FindBin::RealBin;
my $scriptName = $FindBin::Script;
my $dbDir = "$scriptDir/var";
our $confDir = "$scriptDir/conf";
our $nodeDBName = "$dbDir/node.yaml";
our $domainDBName = "$dbDir/domains.yaml";
our $nodePopulationDBName = "$dbDir/node_population.yaml";
# these contain the values from the databases
# loaded on demand
our $nodeDB;
our $virtDB;
our $nodePopulations;
# options variables
our $reportFormat = 'screen';
our $targetNode = '';
our $dryRun = 1;
our $DEBUG = 0;
my $help = 0;
my $version = 0;
sub help {
print "$0 command [argument]\n";
print "where command is one of\n";
print "\tnode update|list|scan # work with a node\n";
print "\tdomain update|list # work with individual domains\n";
print "\tcluster status # report of memory and vcpu status on all nodes\n";
print "For additional help, run command help\n";
print "\tnode help # or domain, or cluster\n";
print "Some flags can be used where appropriate\n";
print "\t--help|-h # show this screen\n";
print "\t--version|-v # show version of program\n";
print "\t--format|-f screen|tsv # output of list commands is either padded for screen or Tab Delim\n";
print "\t--target|-t NODE # the action use NODE for the target of actions\n";
print "\t--dryrun|-n # does not perform the actions, simply shows what commands would be executed\n";
print "\t--debug|d # increases verbosity, with -ddd, totally outragious\n";
}
sub loadVirtDB {
return if $virtDB;
$virtDB = &readDB( $domainDBName );
}
sub domain {
my $action = lc shift;
my $return = '';
&loadVirtDB();
&loadNodePopulations();
@_ = keys( %$virtDB ) if ( $_[0] && $_[0] eq 'ALL' );
if ( $_[0] && $_[0] eq 'RUNNING' ) {
my @running;
foreach my $node ( keys %$nodePopulations ) {
push @running, keys %{ $nodePopulations->{$node}->{'running'} };
}
@_ = @running;
}
if ( $action eq 'update' ) { # download xml to var and update database
while ( my $virt = shift ) {
&parseDomain( $virt );
} # while
&writeDB( $domainDBName, $virtDB );
} elsif ( $action eq 'list' ) { # dump domain as a tab separated data file
my @return;
foreach my $node ( keys %$nodePopulations ) {
foreach my $virt (keys %{$nodePopulations->{$node}->{'running'}} ) {
push @return, &listDomain( $virt, $node );
}
}
$return = join( "\n", sort @return ) . "\n";;
}
return $return;;
} # sub domain
sub listDomain {
my ($virt,$node) = @_;
my @return;
push @return, $virt;
push @return, $node;
foreach my $column ( sort keys %{ $virtDB->{$virt} } ) {
push @return, $virtDB->{$virt}->{$column};
}
return join( "\t", @return);
}
# 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 $DEBUG;
if ( -f $filename ) {
open XML, "<$filename" or die "Could not read from $filename: $!\n";
$return = join( '', <XML> );
close XML;
} else {
&loadNodePopulations();
#die Dumper( $nodePopulations );
foreach my $node ( keys %$nodePopulations ) {
print "getVirtConfig Looking on $node for $virt\n";
if ( exists( $nodePopulations->{$node}->{'running'}->{$virt} ) ) { # we found it
print "Found $virt on node $node\n";
$return = `ssh $node 'virsh dumpxml $virt'`;
open XML,">$filename" or die "Could not write to $filename: $!\n";
print XML $return;
close XML;
} # if
} # foreach
} # if..else
return $return;
} # sub getVirtConfig
sub getXMLValue {
my ( $key, $string ) = @_;
my $start = "<$key";
my $end = "</$key>";
$string =~ m/$start([^>]*)>([^<]+)$end/;
return ($1,$2);
}
sub parseDomain {
my ($virt, $nodePopulations ) = @_;
my @keysToSave = ( 'uuid', 'memory', 'vcpu' );
my $filename = "$confDir/$virt.xml";
my $xml = &getVirtConfig( $virt, $filename );
my ($param,$value) = &getXMLValue( 'uuid', $xml );
$virtDB->{$virt}->{'uuid'} = $value;
($param,$value) = &getXMLValue( 'memory', $xml );
$virtDB->{$virt}->{'memory'} = $value;
($param,$value) = &getXMLValue( 'vcpu', $xml );
$virtDB->{$virt}->{'vcpu'} = $value;
$xml =~ m/type='vnc' port='(\d+)'/;
$virtDB->{$virt}->{'vnc'} = $1;
}
sub cluster {
my $action = lc shift;
my $return = '';
if ( $action eq 'status' ) {
&loadVirtDB();
&loadNodePopulations();
&loadNodeDB();
print "Node\tThreads\tMemory\tDomains\tvcpu\tmem_used\n";
my $usedmem = 0;
my $usedcpu = 0;
my $availmem = 0;
my $availcpu = 0;
my $totalDomains = 0;
foreach my $node (sort keys %$nodeDB ) {
my $memory = 0;
my $vcpus = 0;
my $count = 0;
foreach my $domain ( keys %{ $nodePopulations->{$node}->{'running'} } ) {
$memory += $virtDB->{$domain}->{'memory'};
$vcpus += $virtDB->{$domain}->{'vcpu'};
$count++;
}
$return .= "$node\t$nodeDB->{$node}->{cpu_count}\t$nodeDB->{$node}->{memory}\t$count\t$vcpus\t$memory\n";
$usedmem += $memory;
$usedcpu += $vcpus;
$totalDomains += $count;
$availmem += $nodeDB->{$node}->{memory};
$availcpu += $nodeDB->{$node}->{cpu_count};
} # outer for
$return .= "Total\t$availcpu\t$availmem\t$totalDomains\t$usedcpu\t$usedmem\n";
}
return $return;
}
# handle any command line parameters that may have been passed in
GetOptions (
'format|f=s' => \$reportFormat,
'target|t=s' => \$targetNode,
'dryrun|n!' => \$dryRun,
'debug|d+' => \$DEBUG,
'help|h' => \$help,
'version|v' => \$version
) or die "Error parsing command line\n";
my $command = shift; # the first one is the actual subsection
my $action = shift; # second is action to run
if ( $help || ! $command ) { &help() ; exit; }
if ( $version ) { use File::Basename; print basename($0) . " v$VERSION\n"; exit; }
print "Parameters are\nreportFormat\t$reportFormat\ntargetNode\t$targetNode\ndryRun\t$dryRun\nDEBUG\t$DEBUG\n" if $DEBUG;
print "Command = $command\nAction = $action\n" if $DEBUG;
# we allow a three part command for some actions on a domain, ie start, shutdown, migrate and destroy
# for simplicity, if the command is one of the above, allow the user to enter like that, but we will
# restructure the command as if they had used the full, three part (ie, with domain as the command)
# so, the following are equivilent
# havirt domain start nameofdomain
# havirt start nameofdomain
if ( $command eq 'start' || $command eq 'shutdown' || $command eq 'migrate' || $command eq 'destroy' ) { # shortcut for working with domains
push @ARGV, $action; # this is the domain we are working with
$action = $command; # this is what we want to do (start, shutdown, etc...)
$command = 'domain'; # keywork domain, for correct module
}
# ok, this is some serious weirdness. $command is actually the name of a module, and $action is a method
# defined in the module.
# I use 'require' which loads at runtime, not compile time, so it will only load a module if needed.
# then, I check to see if a method named in $action is defined within that module and, if so
# execute it and return the result. If not, gives an error message.
# This means to add functionality, we simply add a method (sub) in a given module, or create a whole
# new module.
# we have to concat here since the double colon causes some interpretation problems
my $execute = $command . '::' . $action;
# load the module, die if it doesn't exist. Might make this an eval later
require "$command.pm";
Module->import( $command ); # for require, you must manually import
if ( defined &{\&{$execute}} ) { # check if module::sub exists (ie, $command::action)
print &{\&{$execute}}(@ARGV); # yes, it exists, so call it with any remaining arguments
} else { # method $action does not exist in module $command, so just a brief error message
die "Error, could not find action $action for module $command\n";
}
1;