Commit e8c97885 authored by Francesc Guasch's avatar Francesc Guasch
Browse files

[#47] Added backend support for different NIC configs

parent 6d9a7855
......@@ -903,6 +903,19 @@ sub _req_method {
return $methods{$cmd};
}
=head2 open_vm
Opens a VM of a given type
my $vm = $ravada->open_vm('KVM');
=cut
sub open_vm {
return search_vm(@_);
}
=head2 search_vm
Searches for a VM of a given type
......
package Ravada::NetInterface;
use warnings;
use strict;
use Moose::Role;
##############################################################
#
# methods
#
requires 'type';
requires 'source';
requires 'xml_source';
##############################################################
#
# attributes
#
has '_net' => (
isa => 'Object'
,is => 'ro'
);
##############################################################
sub TO_JSON {
my $self = shift;
return { type => $self->type , source => $self->source };
}
1;
package Ravada::NetInterface::KVM;
use warnings;
use strict;
use Carp qw(cluck confess croak);
use Data::Dumper;
use Hash::Util qw(lock_keys);
use Moose;
use Sys::Virt::Network;
use XML::LibXML;
with 'Ravada::NetInterface';
###########################################################################
has '_net' => (
isa => 'Sys::Virt::Network'
,is => 'ro'
);
#
#
###########################################################################
=head2 type
Returns the type for the interface in the domain
=cut
sub type {
return 'network';
}
=head2 xml_source
Returns the XML description for the domain source tag
=cut
sub xml_source {
my $self = shift;
return "<source network=\"".$self->_net->get_name."\"/>";
}
=head2 source
Returns a hash with the attributes of the source element
=cut
sub source {
my $self = shift;
return { network => $self->_net->get_name };
}
1;
package Ravada::NetInterface::MacVTap;
use warnings;
use strict;
use Carp qw(cluck confess croak);
use Data::Dumper;
use Hash::Util qw(lock_keys);
use Moose;
use Sys::Virt::Network;
use XML::LibXML;
with 'Ravada::NetInterface';
###########################################################################
has 'interface' => (
isa => 'IO::Interface::Simple'
,is => 'ro'
,required => 1
);
###########################################################################
=head2 type
Returns the type for the interface in the domain
=cut
sub type {
return 'direct';
}
=head2 xml_source
Returns the XML description for the domain source tag
=cut
sub xml_source {
my $self = shift;
return "<source dev='".$self->interface->name."' mode='".$self->mode."'/>"
}
sub source {
my $self = shift;
return {
dev => $self->interface->name
,mode => $self->mode
};
}
sub mode {
return 'bridge';
}
1;
package Ravada::NetInterface::Void;
use warnings;
use strict;
use Carp qw(cluck confess croak);
use Data::Dumper;
use Hash::Util qw(lock_keys);
use Moose;
use Sys::Virt::Network;
use XML::LibXML;
with 'Ravada::NetInterface';
###########################################################################
#
sub type { return 'void' };
=head2 xml_source
Returns the XML for the network Interface
=cut
sub xml_source {
return '<source network="void"/>';
}
sub source {
return { network => 'void' };
}
1;
......@@ -34,6 +34,7 @@ our %VALID_ARG = (
,id_template => 1
,memory => 2
,disk => 2
,network => 2
}
,remove_base => $args_prepare
,prepare_base => $args_prepare
......@@ -127,6 +128,9 @@ sub create_domain {
confess "Invalid argument $_" if !$VALID_ARG{'create_domain'}->{$_};
}
my $self = {};
if ($args{network}) {
$args{network} = JSON::XS->new->convert_blessed->encode($args{network});
}
bless($self,$class);
return $self->_new_request(command => 'create' , args => encode_json(\%args));
......
......@@ -25,6 +25,9 @@ requires 'list_domains';
# storage volume
requires 'create_volume';
# networks
requires 'list_networks';
############################################################
has 'host' => (
......
......@@ -8,6 +8,8 @@ use Encode::Locale;
use Fcntl qw(:flock O_WRONLY O_EXCL O_CREAT);
use Hash::Util qw(lock_hash);
use IPC::Run3 qw(run3);
use IO::Interface::Simple;
use JSON::XS;
use LWP::UserAgent;
use Moose;
use Sys::Virt;
......@@ -15,6 +17,8 @@ use URI;
use XML::LibXML;
use Ravada::Domain::KVM;
use Ravada::NetInterface::KVM;
use Ravada::NetInterface::MacVTap;
with 'Ravada::VM';
......@@ -308,6 +312,8 @@ sub _domain_create_from_iso {
_xml_modify_disk($xml, [$device_disk]) if $device_disk;
$self->_xml_modify_usb($xml);
$self->_xml_modify_network($xml , $args{network}) if $args{network};
my $dom = $self->vm->define_domain($xml->toString());
$dom->create if $args{active};
......@@ -631,6 +637,36 @@ sub _xml_modify_memory {
}
sub _xml_modify_network {
my $self = shift;
my $doc = shift;
my $network = shift;
my ($type, $source );
if (ref($network) =~ /^Ravada/) {
($type, $source) = ($network->type , $network->source);
} else {
$network = decode_json($network);
($type, $source) = ($network->{type} , $network->{source});
}
confess "Unknown network type " if !defined $type;
confess "Unknown network xml_source" if !defined $source;
my @interfaces = $doc->findnodes('/domain/devices/interface');
if (scalar @interfaces>1) {
warn "WARNING: ".scalar @interfaces." found, changing the first one";
}
my $if = $interfaces[0];
$if->setAttribute(type => $type);
my ($node_source) = $if->findnodes('./source');
$node_source->removeAttribute('network');
for my $field (keys %$source) {
$node_source->setAttribute($field => $source->{$field});
}
}
sub _xml_modify_usb {
my $self = shift;
my $doc = shift;
......@@ -826,4 +862,31 @@ sub _xml_modify_mac {
$if_mac->setAttribute(address => $new_mac);
}
=head2 list_networks
Returns a list of networks known to this VM. Each element is a Ravada::NetInterface object
=cut
sub list_networks {
my $self = shift;
my @nets = $self->vm->list_all_networks();
my @ret_nets;
for my $net (@nets) {
push @ret_nets ,( Ravada::NetInterface::KVM->new( _net => $net ) );
}
for my $if (IO::Interface::Simple->interfaces) {
next if $if->is_loopback();
# that should catch bridges
next if $if->hwaddr =~ /^[00:]+00$/;
push @ret_nets, ( Ravada::NetInterface::MacVTap->new(interface => $if));
}
return @ret_nets;
}
1;
......@@ -14,6 +14,8 @@ use Sys::Hostname;
use URI;
use Ravada::Domain::Void;
use Ravada::NetInterface::Void;
with 'Ravada::VM';
##########################################################################
......@@ -90,6 +92,10 @@ sub search_domain {
}
}
sub list_networks {
return Ravada::NetInterface::Void->new();
}
#########################################################################3
1;
use warnings;
use strict;
use Data::Dumper;
use Test::More;
use Test::SQL::Data;
use XML::LibXML;
use lib 't/lib';
use Test::Ravada;
my $test = Test::SQL::Data->new(config => 't/etc/sql.conf');
use_ok('Ravada');
my $FILE_CONFIG = 't/etc/ravada.conf';
my $RVD_BACK = rvd_back($test->connector, $FILE_CONFIG);
my $RVD_FRONT= rvd_front($test->connector, $FILE_CONFIG);
my %ARG_CREATE_DOM = (
KVM => [ id_iso => 1 ]
,Void => [ ]
);
my @ARG_RVD = ( config => $FILE_CONFIG, connector => $test->connector);
my @VMS = reverse keys %ARG_CREATE_DOM;
my $USER = create_user("foo","bar");
my %SUB_CHECK_NET =(
'KVM' => \&check_net_kvm
);
###############################################################################
sub test_vm {
my ($vm_name) = @_;
for my $rvd ($RVD_FRONT,$RVD_BACK) {
my $vm = $rvd->open_vm($vm_name);
ok($vm,"Expecting $vm_name VM");
my @networks = $vm->list_networks();
ok(scalar @networks
, "[$vm_name] Expecting at least 1 network, got ".scalar @networks);
ok(scalar @networks > 1
, "[$vm_name] Expecting at least 2 networks, got ".scalar @networks)
if $vm_name !~ /Void/i;
for my $net (@networks) {
ok($net->type =~ /\w/,"Expecting type , got '".$net->type."'");
ok($net->xml_source =~ /<source/,"Expecting source, got '".$net->xml_source."'");
test_create_domain($vm_name, $vm, $net);
}
}
}
sub test_create_domain {
my ($vm_name, $vm, $net) = @_;
my $domain_name = new_domain_name();
my @args_create = (
vm => $vm_name
,name => $domain_name
,id_iso => 1
,network => $net
,id_owner => $USER->id
);
if ($vm->readonly) {
my $req = $RVD_FRONT->create_domain(@args_create);
$RVD_BACK->process_requests();
wait_request($req);
ok($req->status eq 'done',"Expecting req 'done', got '".$req->status."'") or return;
ok(!$req->error ,"Expecting no req error , got '".$req->error."'") or return;
} else {
my $domain0 = $vm->create_domain(@args_create);
}
my $domain = $vm->search_domain($domain_name);
ok($domain,"Expecting domain '$domain_name' created") or return;
return if $vm_name =~ /Void/i;
my $sub = $SUB_CHECK_NET{$vm_name};
ok($sub,"[$vm_name] Expecting a sub to check network") or return;
$sub->($vm_name, $domain, $net);
}
sub check_net_kvm {
my ($vm_name, $domain, $net) = @_;
my $xml = XML::LibXML->load_xml(string => $domain->domain->get_xml_description);
my @if = $xml->findnodes('/domain/devices/interface');
ok(scalar @if == 1,"Expecting 1 interface, got ".scalar @if) or return;
for my $if ( @if ) {
if (ref($net) =~ /KVM/) {
test_interface_kvm($vm_name, $net, $if);
} elsif(ref($net) =~ /MacVTap/i) {
test_interface_macvtap($vm_name, $net, $if);
}
}
}
sub test_interface_kvm {
my ($vm_name, $net, $if) = @_;
my $exp_type = 'network';
my $type = $if->getAttribute('type');
ok($type eq $exp_type,"[$vm_name , netKVM] Expecting interface type=\"$exp_type\", got: \"$type\"");
my ($source) = $if->findnodes('./source');
my $network = $source->getAttribute('network');
my ($exp_network) = $net->xml_source =~ /"(\w+)"/;
ok($network eq $exp_network
,"Expecting source=$exp_network , got ".$network);
}
sub test_interface_macvtap {
my ($vm_name, $net, $if) = @_;
my $exp_type = 'direct';
my $type = $if->getAttribute('type');
ok($type eq $exp_type,"[$vm_name , netKVM] Expecting interface type=\"$exp_type\", got: \"$type\"");
my ($source) = $if->findnodes('./source');
my $dev= $source->getAttribute('dev');
my ($exp_dev) = $net->interface->name;
ok(defined$dev && $dev eq $exp_dev
,"[$vm_name - macVTap] Expecting dev='$exp_dev', got '".($dev or '<UNDEF>'));
my $mode= $source->getAttribute('mode');
my ($exp_mode) = $net->mode;
ok(defined$mode && $mode eq $exp_mode
,"[$vm_name - macVTap] Expecting mode='$exp_mode', got '".($mode or '<UNDEF>'));
}
###############################################################################
remove_old_domains();
remove_old_disks();
for my $vm_name (@VMS) {
test_vm($vm_name);
}
remove_old_domains();
remove_old_disks();
done_testing();
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment