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

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

parents 78909ddd 47944c83
Hide whitespace changes
Inline Side-by-side
Makefile.PL
View file @ b9f28f4a
......@@ -19,6 +19,7 @@ WriteMakefile(
,'XML::LibXML'=> 0
,'YAML' => 0
,'Image::Magick' => 0
,'IO::Scalar' => 0
,'MooseX::Types::NetAddr::IP' => 0
,'IO::Interface' => 0
,'Sys::Statistics::Linux' => 0
......
bin/rvd_back.pl
View file @ b9f28f4a
......@@ -48,6 +48,7 @@ my $HIBERNATE_DOMAIN;
my $START_DOMAIN;
my $SHUTDOWN_DOMAIN;
my $REBASE;
my $RUN_REQUEST;
my $IMPORT_DOMAIN_OWNER;
......@@ -116,6 +117,7 @@ GetOptions ( help => \$help
,'import-domain-owner=s' => \$IMPORT_DOMAIN_OWNER
,'add-locale-repository=s' => \$ADD_LOCALE_REPOSITORY
,'run-request=s' => \$RUN_REQUEST
) or exit;
$START = 1 if $DEBUG || $FILE_CONFIG || $NOFORK;
......@@ -173,6 +175,8 @@ sub do_start {
$ravada->process_long_requests();
$ravada->process_requests();
exit if done_request();
if ( time - $t_refresh > 60 ) {
Ravada::Request->cleanup();
Ravada::Request->refresh_vms() if rand(5)<3;
......@@ -185,6 +189,16 @@ sub do_start {
}
sub done_request {
return 0 if !$RUN_REQUEST;
my $req;
eval { $req = Ravada::Request->open($RUN_REQUEST) };
warn $req->status;
warn $@ if $@;
return 1 if !$req || $req->status eq 'done';
}
sub clean_old_requests {
my $ravada = Ravada->new( %CONFIG );
$ravada->clean_old_requests();
......@@ -204,6 +218,7 @@ sub start {
for (;;) {
eval { do_start() };
warn $@ if $@;
exit if done_request();
}
}
......
debian/control-debian-10
View file @ b9f28f4a
......@@ -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,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-ssh2-perl, bridge-utils
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-ssh2-perl, bridge-utils
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
debian/control-ubuntu-18.04
View file @ b9f28f4a
......@@ -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,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-ssh2-perl, bridge-utils
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-ssh2-perl, bridge-utils
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
debian/control-ubuntu-19.04
View file @ b9f28f4a
......@@ -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,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-ssh2-perl, bridge-utils
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-ssh2-perl, bridge-utils
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
lib/Ravada.pm
View file @ b9f28f4a
......@@ -2548,22 +2548,35 @@ sub _can_fork {
warn $msg if $DEBUG;
$req->error($msg);
$req->at_time(time+10);
$req->status('waiting') if $req->status() !~ 'waiting';
return 0;
}
sub _wait_pids {
my $self = shift;
my @done;
for my $type ( keys %{$self->{pids}} ) {
for my $pid ( keys %{$self->{pids}->{$type}}) {
my $kid = waitpid($pid , WNOHANG);
last if $kid <= 0 ;
my $request = Ravada::Request->open($self->{pids}->{$type}->{$kid});
if ($request) {
$request->status('done') if $request->status =~ /working/i;
};
delete $self->{pids}->{$type}->{$kid};
push @done, ($kid);
}
}
return if !@done;
for my $pid (@done) {
my $id_req;
for my $type ( keys %{$self->{pids}} ) {
$id_req = $self->{pids}->{$type}->{$pid} if exists $self->{pids}->{$type}->{$pid};
next if !$id_req;
delete $self->{pids}->{$type}->{$pid};
last;
}
next if !$id_req;
my $request = Ravada::Request->open($id_req);
if ($request) {
$request->status('done') if $request->status =~ /working/i;
};
}
}
......@@ -3069,6 +3082,7 @@ sub _cmd_refresh_machine($self, $request) {
my $id_domain = $request->args('id_domain');
my $user = Ravada::Auth::SQL->search_by_id($request->args('uid'));
my $domain = Ravada::Domain->open($id_domain) or confess "Error: domain $id_domain not found";
$domain->check_status();
$domain->list_volumes_info();
$domain->info($user);
$self->_remove_unnecessary_downs($domain);
......@@ -3295,6 +3309,7 @@ sub _refresh_disabled_nodes($self, $request = undef ) {
}
sub _refresh_active_domain($self, $domain, $active_domain) {
$domain->check_status();
return if $domain->is_hibernated();
my $is_active = $domain->is_active();
......
lib/Ravada/Domain.pm
View file @ b9f28f4a
......@@ -1073,14 +1073,15 @@ sub open($class, @args) {
$domain = $vm->search_domain($row->{name}, $force) or return;
$domain->_data(id_vm => $vm->id);
}
if (!$id_vm) {
$domain->_search_already_started() if !$domain->is_base;
$domain->_check_clean_shutdown() if $domain->domain && !$domain->is_active;
}
$domain->_insert_db_extra() if $domain && !$domain->is_known_extra();
return $domain;
}
sub check_status($self) {
$self->_search_already_started() if !$self->is_base;
$self->_check_clean_shutdown() if $self->domain;
}
=head2 is_known
Returns if the domain is known in Ravada.
......@@ -1448,6 +1449,8 @@ sub _pre_remove_domain($self, $user, @) {
}
# check the node is active
# search the domain in another node if it is not
sub _check_active_node($self) {
return $self->_vm if $self->_vm->is_active(1);
......@@ -1455,7 +1458,9 @@ sub _check_active_node($self) {
next if !$node->is_local;
$self->_vm($node);
$self->domain($node->search_domain_by_id($self->id)->domain);
my $domain_active = $node->search_domain_by_id($self->id);
next if !$domain_active;
$self->domain($domain_active->domain);
last;
}
return $self->_vm;
......@@ -2015,7 +2020,6 @@ sub _pre_shutdown {
$self->_allow_shutdown(@_);
$self->_vm->connect;
$self->_pre_shutdown_domain();
if ($self->is_paused) {
......@@ -3469,6 +3473,7 @@ sub _pre_migrate($self, $node, $request = undef) {
return if !$self->id_base;
$self->check_status();
confess "ERROR: Active domains can't be migrated" if $self->is_active;
my $base = Ravada::Domain->open($self->id_base);
......
lib/Ravada/VM.pm
View file @ b9f28f4a
......@@ -9,7 +9,7 @@ Ravada::VM - Virtual Managers library for Ravada
=cut
use Carp qw( carp croak cluck);
use Carp qw( carp confess croak cluck);
use Data::Dumper;
use File::Path qw(make_path);
use Hash::Util qw(lock_hash);
......@@ -20,6 +20,7 @@ use Moose::Role;
use Net::DNS;
use Net::Ping;
use Net::SSH2 qw(LIBSSH2_FLAG_SIGPIPE);
use IO::Scalar;
use IO::Socket;
use IO::Interface;
use Net::Domain qw(hostfqdn);
......@@ -305,7 +306,6 @@ sub _connect_ssh($self, $disconnect=0) {
warn $self->name." readonly, don't do ssh";
return;
}
return if !$self->ping();
my @pwd = getpwuid($>);
my $home = $pwd[7];
......@@ -314,6 +314,7 @@ sub _connect_ssh($self, $disconnect=0) {
$ssh = $SSH{$self->host} if exists $SSH{$self->host};
if (! $ssh || $disconnect ) {
return if !$self->ping();
$ssh->disconnect if $ssh && $disconnect;
$ssh = Net::SSH2->new( timeout => $SSH_TIMEOUT );
my $connect;
......@@ -1000,10 +1001,33 @@ sub ping($self, $option=undef) {
confess "ERROR: option unknown" if defined $option && $option ne 'debug';
return 1 if $self->is_local();
my $cache_key = "ping_".$self->host;
my $ping = $self->_get_cache($cache_key);
return $ping if defined $ping;
my $debug = 0;
$debug = 1 if defined $option && $option eq 'debug';
return $self->_do_ping($self->host, $debug);
$ping = $self->_do_ping($self->host, $debug);
$self->_set_cache($cache_key => $ping);
return $ping;
}
sub _set_cache($self, $key, $value) {
$key = "_cache_$key";
$self->{$key} = [ $value, time ];
}
sub _get_cache($self, $key, $timeout=30) {
$key = "_cache_$key";
return if !exists $self->{$key};
my ($value, $time) = @{$self->{$key}};
if ( time - $time > $timeout ) {
delete $self->{$key};
return ;
}
return $value;
}
sub _do_ping($self, $host, $debug=0) {
......@@ -1202,9 +1226,14 @@ sub _write_file_local( $self, $file, $contents ) {
sub read_file( $self, $file ) {
return $self->_read_file_local($file) if $self->is_local;
my ($content, $err) = $self->run_command("cat $file");
confess $err if $err;
return $content;
my $ssh = ($self->{_ssh} or $self->_connect_ssh());
die "Error: no ssh connection to ".$self->name if ! $ssh;
my $data = '';
my $io = IO::Scalar->new(\$data);
my $ok = $ssh->scp_get($file, $io);
return $data;
}
sub _read_file_local( $self, $file ) {
......@@ -1215,18 +1244,13 @@ sub _read_file_local( $self, $file ) {
sub file_exists( $self, $file ) {
return -e $file if $self->is_local;
# why should we force disconnect before ?
$self->_connect_ssh();
my ( $out, $err) = $self->run_command("/usr/bin/test",
"-e $file ; echo \$?");
chomp $out;
chomp $err;
my $ssh = ($self->{_ssh} or $self->_connect_ssh());
die "Error: no ssh connection to ".$self->name if ! $ssh;
warn $self->name." ".$err if $err;
my $io = IO::Scalar->new();
my $ok = $ssh->scp_get($file, $io);
return 1 if $out =~ /^0$/;
return 0;
return $ok;
}
sub remove_file( $self, $file ) {
......@@ -1416,24 +1440,44 @@ sub shutdown_domains($self) {
$sth->finish;
}
sub _shared_storage_cache($self, $node, $dir, $value=undef) {
if (!defined $value) {
my $sth = $$CONNECTOR->dbh->prepare(
"SELECT is_shared FROM storage_nodes "
." WHERE dir= ? "
." AND ((id_node1 = ? AND id_node2 = ? ) "
." OR (id_node2 = ? AND id_node1 = ? )) "
);
$sth->execute($dir, $self->id, $node->id, $node->id, $self->id);
my ($is_shared) = $sth->fetchrow;
return $is_shared;
}
my $sth = $$CONNECTOR->dbh->prepare(
"INSERT INTO storage_nodes (id_node1, id_node2, dir, is_shared) "
." VALUES (?,?,?,?)"
);
$sth->execute($self->id, $node->id, $dir, $value);
return $value;
}
sub shared_storage($self, $node, $dir) {
$dir .= '/' if $dir !~ m{/$};
my $shared_cache = $self->_shared_storage_cache($node, $dir);
return $shared_cache if defined $shared_cache;
return if !$node->is_active || !$self->is_active;
my $cached_st_key = "_cached_shared_storage_".$self->name.$node->name.$dir;
$cached_st_key =~ s{/}{_}g;
return $self->{$cached_st_key} if exists $self->{$cached_st_key};
$dir .= '/' if $dir !~ m{/$};
my $file;
for ( ;; ) {
$file = $dir.Ravada::Utils::random_name(4).".tmp";
my $exists;
eval {
next if $self->file_exists($file);
next if $node->file_exists($file);
$exists = $self->file_exists($file) || $node->file_exists($file);
};
next if $exists;
return if $@ && $@ =~ /onnect to SSH/i;
last;
}
$file = "$dir$cached_st_key";
$self->write_file($file,''.localtime(time));
confess if !$self->file_exists($file);
my $shared;
......@@ -1443,8 +1487,9 @@ sub shared_storage($self, $node, $dir) {
sleep 1;
}
$self->remove_file($file);
$shared = 0 if !defined $shared;
$self->_shared_storage_cache($node, $dir, $shared);
$self->{$cached_st_key} = $shared;
return $shared;
}
sub _fetch_tls_host_subject($self) {
......
sql/mysql/storage_nodes.sql 0 → 100644
View file @ b9f28f4a
create table storage_nodes (
`id` integer NOT NULL AUTO_INCREMENT,
`id_node1` integer NOT NULL,
`id_node2` integer NOT NULL,
`dir` varchar(255) NOT NULL,
`is_shared` integer NOT NULL DEFAULT 1,
PRIMARY KEY (`id`),
UNIQUE (`id_node1`,`id_node2`, `dir`)
);
sql/sqlite/storage_nodes.sql 0 → 100644
View file @ b9f28f4a
create table storage_nodes (
`id` integer NOT NULL PRIMARY KEY AUTOINCREMENT
, `id_node1` integer NOT NULL
, `id_node2` integer NOT NULL
, `dir` varchar(255) NOT NULL
, `is_shared` integer NOT NULL DEFAULT 1
, UNIQUE (`id_node1`,`id_node2`, `dir`)
);
t/kvm/n10_nodes.t
View file @ b9f28f4a
......@@ -809,6 +809,7 @@ sub test_domain_already_started {
{ # clone is active, it should be found in node
my $clone3 = rvd_back->search_domain($clone->name);
$clone3->check_status();
is($clone3->id, $clone->id);
is($clone3->_vm->host , $node->host,"Expecting ".$clone3->name
." in ".$node->host) or exit;
......@@ -1016,6 +1017,11 @@ sub test_shutdown($node) {
is($clone->is_active,0,"[".$clone->type."] Expecting clone ".$clone->name." inactive") or return;
is($clone->_data('status'),'shutdown',"[".$clone->type."] Expecting clone ".$clone->name." data active") or return;
my $req = Ravada::Request->refresh_vms();
wait_request(debug => 1);
is($req->status,'done');
is($req->error,'');
my $clone2 = Ravada::Domain->open($clone->id); #open will clean internal shutdown
is($clone2->is_active,0) or exit;
......@@ -1024,6 +1030,7 @@ sub test_shutdown($node) {
my $md5_remote = _md5($file, $node);
is($md5_remote, $md5);
}
# this would eventualy be called on check_vms request
my @line = search_iptable_remote(
node => $node
, remote_ip => $remote_ip
......
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