Commit 5887fd01 authored by Francesc Guasch's avatar Francesc Guasch
Browse files

[#61] disconnecting from VM every time

parent 1a6a5c74
......@@ -185,10 +185,10 @@ sub _connect_vm {
warn "disconnect VM $n $vm" if $DEBUG;
$vm->disconnect();
next;
} else {
warn "connect VM $n $vm" if $DEBUG;
$vm->connect();
}
warn "connect VM $n $vm" if $DEBUG;
$vm->reconnect();
}
}
......
......@@ -112,6 +112,18 @@ after 'shutdown' => \&_post_shutdown;
before 'remove_base' => \&_can_remove_base;
after 'remove_base' => \&_remove_base_db;
##################################################
sub _vm_connect {
my $self = shift;
$self->_vm->connect();
}
sub _vm_disconnect {
my $self = shift;
$self->_vm->disconnect();
}
sub _start_preconditions{
if (scalar @_ %2 ) {
_allow_manage_args(@_);
......@@ -590,6 +602,12 @@ sub _can_remove_base {
_check_has_clones(@_);
}
sub _post_remove_base {
my $self = shift;
$self->_vm->disconnect();
$self->_remove_base_db(@_);
}
sub _remove_base_db {
my $self = shift;
......
......@@ -14,7 +14,7 @@ use XML::LibXML;
with 'Ravada::Domain';
has 'domain' => (
is => 'ro'
is => 'rw'
,isa => 'Sys::Virt::Domain'
,required => 1
);
......@@ -192,9 +192,11 @@ sub _remove_file_image {
sub _disk_device {
my $self = shift;
$self->_vm->connect();
my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description)
or die "ERROR: $!\n";
$self->_vm->disconnect();
my @img;
my $list_disks = '';
......@@ -526,9 +528,16 @@ sub _new_pci_slot{
}
}
#sub BUILD {
# warn "Builder KVM.pm";
#}
=head2 BUILD
internal build method
=cut
sub BUILD {
my $self = shift;
$self->_vm->disconnect();
}
=head2 list_volumes
......@@ -554,6 +563,8 @@ sub screenshot {
my $self = shift;
my $file = (shift or $self->_file_screenshot);
$self->_vm->connect();
$self->domain($self->_vm->vm->get_domain_by_name($self->name));
my $stream = $self->{_vm}->vm->new_stream();
my $mimetype = $self->domain->screenshot($stream,0);
......@@ -573,6 +584,7 @@ sub screenshot {
unlink $file_tmp or warn "$! removing $file_tmp";
$stream->finish;
$self->_vm->disconnect();
return $bytes;
}
......
......@@ -277,15 +277,29 @@ sub open_vm {
my $type = shift or confess "I need vm type";
my $class = "Ravada::VM::$type";
return $VM{$type} if $VM{$type};
if ($VM{$type}) {
$VM{$type}->disconnect();
return $VM{$type}
}
my $proto = {};
bless $proto,$class;
$VM{$type} = $proto->new(readonly => 1);
$VM{$type}->disconnect();
return $VM{$type};
}
=head2 search_vm
Calls to open_vm
=cut
sub search_vm {
return open_vm(@_);
}
=head2 search_clone
Search for a clone of a domain owned by an user.
......@@ -360,6 +374,7 @@ sub search_domain {
my $vm = $self->open_vm($vm_name);
my $domain = $vm->search_domain($name);
$domain->_vm->disconnect();
return $domain;
}
......
......@@ -56,11 +56,22 @@ has 'readonly' => (
);
############################################################
#
# Method Modifiers
# Method Modifiers definition
#
#
before 'create_domain' => \&_check_create_domain;
before 'create_domain' => \&_pre_create_domain;
after 'create_domain' => \&_disconnect;
before 'search_domain' => \&_connect;
after 'search_domain' => \&_disconnect;
before 'create_volume' => \&_connect;
after 'create_volume' => \&_disconnect;
#############################################################
#
# method modifiers
#
sub _check_readonly {
my $self = shift;
confess "ERROR: You can't create domains in read-only mode "
......@@ -68,6 +79,21 @@ sub _check_readonly {
}
sub _connect {
my $self = shift;
$self->connect();
}
sub _disconnect {
my $self = shift;
$self->disconnect();
}
sub _pre_create_domain {
_check_create_domain(@_);
_connect(@_);
}
############################################################
#
sub _domain_remove_db {
......
......@@ -28,7 +28,7 @@ with 'Ravada::VM';
has vm => (
# isa => 'Sys::Virt'
is => 'rw'
,builder => 'connect'
,builder => '_connect'
,lazy => 1
);
......@@ -63,13 +63,8 @@ our $CONNECTOR = \$Ravada::CONNECTOR;
##########################################################################
=head2 connect
Connect to the Virtual Machine Manager
=cut
sub connect {
sub _connect {
my $self = shift;
my $vm;
......@@ -99,15 +94,15 @@ sub disconnect {
$self->storage_pool(undef);
}
=head2 reconnect
=head2 connect
Reconnect the internal virtual manager
Connect to the Virtual Machine Manager
=cut
sub reconnect {
sub connect {
my $self = shift;
$self->vm($self->connect);
$self->vm($self->_connect);
$self->storage_pool($self->_load_storage_pool);
}
......@@ -166,7 +161,6 @@ 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(@_);
......@@ -191,7 +185,7 @@ sub search_domain {
my $self = shift;
my $name = shift or confess "Missing name";
$self->reconnect if !defined $self->vm();
$self->connect;# if !defined $self->vm();
my @all_domains;
eval { @all_domains = $self->vm->list_all_domains() };
......@@ -210,8 +204,12 @@ sub search_domain {
);
};
warn $@ if $@;
return $domain if $domain;
if ($domain) {
$self->disconnect;# if !defined $self->vm();
return $domain;
}
}
$self->disconnect;# if !defined $self->vm();
return;
}
......@@ -227,11 +225,12 @@ Returns a list of the created domains
sub list_domains {
my $self = shift;
$self->reconnect if !defined $self->vm();
$self->connect();
my @list;
for my $name ($self->vm->list_all_domains()) {
my $domain ;
my $id;
$self->connect();
eval { $domain = Ravada::Domain::KVM->new(
domain => $name
,storage => $self->storage_pool
......@@ -239,8 +238,10 @@ sub list_domains {
);
$id = $domain->id();
};
warn $@ if $@ && $@ !~ /No DB info/i;
push @list,($domain) if $domain && $id;
}
$self->disconnect();
return @list;
}
......@@ -297,9 +298,12 @@ sub search_volume {
my $self = shift;
my $name = shift or confess "Missing volume name";
$self->connect();
my $vol;
eval { $vol = $self->storage_pool->get_volume_by_name($name) };
die $@ if $@;
$self->disconnect();
return $vol;
}
......@@ -315,6 +319,7 @@ sub _domain_create_from_iso {
die "Domain $args{name} already exists"
if $self->search_domain($args{name});
$self->connect() if !defined $self->vm;
my $vm = $self->vm;
my $storage = $self->storage_pool;
......@@ -416,10 +421,14 @@ sub _domain_create_from_base {
my $base = $args{base} if $args{base};
$base = $self->_search_domain_by_id($args{id_base}) if $args{id_base};
confess "Unknown base id: $args{id_base}" if !$base;
my $vm = $self->vm;
my $storage = $self->storage_pool;
$base->_vm->connect();
my $xml = XML::LibXML->load_xml(string => $base->domain->get_xml_description());
$base->_vm->disconnect();
my @device_disk = $self->_create_disk($base, $args{name});
# _xml_modify_cdrom($xml);
......@@ -844,6 +853,7 @@ sub _unique_mac {
$mac = lc($mac);
$self->connect() if !$self->vm;
for my $dom ($self->vm->list_all_domains) {
my $doc = $XML->load_xml(string => $dom->get_xml_description()) or die "ERROR: $!\n";
......@@ -895,7 +905,7 @@ 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();
$self->connect() if !defined $self->vm();
my @nets = $self->vm->list_all_networks();
my @ret_nets;
......@@ -931,6 +941,8 @@ sub import_domain {
my $self = shift;
my ($name, $user) = @_;
$self->connect();
my $domain_kvm = $self->vm->get_domain_by_name($name);
confess "ERROR: unknown domain $name in KVM" if !$domain_kvm;
......@@ -941,6 +953,8 @@ sub import_domain {
);
$domain->_insert_db(name => $name, id_owner => $user->id);
$self->disconnect();
return $domain;
}
......
......@@ -18,11 +18,16 @@ use Ravada::NetInterface::Void;
with 'Ravada::VM';
has 'vm' => (
is => 'rw'
);
##########################################################################
#
sub connect {}
sub disconnect {}
sub reconnect {}
sub create_domain {
my $self = shift;
......
......@@ -136,7 +136,7 @@ sub test_domain{
.($n_domains+1)
." "
.join(" * ", sort map { $_->name } @list)
);
) or exit;
ok(!$domain->is_base,"Domain shouldn't be base "
.Dumper($domain->_select_domain_db()));
......@@ -161,6 +161,7 @@ sub test_domain{
ok(test_domain_in_virsh($domain->name,$domain->name)," not in virsh list all");
my $domain2;
$vm->connect();
eval { $domain2 = $vm->vm->get_domain_by_name($domain->name)};
ok($domain2,"Domain ".$domain->name." missing in VM") or exit;
......@@ -172,9 +173,14 @@ sub test_domain_in_virsh {
my $name = shift;
my $vm = $RAVADA->search_vm('kvm');
$vm->connect();
for my $domain ($vm->vm->list_all_domains) {
return 1 if $domain->get_name eq $name;
if ( $domain->get_name eq $name ) {
$vm->disconnect;
return 1
}
}
$vm->disconnect();
return 0;
}
......@@ -198,6 +204,7 @@ sub test_domain_missing_in_db {
my $vm = $RAVADA->search_vm('kvm');
my $domain3;
$vm->connect();
eval { $domain3 = $vm->vm->get_domain_by_name($domain->name)};
ok($domain3,"I can't find the domain in the VM") or return;
......
......@@ -115,6 +115,7 @@ sub _remove_old_domains_kvm {
my $vm = rvd_back()->search_vm('KVM');
my $base_name = base_domain_name();
$vm->connect();
for my $domain ( $vm->vm->list_defined_domains ) {
next if $domain->get_name !~ /^$base_name/;
eval {
......@@ -127,6 +128,7 @@ sub _remove_old_domains_kvm {
eval { $domain->undefine };
warn $@ if $@;
}
$vm->disconnect();
}
sub remove_old_domains {
......@@ -149,6 +151,7 @@ sub _remove_old_disks_kvm {
my $dir_img = $vm->dir_img();
ok($dir_img," I cant find a dir_img in the KVM virtual manager") or return;
$vm->connect;
eval { $vm->storage_pool->refresh() };
ok(!$@,$@) or return;
opendir my $ls,$dir_img or die "$! $dir_img";
......@@ -161,6 +164,7 @@ sub _remove_old_disks_kvm {
unlink $disk or die "I can't remove $disk";
}
$vm->storage_pool->refresh();
$vm->disconnect();
}
sub _remove_old_disks_void {
......
......@@ -15,12 +15,11 @@ use Test::Ravada;
my $test = Test::SQL::Data->new(config => 't/etc/sql.conf');
my $ravada;
my ($DOMAIN_NAME) = $0 =~ m{.*/(.*)\.};
my $DOMAIN_NAME_SON=$DOMAIN_NAME."_son";
my $RVD_BACK = rvd_back( $test->connector , 't/etc/ravada.conf');
my $RVD_FRONT = rvd_front( $test->connector , 't/etc/ravada.conf');
my $USER = create_user("foo","bar");
my @ARG_CREATE_DOM = (
......@@ -32,30 +31,10 @@ my @ARG_CREATE_DOM = (
#######################################################################
sub test_empty_request {
my $request = $ravada->request();
my $request = $RVD_BACK->request();
ok($request);
}
sub test_remove_domain {
my $vm = shift;
my $name = shift;
my $domain = $name if ref($name);
$domain = $vm->search_domain($name,1);
if ($domain) {
diag("Removing domain $name");
eval { $domain->remove(user_admin()) };
ok(!$@ , "Error removing domain $name : $@") or exit;
# TODO check remove files base
}
$domain = $vm->search_domain($name,1);
ok(!$domain, "I can't remove old domain $name");
}
sub test_unread_messages {
my ($user, $n_unread, $test) = @_;
confess "Missing test name" if !$test;
......@@ -93,10 +72,10 @@ sub test_req_create_domain_iso {
ok($req->status eq 'requested'
,"Status of request is ".$req->status." it should be requested");
$ravada->_process_requests_dont_fork();
$RVD_BACK->process_requests();
wait_request($req);
$ravada->_wait_pids();
$RVD_BACK->_wait_pids();
ok($req->status eq 'done'
,"Status of request is ".$req->status." it should be done");
......@@ -108,13 +87,16 @@ sub test_req_create_domain_iso {
my $req2 = Ravada::Request->open($req->id);
ok($req2->{id} == $req->id,"req2->{id} = ".$req2->{id}." , expecting ".$req->id);
my $vm = $RVD_BACK->search_vm($vm_name);
my $vm = $RVD_FRONT->search_vm($vm_name);
my $domain = $vm->search_domain($name);
ok($domain,"[$vm_name] I can't find domain $name");
ok(!$domain->is_locked,"Domain $name should not be locked");
$USER->mark_all_messages_read();
$domain->_vm->disconnect();
ok(!$domain->_vm->vm) or exit;
return $domain;
}
......@@ -147,71 +129,92 @@ sub test_req_create_domain {
ok($req->status eq 'requested'
,"Status of request is ".$req->status." it should be requested");
$ravada->_process_requests_dont_fork();
$RVD_BACK->process_requests();
wait_request($req);
ok($req->status eq 'done'
,"Status of request is ".$req->status." it should be done");
ok(!$req->error,"Error ".$req->error." creating domain ".$name);
my $domain = $ravada->search_domain($name);
my $domain = $RVD_FRONT->search_domain($name);
ok($domain,"Searching for domain $name") or return;
ok($domain->name eq $name,"Expecting domain name '$name', got ".$domain->name);
ok(!$domain->is_base,"Expecting domain not base , got: ".$domain->is_base());
ok(!$domain->_vm->vm) or exit;
$domain->_vm->disconnect();
return $domain;
}
sub test_req_prepare_base {
my $vm = shift;
my $vm_name = shift;
my $name = shift;
my $domain = $vm->search_domain($name);
ok($domain, "Searching for domain $name, got ".ref($name)) or return;
ok(!$domain->is_base, "Expecting domain base=0 , got: '".$domain->is_base."'");
my $req;
{
my $vm = $RVD_FRONT->search_vm($vm_name);
my $domain = $vm->search_domain($name);
ok($domain, "Searching for domain $name, got ".ref($name)) or return;
ok(!$domain->is_base, "Expecting domain base=0 , got: '".$domain->is_base."'");
ok(!$domain->_vm->vm);
$req = Ravada::Request->prepare_base(
id_domain => $domain->id
,uid => $USER->id
);
ok($req);
ok($req->status);
ok($domain->is_locked,"Domain $name should be locked when preparing base");
}
my $req = Ravada::Request->prepare_base(
id_domain => $domain->id
,uid => $USER->id
);
ok($req);
ok($req->status);
$RVD_BACK->process_requests();
wait_request($req);
ok(!$req->error,"Expecting error='', got '".($req->error or '')."'");
ok($domain->is_locked,"Domain $name should be locked when preparing base");
wait_request($req);
$ravada->_process_requests_dont_fork();
ok(!$req->error,"Expecting error='', got '".$req->error."'");
ok($domain->is_base, "Expecting domain base=1 , got: '".$domain->is_base."'");
my $vm = $RVD_FRONT->search_vm($vm_name);
my $domain2 = $vm->search_domain($name);
ok($domain2->is_base, "Expecting domain base=1 , got: '".$domain2->is_base."'") or exit;
ok(!$domain2->_vm->vm) or exit;
}
sub test_req_create_from_base {
my $vm = shift;
my $vm_name = shift;
my $domain_base = shift;
diag("create from base");
my $clone_name = new_domain_name();
my $req = Ravada::Request->create_domain(
name => $clone_name
, vm => $vm->name
, vm => $vm_name
, id_base => $domain_base->id
, id_owner => $USER->id
);
ok($req->status eq 'requested'
,"Status of request is ".$req->status." it should be requested");
$ravada->_process_requests_dont_fork();
$RVD_BACK->process_requests(1);
wait_request($req);
ok($req->status eq 'done'
,"Status of request is ".$req->status." it should be done");
ok(!$req->error,"Error ".$req->error." creating domain ".$clone_name);
my $domain = $ravada->search_domain($clone_name);
my $domain = $RVD_FRONT->search_domain($clone_name);
ok($domain,"Searching for domain $clone_name") or return;
ok($domain->name eq $clone_name
,"Expecting domain name '$clone_name', got ".$domain->name);
ok(!$domain->is_base,"Expecting domain not base , got: ".$domain->is_base());