Unverified Commit 35377cca authored by Francesc Guasch's avatar Francesc Guasch Committed by GitHub
Browse files

Feature nested bases (#1456)

feature(frontend): show nested bases

* test: validate HTML
* refactor(frontend): fixed most of the HTML templates
* refactor(grants): disable only those that should be


Thanks to @amparorvd
parent 9b1966cd
......@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libencode-locale-perl, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libencode-locale-perl, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl, libguestfs-tools
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
......@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-bin,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libencode-locale-perl, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-bin,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libencode-locale-perl, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl, libguestfs-tools
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
......@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl, libguestfs-tools
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
......@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-openssh-perl, bridge-utils, libpbkdf2-tiny-perl, libdatetime-format-dateparse-perl, libguestfs-tools
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
......@@ -1112,10 +1112,6 @@ sub _enable_grants($self) {
return if $self->_null_grants();
my $sth = $CONNECTOR->dbh->prepare(
"UPDATE grant_types set enabled=0"
);
$sth->execute;
my @grants = (
'change_settings', 'change_settings_all', 'change_settings_clones'
,'clone', 'clone_all', 'create_base', 'create_machine'
......@@ -1130,7 +1126,7 @@ sub _enable_grants($self) {
,'start_many'
);
$sth = $CONNECTOR->dbh->prepare("SELECT id,name FROM grant_types");
my $sth = $CONNECTOR->dbh->prepare("SELECT id,name FROM grant_types");
$sth->execute;
my %grant_exists;
while (my ($id, $name) = $sth->fetchrow ) {
......@@ -1150,7 +1146,14 @@ sub _enable_grants($self) {
$sth->execute($name);
}
$self->_disable_other_grants(@grants);
}
sub _disable_other_grants($self, @grants) {
my $query = "UPDATE grant_types set enabled=0 WHERE enabled=1 AND "
.join(" AND ",map { "name <> ? " } @grants );
my $sth = $CONNECTOR->dbh->prepare($query);
$sth->execute(@grants);
}
sub _update_old_qemus($self) {
......@@ -2135,16 +2138,8 @@ sub _search_domain {
=cut
sub search_domain_by_id {
my $self = shift;
my $id = shift or confess "ERROR: missing argument id";
my $sth = $CONNECTOR->dbh->prepare("SELECT name FROM domains WHERE id=?");
$sth->execute($id);
my ($name) = $sth->fetchrow;
confess "Unknown domain id=$id" if !$name;
return $self->search_domain($name);
sub search_domain_by_id($self, $id) {
return Ravada::Domain->open($id);
}
=head2 list_vms
......@@ -2771,7 +2766,7 @@ sub _do_execute_command {
my $err = ( $@ or '');
my $elapsed = tv_interval($t0,[gettimeofday]);
$request->run_time($elapsed);
$request->error($err) if $err;
$request->error(''.$err) if $err;
if ($err) {
my $user = $request->defined_arg('user');
if ($user) {
......@@ -3195,7 +3190,7 @@ sub _cmd_start {
my $domain;
$domain = $self->search_domain($name) if $name;
$domain = $self->search_domain_by_id($id_domain) if $id_domain;
$domain = Ravada::Domain->open($id_domain) if $id_domain;
die "Unknown domain '".($name or $id_domain)."'" if !$domain;
$domain->status('starting');
......@@ -3703,6 +3698,7 @@ sub _cmd_refresh_vms($self, $request=undef) {
$self->_clean_requests('refresh_vms', $request);
$self->_refresh_volatile_domains();
$request->error('') if $request;
}
sub _cmd_shutdown_node($self, $request) {
......@@ -3826,17 +3822,24 @@ sub _cmd_purge($self, $request) {
$domain->purge($request);
}
sub _migrate_base($self, $domain, $node, $uid, $request) {
sub _migrate_base($self, $domain, $id_node, $uid, $request) {
if (ref($id_node)) {
$id_node = $id_node->id;
}
my $base = Ravada::Domain->open($domain->id_base);
return if $base->base_in_vm($node->id);
return if $base->base_in_vm($id_node);
my $req_base = Ravada::Request->set_base_vm(
id_domain => $base->id
, id_vm => $node->id
, id_vm => $id_node
, uid => $uid
, retry => 10
);
$request->after_request($req_base->id) if $req_base;
die "Base ".$base->name." still not prepared in node ".$node->name.". Retry\n";
confess "Error: no request for set_base_vm" if !$req_base;
confess "Error: same request" if $req_base->id == $request->id;
$request->retry(10) if !defined $request->retry();
$request->after_request_ok($req_base->id);
die "Base ".$base->name." still not prepared in node $id_node. Retry\n";
}
sub _cmd_migrate($self, $request) {
......@@ -3844,7 +3847,8 @@ sub _cmd_migrate($self, $request) {
my $id_domain = $request->args('id_domain') or die "ERROR: Missing id_domain";
my $user = Ravada::Auth::SQL->search_by_id($uid);
my $domain = $self->search_domain_by_id($id_domain);
my $domain = Ravada::Domain->open($id_domain)
or confess "Error: domain $id_domain not found";
die "Error: user ".$user->name." not allowed to migrate domain ".$domain->name
unless $user->is_operator;
......@@ -3863,7 +3867,7 @@ sub _cmd_migrate($self, $request) {
,id_domain => $id_domain
,@timeout
);
$request->after_request($req_shutdown->id);
$request->after_request_ok($req_shutdown->id);
$request->retry(10) if !defined $request->retry();
die "Virtual Machine ".$domain->name." ".$request->retry." is active. Shutting down. Retry.\n";
}
......@@ -3946,6 +3950,7 @@ sub _refresh_active_domains($self, $request=undef) {
my @domains;
eval { @domains = $self->list_domains_data };
warn $@ if $@;
my $t0 = time;
for my $domain_data (sort { $b->{date_changed} cmp $a->{date_changed} }
@domains) {
$request->error("checking $domain_data->{name}") if $request;
......@@ -3954,6 +3959,7 @@ sub _refresh_active_domains($self, $request=undef) {
next if !$domain;
$self->_refresh_active_domain($domain, \%active_domain);
$self->_remove_unnecessary_downs($domain) if !$domain->is_active;
last if !$CAN_FORK && time - $t0 > 10;
}
$request->error("checked ".scalar(@domains)) if $request;
}
......@@ -4107,16 +4113,19 @@ sub _cmd_set_base_vm {
# my $domain = $self->search_domain_by_id($id_domain) or confess "Error: Unknown domain id: $id_domain";
die "USER $uid not authorized to set base vm"
if !$user->is_admin;
if !$user->is_admin;
$domain->prepare_base($user) if $value && !$domain->is_base;
$self->_migrate_base($domain, $id_vm, $uid, $request) if $domain->id_base;
if ( $value && !$domain->is_base ) {
$domain->prepare_base($user);
}
$domain->set_base_vm(
id_vm => $id_vm
,user => $user
,value => $value
,request => $request
);
id_vm => $id_vm
,user => $user
,value => $value
,request => $request
);
}
sub _cmd_cleanup($self, $request) {
......
......@@ -364,13 +364,13 @@ sub _around_start($orig, $self, @arg) {
}
sub _request_set_base($self) {
sub _request_set_base($self, $id_vm=$self->_vm->id) {
my $base = Ravada::Domain->open($self->id_base);
$base->_set_base_vm_db($self->_vm->id,0);
Ravada::Request->set_base_vm(
uid => Ravada::Utils::user_daemon->id
,id_domain => $base->id
,id_vm => $self->_vm->id
,id_vm => $id_vm
);
my $vm_local = $self->_vm->new( host => 'localhost' );
$self->_set_vm($vm_local, 1);
......@@ -847,14 +847,11 @@ sub _pre_prepare_base($self, $user, $request = undef ) {
sleep 1;
}
}
$self->_post_remove_base();
# $self->_post_remove_base();
if (!$self->is_local) {
my $vm_local = Ravada::VM->open( type => $self->vm );
$self->migrate($vm_local, $request);
}
if ($self->id_base ) {
$self->spinoff();
}
$self->_check_free_space_prepare_base();
}
......@@ -879,7 +876,6 @@ sub _post_prepare_base {
$self->description($base->description) if $base->description();
}
$self->_remove_id_base();
$self->_set_base_vm_db($self->_vm->id,1);
$self->autostart(0,$user);
};
......@@ -2053,9 +2049,9 @@ sub clones($self, %filter) {
_init_connector();
my $query =
"SELECT id, id_vm, name, id_owner, status, client_status, is_pool"
"SELECT id, id_vm, name, id_owner, status, client_status, is_pool, is_base"
." FROM domains "
." WHERE id_base = ? AND (is_base=NULL OR is_base=0)";
." WHERE id_base = ? ";
my @values = ($self->id);
if (keys %filter) {
$query .= "AND ( ".join(" AND ",map { "$_ = ?" } sort keys %filter)." )";
......@@ -2322,7 +2318,7 @@ sub clone {
my %args2 = @_;
delete $args2{from_pool};
return $self->_copy_clone(%args2) if $self->id_base();
return $self->_copy_clone(%args2) if !$self->is_base && $self->id_base();
my $uid = $user->id;
......@@ -4015,9 +4011,9 @@ sub rsync($self, @args) {
next if _check_stat($file, $vm_local, $node);
my $msg = $self->_msg_log_rsync($file, $node, "rsync", $request);
$request->status("syncing") if $request;
$request->error("Syncing $file");
$request->error($msg) if $request && $DEBUG_RSYNC;
$request->status("syncing") if $request;
$request->error("Syncing $file") if $request;
$request->error($msg) if $request && $DEBUG_RSYNC;
warn "$msg\n" if $DEBUG_RSYNC;
my $t0 = time;
......@@ -4033,8 +4029,9 @@ sub rsync($self, @args) {
.Dumper($files)."\n"
.join(' ',@{$rsync->err});
}
$request->error("rsync done ".(time - $time_rsync)." seconds");
$request->error("rsync done ".(time - $time_rsync)." seconds") if $request;
$node->refresh_storage_pools();
$request->error("") if $request;
}
sub _check_stat($file, $vm1, $vm2) {
......@@ -4097,16 +4094,7 @@ sub _pre_migrate($self, $node, $request = undef) {
if !$base->base_in_vm($node->id);
confess "ERROR: base id ".$self->id_base." not found." if !$base;
for my $file ( $base->list_files_base ) {
next if $node->file_exists($file);
warn "Warning: file not found $file in ".$node->name;
Ravada::Request->set_base_vm(
uid => Ravada::Utils::user_daemon->id
,id_domain => $base->id
,id_vm => $node->id
);
return;
}
return unless $self->_check_all_parents_in_node($node);
$self->_set_base_vm_db($node->id,0) unless $node->is_local;
}
......@@ -4205,6 +4193,7 @@ sub set_base_vm($self, %args) {
$request->status("working","Preparing base") if $request;
}
} elsif ($value) {
$self->_check_all_parents_in_node($vm);
$request->status("working", "Syncing base volumes to ".$vm->host)
if $request;
eval {
......@@ -4229,9 +4218,34 @@ sub set_base_vm($self, %args) {
return $self->_set_base_vm_db($vm->id, $value);
}
sub _check_all_parents_in_node($self, $vm) {
my @bases;
my $base = $self;
for ( ;; ) {
last if !$base->id_base;
$base = Ravada::Domain->open($base->id_base);
push @bases,($base) if !$base->base_in_vm($vm->id)
|| !$base->base_files_in_vm($vm);
}
return 1 if !@bases;
my $req;
for my $base ( reverse @bases) {
$base->_set_base_vm_db($vm->id,0);
my @after_req;
@after_req = ( after_request_ok => $req->id) if $req;
$req = Ravada::Request->set_base_vm(
uid => Ravada::Utils::user_daemon->id
,id_domain => $base->id
,id_vm => $vm->id
,@after_req
);
}
return 0;
}
sub _set_clones_autostart($self, $value) {
for my $clone_data ($self->clones) {
my $clone = Ravada::Domain->open($clone_data->{id});
my $clone = Ravada::Domain->open($clone_data->{id}) or next;
$clone->_internal_autostart(0);
}
}
......@@ -4351,6 +4365,15 @@ sub base_in_vm($self,$id_vm) {
# return 1 if !defined $enabled
# && $id_vm == $self->_vm->id && $self->_vm->host eq 'localhost';
return $enabled;
}
sub base_files_in_vm($self,$vm) {
$vm = Ravada::VM->open($vm) if !ref($vm);
for my $file ($self->list_files_base) {
return 0 if !$vm->file_exists($file);
}
return 1;
}
sub _bases_vm($self) {
......@@ -5180,7 +5203,6 @@ sub rebase($self, $user, $new_base) {
}
sub _create_base_as_old($self, $user, $new_base) {
$new_base->dettach($user);
$new_base->prepare_base($user);
my $old_base = $self;
......
......@@ -498,6 +498,38 @@ sub post_prepare_base {
$self->_store_xml();
}
sub _set_backing_store($self, $disk, $backing_file) {
my ($backing_store) = $disk->findnodes('backingStore');
if ($backing_file) {
my $vol_backing_file = Ravada::Volume->new(
file => $backing_file
,vm => $self->_vm
);
my $backing_file_format = (
$vol_backing_file->_qemu_info('file format')
or 'qcow2'
);
$backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
$backing_store->setAttribute('type' => 'file');
my ($format) = $backing_store->findnodes('format');
$format = $backing_store->addNewChild(undef,'format') if !$format;
$format->setAttribute('type' => $backing_file_format);
my ($source_bf) = $backing_store->findnodes('source');
$source_bf = $backing_store->addNewChild(undef,'source') if !$source_bf;
$source_bf->setAttribute('file' => $backing_file);
my $next_backing_file = $vol_backing_file->backing_file();
$self->_set_backing_store($backing_store, $next_backing_file);
} else {
$disk->removeChild($backing_store) if $backing_store;
$backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
}
}
sub _set_volumes_backing_store($self) {
my $doc = XML::LibXML->load_xml(string
=> $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
......@@ -511,32 +543,7 @@ sub _set_volumes_backing_store($self) {
my $file = $source->getAttribute('file');
my $backing_file = $vol{$file}->backing_file();
my ($backing_store) = $disk->findnodes('backingStore');
if ($backing_file) {
my $vol_backing_file = Ravada::Volume->new(
file => $backing_file
,vm => $self->_vm
);
my $backing_file_format = (
$vol_backing_file->_qemu_info('file format')
or 'qcow2'
);
$backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
$backing_store->setAttribute('type' => 'file');
my ($format) = $backing_store->findnodes('format');
$format = $backing_store->addNewChild(undef,'format') if !$format;
$format->setAttribute('type' => $backing_file_format);
my ($source_bf) = $backing_store->findnodes('source');
$source_bf = $backing_store->addNewChild(undef,'source') if !$source_bf;
$source_bf->setAttribute('file' => $backing_file);
} else {
$disk->removeChild($backing_store) if $backing_store;
$backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
}
$self->_set_backing_store($disk, $backing_file);
}
}
......@@ -607,8 +614,7 @@ sub _detect_disks_driver($self) {
confess "Error: wrong format ".Dumper($format)." for file $file"
unless !$format || $format =~ /^\w+$/;
confess "Error: no file format for $file" if !$format;
$driver->setAttribute(type => $format);
$driver->setAttribute(type => $format) if defined $format;
}
$self->_post_change_hardware($doc);
......
......@@ -277,6 +277,7 @@ sub list_domains($self, %args) {
my $query = "SELECT d.name, d.id, id_base, is_base, id_vm, status, is_public "
." ,vms.name as node , is_volatile, client_status, id_owner "
." ,comment, is_pool"
." ,d.date_changed"
." FROM domains d LEFT JOIN vms "
." ON d.id_vm = vms.id ";
......
......@@ -54,6 +54,7 @@ sub BUILD($self, $arg) {
}
sub open($self, $id) {
confess "Error: undefined id" if !defined $id;
my $domain = Ravada::Front::Domain->new( id => $id );
if ($domain->type eq 'KVM') {
$domain = Ravada::Front::Domain::KVM->new( id => $id );
......
......@@ -185,7 +185,7 @@ our %COMMAND = (
,secondary => {
limit => 50
,priority => 4
,commands => ['shutdown','shutdown_now', 'manage_pools','enforce_limits', 'set_time']
,commands => ['shutdown','shutdown_now', 'manage_pools','enforce_limits', 'set_time', 'remove_domain']
}
,important=> {
......@@ -587,7 +587,7 @@ sub _duplicated_request($self=undef, $command=undef, $args=undef) {
my $args_found_s = join(".",map {$args_found_d->{$_} } sort keys %$args_found_d);
next if $args_d_s ne $args_found_s;
return $id;
return Ravada::Request->open($id);
}
return 0;
}
......@@ -634,11 +634,14 @@ sub _new_request {
if ($args{command} =~ /^(clone|manage_pools)$/
|| $CMD_NO_DUPLICATE{$args{command}}
|| ($no_duplicate && $args{command} =~ /^(screenshot)$/)) {
if ( _duplicated_request(undef, $args{command}, $args{args})
|| ( $args{command} ne 'clone' && done_recently(undef, 60, $args{command}))) {
# warn "Warning: duplicated request for $args{command} $args{args}";
return;
}
my $dupe = _duplicated_request(undef, $args{command}, $args{args});
return $dupe if $dupe;
my $recent;
$recent = done_recently(undef, 60, $args{command})
if $args{command} !~ /^(clone|migrate|set_base_vm)$/;
return if $recent;
}
my $sth = $$CONNECTOR->dbh->prepare(
......@@ -1258,18 +1261,19 @@ sub done_recently($self, $seconds=60,$command=undef) {
$id_req = $self->id;
$command = $self->command;
}
my $sth = $$CONNECTOR->dbh->prepare(
"SELECT id FROM requests"
my $query = "SELECT id FROM requests"
." WHERE date_changed > ? "
." AND command = ? "
." AND ( status = 'done' OR status ='working') "
." AND error = '' "
." AND id <> ? "
);
." AND id <> ? ";
my $sth = $$CONNECTOR->dbh->prepare( $query );
my $date= Time::Piece->localtime(time - $seconds);
$sth->execute($date->ymd." ".$date->hms, $command, $id_req);
my ($id) = $sth->fetchrow;
return $id;
return if !defined $id;
return Ravada::Request->open($id);
}
sub _requested($command, %fields) {
......@@ -1355,7 +1359,7 @@ sub requirements_done($self) {
$self->status('done');
$self->error($req->error);
}
$ok = 1 if $req->status eq 'done' && $req->error eq '';
$ok = 1 if $req->status eq 'done' && ( !defined $req->error || $req->error eq '' );
}
return $ok;
}
......@@ -1394,6 +1398,7 @@ sub AUTOLOAD {
confess "ERROR: field $name is read only"
if $FIELD_RO{$name};
confess "Error: $name can't be a ref ".Dumper($value) if ref($value);
my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set $name=? "
." WHERE id=?");
eval {
......
......@@ -160,7 +160,10 @@ sub base_filename($self) {
$dir = $self->vm->dir_base($self->capacity) if $self->vm;
$name =~ s{\.(SWAP|DATA|TMP)}{};
$name = $self->domain->name if $self->domain;
$extra .= "-".$self->info->{target} if $self->info->{target};
if ( $self->info->{target} ) {
$name .="-" unless $name =~ /-$/ || $extra =~ /^-/;
$extra .= $self->info->{target};
}
my $base_img = "$dir/$name$extra.".$self->base_extension;
......
......@@ -36,7 +36,7 @@ sub prepare_base($self) {
};
confess $@ if $@;
@cmd = _cmd_copy($file_img, $base_img)
if $format && $format eq 'qcow2' && !$self->backing_file;
if $format && $format eq 'qcow2';# && !$self->backing_file;
my ($out, $err) = $self->vm->run_command( @cmd );
warn $out if $out;
......
......@@ -26,9 +26,11 @@ has ravada => (
my %SUB = (
list_alerts => \&_list_alerts
,list_bases => \&_list_bases
,list_isos => \&_list_isos
,list_nodes => \&_list_nodes
,list_machines => \&_list_machines
,list_machines_tree => \&_list_machines_tree
,list_machines_user => \&_list_machines_user
,list_bases_anonymous => \&_list_bases_anonymous
,list_requests => \&_list_requests
......@@ -40,6 +42,7 @@ my %SUB = (
our %TABLE_CHANNEL = (
list_alerts => 'messages'
,list_machines => 'domains'
,list_machines_tree => 'domains'
,list_requests => 'requests'
);
......@@ -74,6 +77,20 @@ sub _list_alerts($rvd, $args) {
return [@ret2,@ret];
}
sub _list_bases($rvd, $args) {
my $domains = $rvd->list_bases();
my $login = $args->{login} or die "Error: no login arg ".Dumper($args);
my $user = Ravada::Auth::SQL->new(name => $login) or die "Error: uknown user $login";
my @domains_show = @$domains;
if (!$user->is_admin) {