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

[#61] disconnect and reconnect implemented and tested

parent 6968054a
......@@ -148,9 +148,29 @@ sub _create_vm_kvm {
return ($vm_kvm,$err_kvm);
}
sub _refresh_vm_kvm {
=head2 disconnect_vm
Disconnect all the Virtual Managers connections.
=cut
sub disconnect_vm {
my $self = shift;
$self->_disconnect_vm();
}
sub _disconnect_vm{
my $self = shift;
return $self->_connect_vm(0);
}
sub _connect_vm {
my $self = shift;
sleep 1;
my $connect = shift;
$connect = 1 if !defined $connect;
my @vms;
eval { @vms = $self->vm };
warn $@ if $@;
......@@ -160,11 +180,15 @@ sub _refresh_vm_kvm {
return if !scalar @vms;
for my $n ( 0 .. $#{$self->vm}) {
my $vm = $self->vm->[$n];
next if ref $vm !~ /KVM/i;
warn "Refreshing VM $n $vm" if $DEBUG;
my ($vm2, $err) = $self->_create_vm_kvm();
$self->vm->[$n] = $vm2;
warn $err if $err;
if (!$connect) {
warn "disconnect VM $n $vm" if $DEBUG;
$vm->disconnect();
next;
}
warn "connect VM $n $vm" if $DEBUG;
$vm->reconnect();
}
}
......@@ -603,6 +627,8 @@ sub _execute {
confess "Unknown command ".$request->command
if !$sub;
$self->_disconnect_vm();
if ($dont_fork || !$CAN_FORK ) {
eval { $sub->($self,$request) };
......@@ -626,7 +652,7 @@ sub _execute {
exit;
}
$self->_add_pid($pid, $request->id);
$self->_refresh_vm_kvm();
# $self->_connect_vm_kvm();
return '';
}
......@@ -645,7 +671,6 @@ sub _cmd_domdisplay {
$request->result({display => $display});
$request->status('done');
}
sub _cmd_screenshot {
......
......@@ -207,7 +207,7 @@ sub _check_used_memory {
$used_memory += $info->{memory};
}
die "ERROR: Out of free memory. Using $used_memory RAM of $mem_total available" if $used_memory>= $mem_total;
confess "ERROR: Out of free memory. Using $used_memory RAM of $mem_total available" if $used_memory>= $mem_total;
}
sub _check_disk_modified {
......
......@@ -3,6 +3,7 @@ package Ravada::Front;
use strict;
use warnings;
use Carp qw(carp);
use Hash::Util qw(lock_hash);
use JSON::XS;
use Moose;
......@@ -75,6 +76,7 @@ sub list_bases {
}
$sth->finish;
$self->disconnect_vm();
return \@bases;
}
......@@ -103,6 +105,7 @@ sub list_domains {
}
$sth->finish;
$self->disconnect_vm();
return \@domains;
}
......@@ -476,4 +479,14 @@ sub list_bases_anonymous {
}
=head2 disconnect_vm
Disconnects all the conneted VMs
=cut
sub disconnect_vm {
%VM = ();
}
1;
......@@ -7,7 +7,6 @@ use Carp qw(cluck confess croak);
use Data::Dumper;
use Hash::Util qw(lock_keys);
use Moose;
use Sys::Virt::Network;
use XML::LibXML;
......@@ -15,8 +14,8 @@ with 'Ravada::NetInterface';
###########################################################################
has '_net' => (
isa => 'Sys::Virt::Network'
has 'name' => (
isa => 'Str'
,is => 'ro'
);
#
......@@ -24,6 +23,10 @@ has '_net' => (
###########################################################################
sub BUILD {
}
=head2 type
Returns the type for the interface in the domain
......@@ -44,7 +47,7 @@ Returns the XML description for the domain source tag
sub xml_source {
my $self = shift;
return "<source network=\"".$self->_net->get_name."\"/>";
return "<source network=\"".$self->name."\"/>";
}
......@@ -57,7 +60,7 @@ Returns a hash with the attributes of the source element
sub source {
my $self = shift;
return { network => $self->_net->get_name };
return { network => $self->name };
}
1;
......
......@@ -28,6 +28,9 @@ requires 'list_domains';
# storage volume
requires 'create_volume';
requires 'connect';
requires 'disconnect';
############################################################
has 'host' => (
......
package Ravada::VM::KVM;
use Carp qw(croak);
use Carp qw(croak carp);
use Data::Dumper;
use Digest::MD5;
use Encode;
......@@ -26,15 +26,15 @@ with 'Ravada::VM';
#
has vm => (
isa => 'Sys::Virt'
,is => 'rw'
# isa => 'Sys::Virt'
is => 'rw'
,builder => 'connect'
,lazy => 1
);
has storage_pool => (
isa => 'Sys::Virt::StoragePool'
,is => 'ro'
# isa => 'Sys::Virt::StoragePool'
is => 'rw'
,builder => '_load_storage_pool'
,lazy => 1
);
......@@ -82,12 +82,33 @@ sub connect {
,readonly => $self->mode
);
}
$vm->register_close_callback(\&_reconnect);
# $vm->register_close_callback(\&_reconnect);
return $vm;
}
sub _reconnect {
warn "Disconnected";
=head2 disconnect
Disconnect from the Virtual Machine Manager
=cut
sub disconnect {
my $self = shift;
$self->vm(undef);
$self->storage_pool(undef);
}
=head2 reconnect
Reconnect the internal virtual manager
=cut
sub reconnect {
my $self = shift;
$self->vm($self->connect);
$self->storage_pool($self->_load_storage_pool);
}
sub _load_storage_pool {
......@@ -145,6 +166,7 @@ sub create_domain {
croak "argument id_iso or id_base required ".Dumper(\%args)
if !$args{id_iso} && !$args{id_base};
$self->reconnect() if !defined $self->vm;
my $domain;
if ($args{id_iso}) {
$domain = $self->_domain_create_from_iso(@_);
......@@ -169,6 +191,8 @@ sub search_domain {
my $self = shift;
my $name = shift or confess "Missing name";
$self->reconnect if !defined $self->vm();
my @all_domains;
eval { @all_domains = $self->vm->list_all_domains() };
die $@ if $@;
......@@ -203,6 +227,7 @@ Returns a list of the created domains
sub list_domains {
my $self = shift;
$self->reconnect if !defined $self->vm();
my @list;
for my $name ($self->vm->list_all_domains()) {
my $domain ;
......@@ -317,7 +342,6 @@ sub _domain_create_from_iso {
my $dom = $self->vm->define_domain($xml->toString());
$dom->create if $args{active};
my $domain = Ravada::Domain::KVM->new(domain => $dom , storage => $self->storage_pool
, _vm => $self
);
......@@ -871,21 +895,27 @@ Returns a list of networks known to this VM. Each element is a Ravada::NetInterf
sub list_networks {
my $self = shift;
$self->reconnect() if !defined $self->vm();
my @nets = $self->vm->list_all_networks();
my @ret_nets;
for my $net (@nets) {
push @ret_nets ,( Ravada::NetInterface::KVM->new( _net => $net ) );
push @ret_nets ,( Ravada::NetInterface::KVM->new( name => $net->get_name ) );
}
for my $if (IO::Interface::Simple->interfaces) {
next if $if->is_loopback();
next if !$if->address();
next if $if =~ /virbr/i;
# that should catch bridges
next if $if->hwaddr =~ /^[00:]+00$/;
push @ret_nets, ( Ravada::NetInterface::MacVTap->new(interface => $if));
}
$self->vm(undef);
return @ret_nets;
}
......
......@@ -22,6 +22,7 @@ with 'Ravada::VM';
#
sub connect {}
sub disconnect {}
sub create_domain {
my $self = shift;
......
......@@ -4,7 +4,7 @@ use strict;
use Carp qw(confess);
use Data::Dumper;
use POSIX qw(WNOHANG);
use Test::More;
use Test::More;# tests => 82;
use Test::SQL::Data;
use_ok('Ravada');
......@@ -22,12 +22,14 @@ my $DOMAIN_NAME_SON=$DOMAIN_NAME."_son";
my $RVD_BACK = rvd_back( $test->connector , 't/etc/ravada.conf');
my $USER = create_user("foo","bar");
$RVD_BACK = undef;
my @ARG_CREATE_DOM = (
id_iso => 1
,id_owner => $USER->id
);
$Ravada::CAN_FORK = 0;
#######################################################################
......@@ -80,11 +82,10 @@ sub test_req_create_domain_iso {
." ,got '".($req->args->{name} or '<UNDEF>')."'");
ok($req->status eq 'requested'
,"Status of request is ".$req->status." it should be requested");
,"$$ Status of request is ".$req->status." it should be requested");
$ravada->process_requests();
sleep 1;
$ravada->_wait_pids();
wait_request($req);
......@@ -94,9 +95,9 @@ sub test_req_create_domain_iso {
test_unread_messages($USER,1, "[$vm_name] create domain $name");
my $req2 = Ravada::Request->open($req->id);
ok($req2->{id} == $req->id,"req2->{id} = ".$req2->{id}." , expecting ".$req->id);
ok($req2->{id} == $req->id,"iso req2->{id} = ".$req2->{id}." , expecting ".$req->id);
my $vm = $RVD_BACK->search_vm($vm_name);
my $vm = $ravada->search_vm($vm_name);
my $domain = $vm->search_domain($name);
ok($domain,"[$vm_name] I can't find domain $name");
......
......@@ -53,7 +53,7 @@ sub test_new_domain {
my $vm_name = shift;
my $name = shift;
my $vm = rvd_back->search_vm($vm_name);
my $vm = $RAVADA->search_vm($vm_name);
# test_remove_domain($vm_name, $name);
......@@ -72,7 +72,6 @@ sub test_start {
my $name = new_domain_name();
# test_remove_domain($vm_name, $name);
my $vm = rvd_back->search_vm($vm_name);
my $remote_ip = '99.88.77.66';
......@@ -96,9 +95,11 @@ sub test_start {
# start
test_new_domain($vm_name, $name);
my $domain = $vm->search_domain($name);
ok(!$domain->is_active,"Domain $name should be inactive") or return;
{
my $vm = $RAVADA->search_vm($vm_name);
my $domain = $vm->search_domain($name);
ok(!$domain->is_active,"Domain $name should be inactive") or return;
}
my $req2 = Ravada::Request->start_domain(name => $name, uid => $USER->id
,remote_ip => $remote_ip
);
......@@ -107,12 +108,16 @@ sub test_start {
wait_request($req2);
ok($req2->status eq 'done',"Expecting request status 'done' , got "
.$req2->status);
$domain->start($USER) if !$domain->is_active();
ok($domain->is_active);
{
my $domain = $RAVADA->search_domain($name);
$domain->start($USER) if !$domain->is_active();
ok($domain->is_active);
my $domain2 = $vm->search_domain($name);
ok($domain2->is_active);
my $vm = $RAVADA->search_vm($vm_name);
my $domain2 = $vm->search_domain($name);
ok($domain2->is_active);
}
$req2 = undef;
......@@ -127,8 +132,7 @@ sub test_start {
.$req3->status);
ok(!$req3->error,"Error shutting down domain $name , expecting ''. Got '".$req3->error);
ok(!$domain->is_active, "Domain $name should not be active");
my $vm = $RAVADA->search_vm($vm_name);
my $domain3 = $vm->search_domain($name);
ok(!$domain3->is_active,"Domain $name should not be active");
......@@ -138,8 +142,9 @@ sub test_start {
sub test_screenshot {
my $vm_name = shift;
my $domain = shift;
my $domain_name = shift;
my $domain = $RAVADA->search_domain($domain_name);
$domain->start($USER) if !$domain->is_active();
return if !$domain->can_screenshot();
......@@ -149,20 +154,26 @@ sub test_screenshot {
ok(!-e $domain->_file_screenshot,"File screenshot ".$domain->_file_screenshot
." should not exist");
my $req = Ravada::Request->screenshot_domain(id_domain => $domain->id );
my $file_screenshot = $domain->_file_screenshot();
my $domain_id = $domain->id;
$domain = undef;
my $req = Ravada::Request->screenshot_domain(id_domain => $domain_id );
ok($req);
$RAVADA->process_requests();
wait_request($req);
ok($req->status('done'),"Request should be done, it is ".$req->status);
ok(!$req->error(''),"Error should be '' , it is ".$req->error);
ok(-e $domain->_file_screenshot,"File screenshot ".$domain->_file_screenshot
ok(-e $file_screenshot,"File screenshot ".$file_screenshot
." should exist");
}
sub test_screenshot_file {
my $vm_name = shift;
my $domain = shift;
my $domain_name = shift;
my $domain = $RAVADA->search_domain($domain_name);
$domain->start($USER) if !$domain->is_active();
return if !$domain->can_screenshot();
......@@ -173,8 +184,11 @@ sub test_screenshot_file {
ok(!-e $domain->_file_screenshot,"File screenshot should not exist");
my $file = "/var/tmp/screenshot.$$.png";
my $domain_id = $domain->id;
$domain = undef;
my $req = Ravada::Request->screenshot_domain(
id_domain => $domain->id
id_domain => $domain_id
,filename => $file);
ok($req);
......@@ -195,28 +209,27 @@ sub test_screenshot_file {
remove_old_domains();
remove_old_disks();
my $vmm;
for my $vm_name (qw(KVM Void)) {
$vmm = $RAVADA->search_vm($vm_name);
my $vmm = $RAVADA->search_vm($vm_name);
SKIP: {
my $msg = "SKIPPED: Virtual manager $vm_name not found";
diag($msg) if !$vmm;
skip($msg,10) if !$vmm;
$vmm->disconnect() if $vmm;
diag("Testing VM $vm_name");
my $domain = test_start($vm_name);
$domain->_vm->disconnect;
my $domain_name = $domain->name;
$domain = undef;
test_screenshot($vm_name, $domain);
test_screenshot_file($vm_name, $domain);
$domain->shutdown_now($USER) if $domain;
$domain->remove(user_admin()) if $domain;
test_screenshot($vm_name, $domain_name);
test_screenshot_file($vm_name, $domain_name);
};
}
remove_old_domains();
remove_old_disks();
done_testing();
......@@ -202,7 +202,7 @@ sub wait_request {
my $req = shift;
for ( 1 .. 10 ) {
last if $req->status eq 'done';
diag("Request ".$req->command." ".$req->status." ".localtime(time));
diag("Request ".$req->id." ".$req->command." ".$req->status." ".localtime(time));
sleep 2;
}
......
......@@ -120,6 +120,7 @@ sub test_req_create_domain{
ok($req,"Expecting request to create_domain");
$RVD_FRONT->disconnect_vm();
$RVD_BACK->process_requests();
wait_request($req);
......@@ -127,7 +128,7 @@ sub test_req_create_domain{
ok(!$req->error,"Expecting error '' , got '".($req->error or '')."'");
my $domain = $RVD_FRONT->search_domain($name);
ok($domain,"Expecting domain doesn't exists domain '$name'");
ok($domain,"Expecting domain '$name' , found : ".(defined $domain or 0));
return $domain;
}
......@@ -270,6 +271,7 @@ for my $vm_name (qw( Void KVM )) {
my $ravada;
eval { $ravada = Ravada->new(@ARG_RVD) };
$ravada = undef;
my $vm;
......
......@@ -13,6 +13,9 @@ my $test = Test::SQL::Data->new(config => 't/etc/sql.conf');
use_ok('Ravada');
$Ravada::DEBUG = 0;
$Ravada::CAN_FORK = 1;
my $FILE_CONFIG = 't/etc/ravada.conf';
my $RVD_BACK = rvd_back($test->connector, $FILE_CONFIG);
......@@ -33,25 +36,37 @@ my %SUB_CHECK_NET =(
);
###############################################################################
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_vm_rvd {
my ($vm_name, $rvd ) = @_;
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) {
$rvd->disconnect_vm();
$vm->disconnect;
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_vm {
my $vm_name = shift;
$RVD_FRONT = undef;
test_vm_rvd($vm_name, $RVD_BACK);
$RVD_FRONT= rvd_front($test->connector, $FILE_CONFIG);
test_vm_rvd($vm_name, $RVD_FRONT);
$RVD_FRONT = undef;
}
......@@ -68,18 +83,25 @@ sub test_create_domain {
,id_owner => $USER->id
);
if ($vm->readonly) {
$RVD_BACK->disconnect_vm();
$RVD_FRONT->disconnect_vm();
my $req = $RVD_FRONT->create_domain(@args_create);