Skip to content
GitLab
Unverified Commit 8bc1d242 authored by Francesc Guasch's avatar Francesc Guasch Committed by GitHub
Browse files

Refactor use net::openssh library (#1343) 

refactor(nodes): use Net::OpenSSH

* refactor(frontend): removed plugin renderfile
* refactor(volumes): qcwo2 format on clones

issue #1153
parent a553afb9
Hide whitespace changes
Inline Side-by-side
Makefile.PL
View file @ 8bc1d242
......@@ -29,9 +29,10 @@ WriteMakefile(
,'DBD::SQLite' => 0
,'IPTables::ChainMgr' => 0
,'Net::DNS' => 0
,'Net::SSH2' => 0
,'Net::OpenSSH' => 0
,'File::Rsync' => 0
,'DateTime::Format::DateParse'=> 0
,'PBKDF2::Tiny' => 0
},
BUILD_REQUIRES => {
'Test::Perl::Critic' => 0
......
debian/control-debian-10
View file @ 8bc1d242
......@@ -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-ssh2-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
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 @ 8bc1d242
......@@ -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-ssh2-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
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 @ 8bc1d242
......@@ -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-ssh2-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
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
debian/control-ubuntu-20.04
View file @ 8bc1d242
......@@ -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-ssh2-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
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 @ 8bc1d242
......@@ -1367,7 +1367,15 @@ sub _sql_insert_defaults($self){
my $cont = 1;
require Mojolicious::Plugin::Config;
my $plugin = Mojolicious::Plugin::Config->new();
my $conf = $plugin->load("/etc/rvd_front.conf");
my $conf = {
fallback => 0
,session_timeout => 10*60
,admin_session_timeout => 30*60
,auto_view => 1
};
if ( -e "/etc/rvd_front.conf" ){
$conf = $plugin->load("/etc/rvd_front.conf");
}
my $id_backend = 2;
my %values = (
settings => [
......
lib/Ravada/Domain.pm
View file @ 8bc1d242
......@@ -1798,6 +1798,7 @@ sub _remove_domain_cascade($self,$user, $cascade = 1) {
my $vm;
eval { $vm = Ravada::VM->open($instance->{id_vm}) };
die $@ if $@ && $@ !~ /I can't find VM/i;
next if !$vm || !$vm->is_active;
my $domain;
$@ = '';
eval { $domain = $vm->search_domain($domain_name) } if $vm;
......@@ -2483,11 +2484,18 @@ sub _around_is_active($orig, $self) {
return 1 if $self->_data('status') eq 'active';
return 0;
}
if ($self->_vm && $self->_vm->is_active ) {
return 0 if $self->is_removed;
if ($self->_vm) {
eval {
return 0 if $self->_vm->is_active && $self->is_removed;
};
if ( $@ ) {
return 0 if ref($@) && $@->code == 38; # broken pipe
return 0 if $@ =~ /can't connect|error connecting/i;
die $@;
}
}
my $is_active = 0;
$is_active = $self->$orig() if $self->_vm->is_active;
$is_active = $self->$orig();
return $is_active if $self->readonly
|| !$self->is_known
......@@ -3943,6 +3951,8 @@ sub _rsync_volumes_back($self, $request=undef) {
sub _pre_migrate($self, $node, $request = undef) {
confess "Error: node not active" if !$node->is_active(1);
$self->_check_equal_storage_pools($node) if $self->_vm->is_active;
$self->_internal_autostart(0);
......@@ -4065,7 +4075,8 @@ sub set_base_vm($self, %args) {
} elsif ($value) {
$request->status("working", "Syncing base volumes to ".$vm->host)
if $request;
$self->migrate($vm, $request);
eval { $self->migrate($vm, $request) if $vm->is_active(1) };
die $@ if $@ && $@ !~ /no ssh connection/;
$self->_set_clones_autostart(0);
} else {
$self->_set_vm($vm,1); # force set vm on domain
......@@ -4114,7 +4125,6 @@ sub remove_base_vm($self, %args) {
confess "ERROR: Unknown arguments ".join(',',sort keys %args).", valid are user and vm."
if keys %args;
warn $vm->name;
return $self->set_base_vm(vm => $vm, user => $user, value => 0);
}
......
lib/Ravada/Domain/KVM.pm
View file @ 8bc1d242
......@@ -585,6 +585,7 @@ sub _post_remove_base_domain {
sub post_resume_aux($self, %args) {
my $set_time = delete $args{set_time};
$set_time = 1 if !defined $set_time;
eval {
$self->set_time() if $set_time;
};
......@@ -644,6 +645,9 @@ sub is_active {
return 0 if $self->is_removed;
my $is_active = 0;
eval { $is_active = $self->domain->is_active };
return 0 if $@ && ( $@->code == 1 # client socket is closed
|| $@->code == 38 # broken pipe
);
die $@ if $@ && $@ !~ /code: 42,/;
return $is_active;
}
......@@ -2122,6 +2126,9 @@ sub is_removed($self) {
$@ = '';
$is_removed = 1;
}
return if $@ && ($@->code == 38 # cannot recv data
|| $@->code == 1 # client socket is closed
);
die $@ if $@;
return $is_removed;
}
......
lib/Ravada/Domain/Void.pm
View file @ 8bc1d242
......@@ -70,7 +70,15 @@ sub _set_spice_ip($self, $password=undef, $listen_ip=$self->_vm->listen_ip) {
sub is_active {
my $self = shift;
return ($self->_value('is_active') or 0);
my $ret = 0;
eval {
$ret = $self->_value('is_active') ;
$ret = 0 if !defined $ret;
};
return $ret if !$@;
return 0 if $@ =~ /Error connecting|can't connect/;
warn $@;
die $@;
}
sub pause {
......
lib/Ravada/VM.pm
View file @ 8bc1d242
......@@ -19,8 +19,7 @@ use Socket qw( inet_aton inet_ntoa );
use Moose::Role;
use Net::DNS;
use Net::Ping;
use Net::SSH2 qw(LIBSSH2_FLAG_SIGPIPE);
use IO::Scalar;
use Net::OpenSSH;
use IO::Socket;
use IO::Interface;
use Net::Domain qw(hostfqdn);
......@@ -39,7 +38,6 @@ our $CONFIG = \$Ravada::CONFIG;
our $MIN_MEMORY_MB = 128 * 1024;
our $SSH_TIMEOUT = 20 * 1000;
our $CACHE_TIMEOUT = 60;
our $FIELD_TIMEOUT = '_data_timeout';
......@@ -115,6 +113,14 @@ has 'store' => (
, is => 'rw'
, default => 1
);
has 'netssh' => (
isa => 'Any'
,is => 'ro'
, builder => '_connect_ssh'
, lazy => 1
, clearer => 'clear_netssh'
);
############################################################
#
# Method Modifiers definition
......@@ -131,6 +137,7 @@ around 'import_domain' => \&_around_import_domain;
around 'ping' => \&_around_ping;
around 'connect' => \&_around_connect;
after 'disconnect' => \&_post_disconnect;
#############################################################
#
......@@ -287,6 +294,16 @@ sub _around_connect($orig, $self) {
return $result;
}
sub _post_disconnect($self) {
if (!$self->is_local) {
if ($self->netssh) {
$self->netssh->disconnect();
}
$self->clear_netssh();
delete $SSH{$self->host};
}
}
sub _pre_create_domain {
_check_create_domain(@_);
_connect(@_);
......@@ -302,7 +319,7 @@ sub _pre_list_domains($self,@) {
die "ERROR: VM ".$self->name." unavailable" if !$self->ping();
}
sub _connect_ssh($self, $disconnect=0) {
sub _connect_ssh($self) {
confess "Don't connect to local ssh"
if $self->is_local;
......@@ -311,55 +328,41 @@ sub _connect_ssh($self, $disconnect=0) {
return;
}
my @pwd = getpwuid($>);
my $home = $pwd[7];
my $ssh= $self->{_ssh};
my $ssh;
$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;
if (!$ssh || !$ssh->check_master) {
delete $SSH{$self->host};
for ( 1 .. 3 ) {
eval { $connect = $ssh->connect($self->host) };
last if $connect;
$ssh = Net::OpenSSH->new($self->host
,timeout => 2
,batch_mode => 1
,forward_X11 => 0
,forward_agent => 0
,kill_ssh_on_timeout => 1
);
last if !$ssh->error;
warn "RETRYING ssh ".$self->host." ".join(" ",$ssh->error);
sleep 1;
}
if ( !$connect) {
eval { $connect = $ssh->connect($self->host) };
if (!$connect) {
$self->_cached_active(0);
confess $ssh->error();
}
if ( $ssh->error ) {
$self->_cached_active(0);
warn "Error connecting to ".$self->host." : ".$ssh->error();
return;
}
$ssh->auth_publickey( 'root'
, "$home/.ssh/id_rsa.pub"
, "$home/.ssh/id_rsa"
) or $ssh->die_with_error();
$self->{_ssh} = $ssh;
$SSH{$self->host} = $ssh;
}
$SSH{$self->host} = $ssh;
return $ssh;
}
sub _ssh_channel($self) {
my $ssh = $self->_connect_ssh() or confess "ERROR: I can't connect to SSH in ".$self->host;
my $ssh_channel;
for ( 1 .. 5 ) {
$ssh_channel = $ssh->channel();
last if $ssh_channel;
sleep 1;
}
if (!$ssh_channel) {
$ssh = $self->_connect_ssh(1) or die "Error: I can't connect to ".$self->name;
$ssh_channel = $ssh->channel();
}
die $ssh->die_with_error if !$ssh_channel;
$ssh->blocking(1);
return $ssh_channel;
sub ssh($self) {
my $ssh = $self->netssh;
return if !$ssh;
return $ssh if $ssh->check_master;
warn "WARNING: ssh error '".$ssh->error."'" if $ssh->error;
$self->netssh->disconnect;
$self->clear_netssh();
return $self->netssh;
}
sub _around_create_domain {
......@@ -1089,6 +1092,10 @@ sub ping($self, $option=undef, $cache=1) {
return $ping;
}
sub _ping_nocache($self,$option=undef) {
return $self->ping($option,0);
}
sub _delete_cache($self, $key) {
$key = "_cache_$key";
delete $self->{$key};
......@@ -1161,18 +1168,20 @@ Arguments: optional force mode
=cut
sub is_active($self, $force=0) {
return $self->_do_is_active() if $self->is_local || $force;
return $self->_do_is_active($force) if $self->is_local || $force;
return $self->_cached_active if time - $self->_cached_active_time < 60;
return $self->_do_is_active();
}
sub _do_is_active($self) {
sub _do_is_active($self, $force=undef) {
my $ret = 0;
if ( $self->is_local ) {
$ret = 1 if $self->vm;
} else {
if ( !$self->ping() ) {
my @ping_args = ();
@ping_args = (undef,0) if $force; # no cache
if ( !$self->ping(@ping_args) ) {
$ret = 0;
} else {
if ( $self->is_alive ) {
......@@ -1182,6 +1191,9 @@ sub _do_is_active($self) {
}
$self->_cached_active($ret);
$self->_cached_active_time(time);
my $cache_key = "ping_".$self->host;
$self->_delete_cache($cache_key);
return $ret;
}
......@@ -1242,20 +1254,17 @@ sub run_command($self, @command) {
return $self->_run_command_local(@command) if $self->is_local();
my $chan = $self->_ssh_channel() or die "ERROR: No SSH channel to host ".$self->host;
my $ssh = $self->ssh or confess "Error: Error connecting to ".$self->host;
my $command = join(" ",@command);
$chan->exec($command);# or $self->{_ssh}->die_with_error;
my ($out, $err) = $ssh->capture2({timeout => 10},join " ",@command);
chomp $err if $err;
$err = '' if !defined $err;
die "Error: Failed remote command on ".$self->host." @command : '$err'\n"
."'".$ssh->error."'"
if $ssh->error && $ssh->error !~ /^child exited with code/;
$chan->send_eof();
my ($out, $err) = ('', '');
while (!$chan->eof) {
if (my ($o, $e) = $chan->read2) {
$out .= $o;
$err .= $e;
}
}
return ($out, $err);
}
......@@ -1271,6 +1280,10 @@ sub run_command_nowait($self, @command) {
return $self->_run_command_local(@command) if $self->is_local();
return $self->run_command(@command);
=pod
my $chan = $self->_ssh_channel() or die "ERROR: No SSH channel to host ".$self->host;
my $command = join(" ",@command);
......@@ -1279,6 +1292,9 @@ sub run_command_nowait($self, @command) {
$chan->send_eof();
return;
=cut
}
......@@ -1301,10 +1317,12 @@ Writes a file to the node
sub write_file( $self, $file, $contents ) {
return $self->_write_file_local($file, $contents ) if $self->is_local;
my $chan = $self->_ssh_channel();
$chan->exec("cat > $file");
my $bytes = $chan->write($contents);
$chan->send_eof();
my $ssh = $self->ssh or confess "Error: no ssh connection";
my ($rin, $pid) = $self->ssh->pipe_in("cat > $file")
or die "pipe_in method failed ".$self->ssh->error;
print $rin $contents;
close $rin;
}
sub _write_file_local( $self, $file, $contents ) {
......@@ -1325,14 +1343,10 @@ Reads a file in memory from the storage of the virtual manager
sub read_file( $self, $file ) {
return $self->_read_file_local($file) if $self->is_local;
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);
my ($rout, $pid) = $self->ssh->pipe_out("cat $file")
or die "pipe_out method failed ".$self->ssh->error;
return $data;
return join ("",<$rout>);
}
sub _read_file_local( $self, $file ) {
......@@ -1350,8 +1364,8 @@ Returns true if the file exists in this virtual manager storage
sub file_exists( $self, $file ) {
return -e $file if $self->is_local;
my $ssh = ($self->{_ssh} or $self->_connect_ssh());
die "Error: no ssh connection to ".$self->name if ! $ssh;
my $ssh = $self->ssh;
confess "Error: no ssh connection to ".$self->name if ! $ssh;
confess "Error: dangerous filename '$file'"
if $file =~ /[`|"(\\\[]/;
......
t/kvm/n10_nodes.t
View file @ 8bc1d242
......@@ -1067,20 +1067,6 @@ sub _write_in_volumes($clone) {
}
}
sub _domain_node($node) {
my $vm = rvd_back->search_vm('KVM','localhost');
my $domain = $vm->search_domain($node->name);
$domain = rvd_back->import_domain(name => $node->name
,user => user_admin->name
,vm => 'KVM'
,spinoff_disks => 0
) if !$domain || !$domain->is_known;
ok($domain->id,"Expecting an ID for domain ".Dumper($domain)) or exit;
$domain->_set_vm($vm, 'force');
return $domain;
}
sub test_status($node) {
diag("[".$node->type."] testing domain status in front");
my ($base, $clone)= _create_clone($node);
......
t/lib/Test/Ravada.pm
View file @ 8bc1d242
......@@ -1141,7 +1141,8 @@ sub search_iptable_remote {
sub _lock_fh($fh) {
flock($fh, LOCK_EX);
seek($fh, 0, SEEK_END) or die "Cannot seek - $!\n";
print $fh,''.localtime(time)." $0\n";
print $fh,$$." ".localtime(time)." $0\n";
$fh->flush();
$LOCKED_FH{$fh} = $fh;
}
......@@ -1234,10 +1235,15 @@ sub hibernate_node($node) {
$domain->shutdown_now(user_admin);
}
}
$node->disconnect;
my $domain_node = _domain_node($node);
$domain_node->hibernate( user_admin );
for (;;) {
$node->disconnect;
my $domain_node = _domain_node($node);
eval { $domain_node->hibernate( user_admin ) };
my $error = $@;
warn $error if $error;
last if !$error || $error =~ /is not active/;
}
my $max_wait = 30;
my $ping;
......@@ -1252,29 +1258,36 @@ sub hibernate_node($node) {
sub shutdown_node($node) {
if ($node->is_active) {
$node->run_command("service lightdm stop");
if ($node->_do_is_active(1)) {
eval {
$node->run_command("service lightdm stop");
$node->run_command("service gdm stop");
};
confess $@ if $@ && $@ !~ /ssh error|error connecting|control command failed/i;
for my $domain ($node->list_domains()) {
diag("Shutting down ".$domain->name." on node ".$node->name);
$domain->shutdown_now(user_admin);
}
}
$node->disconnect;
my $domain_node = _domain_node($node);
eval {
$domain_node->shutdown(user => user_admin);# if !$domain_node->is_active;
};
sleep 2 if !$node->ping(undef, 0);
my $max_wait = 120;
for ( 1 .. $max_wait / 2 ) {
diag("Waiting for node ".$node->name." to be inactive ...") if !($_ % 10);
my $max_wait = 180;
for ( reverse 1 .. $max_wait ) {
last if !$node->ping(undef, 0);
if ( !($_ % 10) ) {
eval { $domain_node->shutdown(user => user_admin) };
warn $@ if $@;
diag("Waiting for node ".$node->name." to be inactive ... $_");
}
sleep 1;
}
is($node->ping,0);
$domain_node->shutdown_now(user_admin) if $domain_node->is_active;
is($node->ping(undef,0),0);
}
sub start_node($node) {
......@@ -1283,7 +1296,8 @@ sub start_node($node) {
confess "Undefined node " if!$node;
$node->disconnect;
if ( $node->_do_is_active ) {
$node->clear_netssh();
if ( $node->_do_is_active(1) ) {
my $connect;
eval { $connect = $node->connect };
return if $connect;
......@@ -1304,16 +1318,29 @@ sub start_node($node) {
is($node->ping('debug',0),1,"[".$node->type."] Expecting ping node ".$node->name) or exit;
for ( 1 .. 60 ) {
for my $try ( 1 .. 3) {
my $is_active;
eval {
$node->connect();
$is_active = $node->is_active(1)
};
warn $@ if $@;
for ( 1 .. 60 ) {
eval {
$node->disconnect;
$node->clear_netssh();
$node->connect();
$is_active = $node->is_active(1)
};
warn $@ if $@;
last if $is_active;
sleep 1;
diag("Waiting for active node ".$node->name." $_") if !($_ % 10);
}
last if $is_active;
sleep 1;
diag("Waiting for active node ".$node->name." $_") if !($_ % 10);
if ($try == 1 ) {
$domain->shutdown(user => user_admin);
sleep 2;
} elsif ( $try == 2 ) {
$domain->shutdown_now(user_admin);
sleep 2;
}
$domain->start(user => user_admin, remote_ip => '127.0.0.1');
}
is($node->_do_is_active,1,"Expecting active node ".$node->name) or exit;
......@@ -1340,10 +1367,14 @@ sub start_node($node) {
$node->is_active(1);
$node->enabled(1);
for ( 1 .. 60 ) {
for ( reverse 1 .. 120 ) {
my $node2 = Ravada::VM->open(id => $node->id);
last if $node2->is_active(1);
diag("Waiting for node ".$node->name." active ...") if !($_ % 10);
last if $node2->is_active(1) && $node->ssh;
diag("Waiting for node ".$node2->name." active ... $_") if !($_ % 10);
$node2->disconnect();
$node2->connect();
$node2->clear_netssh();
sleep 1;
}
eval { $node->run_command("hwclock","--hctosys") };