Skip to content
GitLab
Commit b52afc11 authored by Francesc Guasch's avatar Francesc Guasch
Browse files

Merge branch 'develop' of https://github.com/UPC/ravada into develop

parents d49cad69 16750ee5
Expand all Hide whitespace changes
Inline Side-by-side
.gitignore
View file @ b52afc11
......@@ -6,6 +6,7 @@ blib
pm_to_blib
t/.db
t/etc/ravada_ldap*.conf
t/etc/remote_vm*.conf
hypnotoad.pid
log
rvd_front.conf
......
Makefile.PL
View file @ b52afc11
......@@ -26,6 +26,8 @@ WriteMakefile(
,'DBD::SQLite' => 0
,'IPTables::ChainMgr' => 0
,'Net::DNS' => 0
,'Net::SSH2' => 0
,'File::Rsync' => 0
},
BUILD_REQUIRES => {
'Test::SQL::Data' => 0
......@@ -33,6 +35,6 @@ WriteMakefile(
},
test => {TESTS => 't/*.t t/*/*.t'},
clean => {FILES => 't/.db' }
clean => {FILES => ['t/.db', '/var/tmp/rvd_void'] }
);
bin/rvd_back.pl
View file @ b52afc11
......@@ -53,7 +53,7 @@ my $USAGE = "$0 "
." --import-domain-owner : owner of the domain to import\n"
." --make-admin : make user admin\n"
." --config : config file, defaults to $FILE_CONFIG_DEFAULT"
." -X : start in foreground\n"
." --no-fork : start in foreground\n"
." --url-isos=(URL|default)\n"
." --import-vbox : import a VirtualBox image\n"
."\n"
......@@ -174,10 +174,14 @@ sub start {
$Ravada::CONNECTOR->dbh;
for my $vm (@{$ravada->vm}) {
$vm->id;
$vm->vm;
$vm->vm if $vm->ping;
}
}
for (;;) {
if ($NOFORK ) {
do_start();
next;
}
my $pid = fork();
die "I can't fork $!" if !defined $pid;
if ($pid == 0 ) {
......
lib/Ravada.pm
View file @ b52afc11
......@@ -80,7 +80,7 @@ $DIR_SQL = "/usr/share/doc/ravada/sql/mysql" if ! -e $DIR_SQL;
# LONG commands take long
our %HUGE_COMMAND = map { $_ => 1 } qw(download);
our %LONG_COMMAND = map { $_ => 1 } (qw(prepare_base remove_base screenshot ), keys %HUGE_COMMAND);
our %LONG_COMMAND = map { $_ => 1 } (qw(prepare_base remove_base screenshot set_base_vm ), keys %HUGE_COMMAND);
our $USER_DAEMON;
our $USER_DAEMON_NAME = 'daemon';
......@@ -400,6 +400,12 @@ sub _update_domain_drivers_types($self) {
}
};
$self->_update_table('domain_drivers_types','id',$data);
my $sth = $CONNECTOR->dbh->prepare(
"UPDATE domain_drivers_types SET vm='KVM' WHERE vm='qemu'"
);
$sth->execute;
$sth->finish;
}
sub _update_domain_drivers_options($self) {
......@@ -683,7 +689,7 @@ sub _create_table {
$sth->finish;
return if keys %$info;
warn "INFO: creating table $table\n";
warn "INFO: creating table $table\n" if $0 !~ /\.t$/;
my $file_sql = "$DIR_SQL/$table.sql";
open my $in,'<',$file_sql or die "$! $file_sql";
my $sql = join " ",<$in>;
......@@ -748,8 +754,13 @@ sub _upgrade_tables {
$self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
$self->_upgrade_table('vms','connection_args',"text DEFAULT NULL");
$self->_upgrade_table('vms','cached_active_time',"integer DEFAULT 0");
$self->_upgrade_table('vms','public_ip',"varchar(128) DEFAULT NULL");
$self->_upgrade_table('vms','is_active',"int DEFAULT 0");
$self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
$self->_upgrade_table('requests','pid','int(11) DEFAULT NULL');
$self->_upgrade_table('requests','start_time','int(11) DEFAULT NULL');
$self->_upgrade_table('iso_images','rename_file','varchar(80) DEFAULT NULL');
$self->_clean_iso_mini();
......@@ -773,11 +784,18 @@ sub _upgrade_tables {
$self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
$self->_upgrade_table('domains','description','text DEFAULT NULL');
$self->_upgrade_table('domains','run_timeout','int DEFAULT NULL');
$self->_upgrade_table('domains','id_vm','int DEFAULT NULL');
$self->_upgrade_table('domains','start_time','int DEFAULT 0');
$self->_upgrade_table('domains','is_volatile','int NOT NULL DEFAULT 0');
$self->_upgrade_table('domains','status','varchar(32) DEFAULT "shutdown"');
$self->_upgrade_table('domains','display','varchar(128) DEFAULT NULL');
$self->_upgrade_table('domains','info','varchar(255) DEFAULT NULL');
$self->_upgrade_table('domains_network','allowed','int not null default 1');
$self->_upgrade_table('iptables','id_vm','int DEFAULT NULL');
$self->_upgrade_table('vms','security','varchar(255) default NULL');
}
......@@ -945,13 +963,30 @@ sub _create_vm {
for my $vm_name (keys %VALID_VM) {
my $vm;
eval { $vm = $create{$vm_name}->($self) };
warn $@ if $@;
$err.= $@ if $@;
push @vms,($vm) if $vm;
push @vms,$vm if $vm;
}
die "No VMs found: $err\n" if $self->warn_error && !@vms;
return \@vms;
return [@vms, $self->_list_remote_vms];
}
sub _list_remote_vms($self ) {
my $sth = $CONNECTOR->dbh->prepare("SELECT * FROM vms WHERE hostname <> 'localhost'");
$sth->execute;
my @vms;
while ( my $row = $sth->fetchrow_hashref) {
my $vm;
eval { $vm = Ravada::VM->open( $row->{id}) };
push @vms,( $vm ) if $vm;
}
$sth->finish;
return @vms;
}
sub _check_vms {
......@@ -1021,7 +1056,7 @@ sub create_domain {
my $domain;
eval { $domain = $vm->create_domain(@_) };
my $error = $@;
$request->error($error) if $error;
$request->error($error) if $request && $error;
if ($error =~ /has \d+ requests/) {
$request->status('retry');
}
......@@ -1061,7 +1096,37 @@ sub remove_domain {
=cut
sub search_domain {
sub search_domain($self, $name, $import = 0) {
my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_vm "
." FROM domains WHERE name=?");
$sth->execute($name);
my ($id, $id_vm) = $sth->fetchrow();
if ($id_vm) {
my $vm = Ravada::VM->open($id_vm);
if (!$vm->is_active) {
warn "Don't search domain $name in inactive VM ".$vm->name;
$vm->disconnect();
} else {
return $vm->search_domain($name);
}
}
for my $vm (@{$self->vm}) {
next if !$vm->is_active;
my $domain = $vm->search_domain($name, $import);
next if !$domain;
next if !$domain->_select_domain_db && !$import;
my $id_domain;
eval { $id_domain = $domain->id };
next if !$id_domain && !$import;
return $domain if $domain->is_active;
}
return if !$id;
return Ravada::Domain->open($id);
}
sub _search_domain {
my $self = shift;
my $name = shift;
my $import = shift;
......@@ -1086,7 +1151,10 @@ sub search_domain {
eval { $id = $domain->id };
# TODO import the domain in the database with an _insert_db or something
warn $@ if $@ && $DEBUG;
return $domain if $id || $import;
next if !$id && !$import;
$domain->_vm($domain->last_vm()) if $id && $domain->last_vm;
return $domain;
}
......@@ -1369,6 +1437,7 @@ sub process_requests {
my $short_commands = (shift or 0);
$self->_wait_pids_nohang();
$self->_kill_stale_process();
my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
." WHERE "
......@@ -1391,7 +1460,8 @@ sub process_requests {
||(!$long_commands && $LONG_COMMAND{$req->command})
) {
warn "[$debug_type,$long_commands,$short_commands] $$ skipping request "
.$req->command if $DEBUG;
.$req->command
if $debug || $DEBUG;
next;
}
next if $req->command !~ /shutdown/i
......@@ -1405,14 +1475,7 @@ sub process_requests {
$n_retry = 0 if !$n_retry;
my $err = $self->_execute($req, $dont_fork);
$req->error($err) if $err;
if ($err && $err =~ /libvirt error code: 38/) {
if ( $n_retry < 3) {
warn $req->id." ".$req->command." to retry" if $DEBUG;
$req->status("retry ".++$n_retry)
} else {
$req->status("done");
}
}
# $req->status("done") if $req->status() !~ /retry/;
next if !$DEBUG && !$debug;
sleep 1;
......@@ -1434,7 +1497,6 @@ sub process_long_requests {
my $self = shift;
my ($debug,$dont_fork) = @_;
$self->_disconnect_vm();
return $self->process_requests($debug, $dont_fork, 1);
}
......@@ -1453,6 +1515,24 @@ sub process_all_requests {
}
sub _kill_stale_process($self) {
my $sth = $CONNECTOR->dbh->prepare(
"SELECT pid,command,start_time "
." FROM requests "
." WHERE start_time<? "
." AND command = 'refresh_vms'"
." AND status <> 'done' "
." AND pid IS NOT NULL "
);
$sth->execute(time - 60 );
while (my ($pid, $command, $start_time) = $sth->fetchrow) {
warn "Killing $command stale for ".time - $start_time." seconds\n";
kill (15,$pid);
}
$sth->finish;
}
sub _domain_working {
my $self = shift;
my ($id_domain, $id_request) = @_;
......@@ -1523,6 +1603,8 @@ sub _execute {
confess "Unknown command ".$request->command
if !$sub;
$request->pid($$);
$request->start_time(time);
$request->error('');
if ($dont_fork || !$CAN_FORK || !$LONG_COMMAND{$request->command}) {
......@@ -1538,11 +1620,13 @@ sub _execute {
return if $self->_wait_children($request);
$request->status('working');
warn $request->command." forking";
my $pid = fork();
die "I can't fork" if !defined $pid;
if ( $pid == 0 ) {
$self->_do_execute_command($sub, $request)
$self->_do_execute_command($sub, $request);
} else {
$request->pid($pid);
$self->_add_pid($pid, $request->id);
}
# $self->_connect_vm_kvm();
......@@ -2036,6 +2120,94 @@ sub _cmd_refresh_storage($self, $request) {
$vm->refresh_storage();
}
sub _cmd_refresh_vms($self, $request=undef) {
my ($active_domain, $active_vm) = $self->_refresh_active_domains($request);
$self->_refresh_down_domains($active_domain, $active_vm);
}
sub _refresh_active_domains($self, $request=undef) {
my $id_domain;
$id_domain = $request->defined_arg('id_domain') if $request;
my %active_domain;
my %active_vm;
for my $vm ($self->list_vms) {
if ( !$vm->is_active ) {
$active_vm{$vm->id} = 0;
$vm->disconnect();
next;
}
$active_vm{$vm->id} = 1;
if ($id_domain) {
my $domain = $vm->search_domain_by_id($id_domain);
$self->_refresh_active_domain($vm, $domain, \%active_domain) if $domain;
} else {
for my $domain ($vm->list_domains( active => 1)) {
next if $active_domain{$domain->id};
$self->_refresh_active_domain($vm, $domain, \%active_domain);
}
}
}
return \%active_domain, \%active_vm;
}
sub _refresh_active_domain($self, $vm, $domain, $active_domain) {
my $is_active = $domain->is_active();
my $status = 'shutdown';
if ( $is_active ) {
$status = 'active';
$domain->_data(id_vm => $vm->id) if $domain->_data('id_vm') != $vm->id;
}
$domain->_set_data(status => $status);
$active_domain->{$domain->id} = $is_active;
}
sub _refresh_down_domains($self, $active_domain, $active_vm) {
my $sth = $CONNECTOR->dbh->prepare(
"SELECT id, name, id_vm FROM domains WHERE status='active'"
);
$sth->execute();
while ( my ($id_domain, $name, $id_vm) = $sth->fetchrow ) {
next if exists $active_domain->{$id_domain};
my $domain = Ravada::Domain->open($id_domain);
if (defined $id_vm && !$active_vm->{$id_vm}) {
$domain->_set_data(status => 'shutdown');
} else {
my $status = 'down';
$status = 'active' if $domain->is_active;
$domain->_set_data(status => $status);
}
}
}
sub _cmd_set_base_vm {
my $self = shift;
my $request = shift;
my $value = $request->args('value');
die "ERROR: Missing value" if !defined $value;
my $uid = $request->args('uid') or die "ERROR: Missing uid";
my $id_vm = $request->args('id_vm') or die "ERROR: Missing id_vm";
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);
die "USER $uid not authorized to set base vm"
if !$user->is_admin;
$domain->set_base_vm(
id_vm => $id_vm
,user => $user
,value => $value
,request => $request
);
}
sub _req_method {
my $self = shift;
my $cmd = shift;
......@@ -2056,6 +2228,7 @@ sub _req_method {
,screenshot => \&_cmd_screenshot
,copy_screenshot => \&_cmd_copy_screenshot
,remove_base => \&_cmd_remove_base
,set_base_vm => \&_cmd_set_base_vm
,ping_backend => \&_cmd_ping_backend
,prepare_base => \&_cmd_prepare_base
,rename_domain => \&_cmd_rename_domain
......@@ -2063,6 +2236,7 @@ sub _req_method {
,list_vm_types => \&_cmd_list_vm_types
,force_shutdown => \&_cmd_force_shutdown
,refresh_storage => \&_cmd_refresh_storage
,refresh_vms => \&_cmd_refresh_vms
);
return $methods{$cmd};
......@@ -2092,13 +2266,14 @@ Searches for a VM of a given type
sub search_vm {
my $self = shift;
my $type = shift;
my $host = (shift or 'localhost');
confess "Missing VM type" if !$type;
my $class = 'Ravada::VM::'.uc($type);
if ($type =~ /Void/i) {
return Ravada::VM::Void->new();
return Ravada::VM::Void->new(host => $host);
}
my @vms;
......@@ -2107,7 +2282,7 @@ sub search_vm {
die $@ if $@;
for my $vm (@vms) {
return $vm if ref($vm) eq $class;
return $vm if ref($vm) eq $class && $vm->host eq $host;
}
return;
}
......
lib/Ravada/Domain.pm
View file @ b52afc11
This diff is collapsed.
lib/Ravada/Domain/KVM.pm
View file @ b52afc11
......@@ -16,7 +16,6 @@ use File::Path qw(make_path);
use Hash::Util qw(lock_keys);
use IPC::Run3 qw(run3);
use Moose;
use Sys::Virt::Stream;
use XML::LibXML;
no warnings "experimental::signatures";
......@@ -31,7 +30,7 @@ has 'domain' => (
);
has '_vm' => (
is => 'ro'
is => 'rw'
,isa => 'Ravada::VM::KVM'
,required => 0
);
......@@ -89,7 +88,13 @@ sub list_disks {
my $self = shift;
my @disks = ();
my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description);
my $doc = $self->{_doc};
if (!$doc) {
$doc = XML::LibXML->load_xml(string
=> $self->domain->get_xml_description);
$self->{_doc} = $doc;
}
for my $disk ($doc->findnodes('/domain/devices/disk')) {
next if $disk->getAttribute('device') ne 'disk';
......@@ -115,7 +120,7 @@ sub remove_disks {
my $removed = 0;
return if !$self->is_known();
return if !$self->is_known();# || $self->is_removed;
my $id;
eval { $id = $self->id };
......@@ -124,15 +129,11 @@ sub remove_disks {
$self->_vm->connect();
for my $file ($self->list_disks) {
if (! -e $file ) {
warn "WARNING: $file already removed for ".$self->domain->get_name."\n"
if $0 !~ /.t$/;
next;
}
$self->_vol_remove($file);
if ( -e $file ) {
unlink $file or die "$! $file";
}
$self->_vol_remove($file);
# if ( -e $file ) {
# unlink $file or die "$! $file";
# }
$removed++;
}
......@@ -153,7 +154,9 @@ Cleanup operations executed before removing this domain
sub pre_remove_domain {
my $self = shift;
warn "Domain::KVM - pre_remove domain 1";
$self->domain->managed_save_remove() if $self->domain->has_managed_save_image;
warn "Domain::KVM - pre_remove domain 2";
}
sub _vol_remove {
......@@ -164,10 +167,18 @@ sub _vol_remove {
my $name;
($name) = $file =~ m{.*/(.*)} if $file =~ m{/};
#TODO: do a remove_volume in the VM
my @vols = $self->_vm->storage_pool->list_volumes();
for my $vol ( @vols ) {
$vol->delete() if$vol->get_name eq $name;
my $removed = 0;
for my $pool ( $self->_vm->vm->list_storage_pools ) {
$pool->refresh;
my $vol;
eval { $vol = $pool->get_volume_by_name($name) };
if (! $vol ) {
warn "VOLUME $name not found in $pool \n".($@ or '')
if $@ !~ /libvirt error code: 50,/i;
next;
}
$vol->delete();
$pool->refresh;
}
return 1;
}
......@@ -182,14 +193,18 @@ sub remove {
my $self = shift;
my $user = shift;
if (!$self->is_removed ) {
$self->list_disks();
}
if ($self->domain->is_active) {
$self->_do_force_shutdown();
}
eval { $self->remove_disks(); };
eval { $self->domain->undefine() };
die $@ if $@ && $@ !~ /libvirt error code: 42/;
# warn "WARNING: Problem removing disks for ".$self->name." : $@" if $@ && $0 !~ /\.t$/;
$self->remove_disks();
eval { $self->_remove_file_image() };
die $@ if $@ && $@ !~ /libvirt error code: 42/;
......@@ -198,8 +213,6 @@ sub remove {
# warn "WARNING: Problem removing ".$self->file_base_img." for ".$self->name
# ." , I will try again later : $@" if $@;
eval { $self->domain->undefine() };
die $@ if $@ && $@ !~ /libvirt error code: 42/;
}
......@@ -461,8 +474,7 @@ Returns the display URI
=cut
sub display {
my $self = shift;
sub display($self, $user) {
my $xml = XML::LibXML->load_xml(string => $self->domain->get_xml_description);
my ($graph) = $xml->findnodes('/domain/devices/graphics')
......@@ -472,8 +484,9 @@ sub display {
my ($port) = $graph->getAttribute('port');
my ($address) = $graph->getAttribute('listen');
die "Unable to get port for domain ".$self->name." ".$graph->toString
if !$port;
if ( !$port ) {
$port = '';
}
return "$type://$address:$port";
}
......@@ -502,16 +515,25 @@ sub start {
if (!(scalar(@_) % 2)) {
%arg = @_;
}
my $remote_ip = delete $arg{remote_ip};
$self->_set_spice_settings($remote_ip);
# $self->domain($self->_vm->vm->get_domain_by_name($self->domain->get_name));
$self->domain->create();
}
my $set_password=0;
my $remote_ip = $arg{remote_ip};
sub _set_spice_settings($self, $remote_ip=undef) {
# there is no point to set the password if already active
return if $self->is_active();
my $set_password=1;
if ($remote_ip) {
$set_password = 0;
my $network = Ravada::Network->new(address => $remote_ip);
$set_password = 1 if $network->requires_password();
}
$self->_set_spice_ip($set_password);
# $self->domain($self->_vm->vm->get_domain_by_name($self->domain->get_name));
$self->domain->create();
}
sub _pre_shutdown_domain {
......@@ -585,7 +607,7 @@ sub force_shutdown{
sub _do_force_shutdown {
my $self = shift;
return $self->domain->destroy;
return $self->domain->destroy if $self->domain->is_active;
}
......@@ -1173,15 +1195,13 @@ sub spinoff_volumes {
}
sub _set_spice_ip {
my $self = shift;
my $set_password = shift;
sub _set_spice_ip($self, $set_password, $ip=undef) {
my $doc = XML::LibXML->load_xml(string
=> $self->domain->get_xml_description) ;
=> $self->domain->get_xml_description);
my @graphics = $doc->findnodes('/domain/devices/graphics');