Skip to content
GitLab
Commit cd53759d authored by fv3rdugo's avatar fv3rdugo
Browse files

Merge branch 'develop' into 369_dockers

parents ea7304e1 3a9c9a75
Expand all Hide whitespace changes
Inline Side-by-side
CONTRIBUTING.md
View file @ cd53759d
......@@ -28,14 +28,6 @@ mentor first timers.
If this is something you think you can fix, then
[fork Ravada](https://help.github.com/articles/fork-a-repo)
and create a branch with a descriptive name. We prepend the issue number to
the branch so it is easier to follow.
A good branch name would be (where issue #77 is the one you're working on):
```sh
git checkout -b fix/77_start_machine
```
## 4. Code Style
......@@ -172,25 +164,15 @@ After working on your changes you need to Push it (upload) your newly created br
Pull requests or PR are proposed changes to a repository submitted by a user and accepted or rejected by a repository's collaborators.
When your changes are done, you should switch back to your master branch and make sure it's
up to date with Ravada's master branch:
```sh
git remote add upstream git@github.com:UPC/ravada.git
git checkout master
git pull --rebase origin master
```
Then update your feature branch from your local copy of master, and push it!
Send your changes to github *pushing* them up:
```sh
git checkout 325_boost_performance
git rebase master
git push --set-upstream origin 325_boost_performance
git push
```
Finally, go to our GitHub repository and
[create a Pull Request](https://github.com/UPC/ravada/pulls)
Finally, go to your GitHub repository and
[create a Pull Request](https://github.com/pulls)
### 10.1 How to Write a Title for a Pull Request
......@@ -211,9 +193,9 @@ To learn more about rebasing in Git, there are a lot of
but here's the suggested workflow:
```sh
git checkout 325_boost_performance
git pull --rebase origin master
git push --force-with-lease origin 325_boost_performance
git remote add upstream https://github.com/UPC/ravada.git
git fetch upstream
git rebase upstream/develop
```
### 10.3 Merging a PR (maintainers only)
......@@ -227,3 +209,14 @@ A PR can only be merged into master by a maintainer if:
Any maintainer is allowed to merge a PR if all of these conditions are
met.
### 11 Reset my fork to upstream
```sh
git remote add upstream https://github.com/UPC/ravada
git fetch upstream
git checkout develop
git reset --hard upstream/develop
git push origin develop --force
```
debian/control-debian-10
View file @ cd53759d
......@@ -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
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
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 @ cd53759d
......@@ -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
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
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 @ cd53759d
......@@ -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
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
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
etc/rvd_front.conf.example
View file @ cd53759d
......@@ -2,6 +2,7 @@
hypnotoad => {
pid_file => '/var/run/ravada/rvd_front.pid'
,listen => ['http://*:8081']
,proxy => 1
}
,dir => {
templates => '/usr/share/ravada/templates'
......
lib/Ravada.pm
View file @ cd53759d
......@@ -15,8 +15,9 @@ use Moose;
use POSIX qw(WNOHANG);
use Time::HiRes qw(gettimeofday tv_interval);
use YAML;
use MIME::Base64;
use Socket qw( inet_aton inet_ntoa );
use Image::Magick::Q16;
no warnings "experimental::signatures";
use feature qw(signatures);
......@@ -160,7 +161,7 @@ sub _init_user_daemon {
sub _update_user_grants {
my $self = shift;
$self->_init_user_daemon();
my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM users");
my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM users WHERE is_temporary=0");
my $id;
$sth->execute;
$sth->bind_columns(\$id);
......@@ -168,7 +169,13 @@ sub _update_user_grants {
my $user = Ravada::Auth::SQL->search_by_id($id);
next if $user->name() eq $USER_DAEMON_NAME;
next if $user->grants();
my %grants = $user->grants();
for my $key (keys %grants) {
delete $grants{$key} if !defined $grants{$key};
}
next if keys %grants;
$USER_DAEMON->grant_user_permissions($user);
$USER_DAEMON->grant_admin_permissions($user) if $user->is_admin;
}
......@@ -449,7 +456,28 @@ sub _update_isos {
,xml_volume => 'jessie-volume.xml'
,min_disk_size => '10'
}
,kali_64 => {
name => 'Kali Linux 2020'
,description => 'Kali Linux 2020 64 Bits'
,arch => 'amd64'
,xml => 'jessie-amd64.xml'
,xml_volume => 'jessie-volume.xml'
,url => 'https://cdimage.kali.org/kali-2020.\d+/'
,file_re => 'kali-linux-2020.\d+-installer-amd64.iso'
,sha256_url => '$url/SHA256SUMS'
,min_disk_size => '10'
}
,kali_64_netinst => {
name => 'Kali Linux 2020 (NetInstaller)'
,description => 'Kali Linux 2020 64 Bits (light NetInstall)'
,arch => 'amd64'
,xml => 'jessie-amd64.xml'
,xml_volume => 'jessie-volume.xml'
,url => 'https://cdimage.kali.org/kali-2020.\d+/'
,file_re => 'kali-linux-2020.\d+-installer-netinst-amd64.iso'
,sha256_url => '$url/SHA256SUMS'
,min_disk_size => '10'
}
,windows_7 => {
name => 'Windows 7'
,description => 'Windows 7 64 bits. Requires an user provided ISO image.'
......@@ -526,7 +554,7 @@ sub _scheduled_fedora_releases($self,$data) {
name => 'Fedora '.$release
,description => "RedHat Fedora $release Workstation 64 bits"
,url => 'http://ftp.halifax.rwth-aachen.de/fedora/linux/releases/'.$release
.'/Workstation/x86_64/iso/Fedora-Workstation-netinst-x86_64-'.$release
.'/Workstation/x86_64/iso/Fedora-Workstation-.*-x86_64-'.$release
.'-.*\.iso'
,arch => 'amd64'
,xml => 'xenial64-amd64.xml'
......@@ -990,7 +1018,7 @@ sub _null_grants($self) {
$sth->execute;
my ($count) = $sth->fetchrow;
exit if !$count && $self->{_null}++;
warn "No null grants found" if !$count && $self->{_null_grants}++;
return $count;
}
......@@ -1225,7 +1253,7 @@ sub _upgrade_tables {
$self->_upgrade_table('iso_images','device','varchar(255)');
$self->_upgrade_table('iso_images','min_disk_size','int (11) DEFAULT NULL');
$self->_upgrade_table('users','language','char(3) DEFAULT NULL');
$self->_upgrade_table('users','language','char(40) DEFAULT NULL');
if ( $self->_upgrade_table('users','is_external','int(11) DEFAULT 0')) {
my $sth = $CONNECTOR->dbh->prepare(
"UPDATE users set is_external=1 WHERE password='*LK* no pss'"
......@@ -1233,6 +1261,7 @@ sub _upgrade_tables {
$sth->execute;
}
$self->_upgrade_table('users','external_auth','char(32) DEFAULT NULL');
$self->_upgrade_table('users','date_created','timestamp DEFAULT CURRENT_TIMESTAMP');
$self->_upgrade_table('networks','requires_password','int(11)');
$self->_upgrade_table('networks','n_order','int(11) not null default 0');
......@@ -1262,7 +1291,13 @@ sub _upgrade_tables {
$self->_upgrade_table('domains','is_pool','int NOT NULL default 0');
$self->_upgrade_table('domains','needs_restart','int not null default 0');
$self->_upgrade_table('domains','screenshot','BLOB');
if ($self->_upgrade_table('domains','screenshot','BLOB')) {
$self->_upgrade_screenshots();
}
$self->_upgrade_table('domains_network','allowed','int not null default 1');
$self->_upgrade_table('iptables','id_vm','int DEFAULT NULL');
......@@ -1427,6 +1462,12 @@ sub _check_config($config_orig = {} , $valid_config = \%VALID_CONFIG ) {
warn "Error: Unknown config entry \n".Dumper(\%config) if ! $0 =~ /\.t$/;
return 0;
}
warn "Warning: LDAP authentication with match is discouraged. Try bind.\n"
if exists $config_orig->{ldap}
&& exists $config_orig->{ldap}->{auth}
&& $config_orig->{ldap}->{auth} =~ /match/
&& $0 !~ /\.t$/;
return 1;
}
......@@ -1579,6 +1620,7 @@ sub create_domain {
my $start = $args{start};
my $id_base = $args{id_base};
my $data = delete $args{data};
my $id_owner = $args{id_owner} or confess "Error: missing id_owner ".Dumper(\%args);
_check_args(\%args,qw(iso_file id_base id_iso id_owner name active swap memory disk id_template start remote_ip request vm add_to_pool));
......@@ -1637,6 +1679,12 @@ sub create_domain {
die $error if $error && !$request;
$request->error($error) if $error;
}
Ravada::Request->add_hardware(
uid => $args{id_owner}
,id_domain => $domain->id
,name => 'disk'
,data => { size => $data, type => 'data' }
) if $domain && $data;
return $domain;
}
......@@ -2410,10 +2458,11 @@ sub _do_execute_command {
$err =~ s/(.*?)retry.?/$1/i;
$request->error($err) if $err;
}
}
} else {
$request->status('done')
if $request->status() ne 'done'
&& $request->status() !~ /^retry/i;
}
}
sub _cmd_manage_pools($self, $request) {
......@@ -2505,16 +2554,33 @@ sub _cmd_copy_screenshot {
my $id_base = $domain->id_base;
my $base = $self->search_domain_by_id($id_base);
if (!$domain->file_screenshot) {
if (!$domain->screenshot) {
die "I don't have the screenshot of the domain ".$domain->name;
} else {
$base->_data(screenshot => $domain->_data('screenshot'));
}
}
my $base_screenshot = $domain->file_screenshot();
sub _upgrade_screenshots($self) {
$base_screenshot =~ s{(.*)/\d+\.(\w+)}{$1/$id_base.$2};
$base->_post_screenshot($base_screenshot);
my $sth = $CONNECTOR->dbh->prepare(
"SELECT id, name, file_screenshot FROM domains WHERE file_screenshot like '%' "
);
$sth->execute();
copy($domain->file_screenshot, $base_screenshot);
my $sth_update = $CONNECTOR->dbh->prepare(
"UPDATE domains set screenshot = ? WHERE id=?"
);
while ( my ($id, $name, $file_path)= $sth->fetchrow ) {
next if ! -e $file_path;
warn "INFO: converting screenshot from $name";
my $file= new Image::Magick::Q16;
$file->Read($file_path);
my @blobs = $file->ImageToBlob(magick => 'png');
eval {
$sth_update->execute(encode_base64($blobs[0]), $id);
};
warn $@;
}
}
......@@ -2644,6 +2710,11 @@ sub _cmd_remove {
$self->remove_domain(name => $request->args('name'), uid => $request->args('uid'));
}
sub _cmd_restore_domain($self,$request) {
my $domain = Ravada::Domain->open($request->args('id_domain'));
return $domain->restore(Ravada::Auth::SQL->search_by_id($request->args('uid')));
}
sub _cmd_pause {
my $self = shift;
my $request = shift;
......@@ -2703,7 +2774,8 @@ sub _cmd_open_iptables {
sub _cmd_clone($self, $request) {
return _req_clone_many($self, $request) if $request->defined_arg('number');
return _req_clone_many($self, $request) if $request->defined_arg('number')
&& $request->defined_arg('number') > 1;
my $domain = Ravada::Domain->open($request->args('id_domain'))
or confess "Error: Domain ".$request->args('id_domain')." not found";
......@@ -2714,7 +2786,7 @@ sub _cmd_clone($self, $request) {
my $user = Ravada::Auth::SQL->search_by_id($request->args('uid'))
or die "Error: User missing, id: ".$request->args('uid');
$args->{user} = $user;
for (qw(id_domain uid at )) {
for (qw(id_domain uid at number )) {
delete $args->{$_};
}
......@@ -2734,6 +2806,15 @@ sub _req_clone_many($self, $request) {
my $domains = $self->list_domains_data();
my %domain_exists = map { $_->{name} => 1 } @$domains;
if (!$base->is_base) {
my $uid = $request->defined_arg('uid');
confess Dumper($request) if !$uid;
my $req_prepare = Ravada::Request->prepare_base(
id_domain => $base->id
, uid => $uid
);
$args->{after_request} = $req_prepare->id;
}
my @reqs;
for ( 1 .. $number ) {
my $n = $_;
......@@ -2798,7 +2879,7 @@ sub _cmd_dettach($self, $request) {
$domain->dettach($user);
}
sub _cmd_rebase_volumes($self, $request) {
sub _cmd_rebase($self, $request) {
my $domain = Ravada::Domain->open($request->id_domain);
my $user = Ravada::Auth::SQL->search_by_id($request->args('uid'));
......@@ -2806,14 +2887,15 @@ sub _cmd_rebase_volumes($self, $request) {
if !$user->is_admin;
if ($domain->is_active) {
Ravada::Request->shutdown_domain(uid => $user->id, id_domain => $domain->id, timeout => 120);
$request->status("requested");
die "Error: domain ".$domain->name." is still active, shut it down to rebase\n"
my $req_shutdown = Ravada::Request->shutdown_domain(uid => $user->id, id_domain => $domain->id, timeout => 120);
$request->after_request($req_shutdown->id);
die "Warning: domain ".$domain->name." is up, retry.\n"
}
$request->status('working');
my $new_base = Ravada::Domain->open($request->args('id_base'));
$domain->rebase_volumes($new_base);
$domain->rebase($user, $new_base);
}
......@@ -2886,12 +2968,26 @@ sub _cmd_remove_base {
die "Unknown domain id '$id_domain'\n" if !$domain;
$domain->_vm->disconnect();
$self->_disconnect_vm();
$domain->remove_base($user);
}
sub _cmd_spinoff($self, $request) {
my $id_domain = $request->id_domain or confess "Missing request id_domain";
my $uid = $request->args('uid') or confess "Missing argument uid";
my $user = Ravada::Auth::SQL->search_by_id( $uid);
my $domain = $self->search_domain_by_id($id_domain);
die "Unknown domain id '$id_domain'\n" if !$domain;
$domain->spinoff();
}
sub _cmd_hybernate {
my $self = shift;
......@@ -2983,7 +3079,7 @@ sub _cmd_change_hardware {
$domain->change_hardware(
$request->args('hardware')
,$request->args('index')
,$request->defined_arg('index')
,$request->args('data')
);
}
......@@ -3168,24 +3264,6 @@ sub _cmd_refresh_vms($self, $request=undef) {
$self->_refresh_volatile_domains();
}
sub _cmd_change_max_memory($self, $request) {
my $uid = $request->args('uid');
my $id_domain = $request->args('id_domain');
my $memory = $request->args('ram');
my $domain = $self->search_domain_by_id($id_domain);
$domain->set_max_mem($memory);
}
sub _cmd_change_curr_memory($self, $request) {
my $uid = $request->args('uid');
my $id_domain = $request->args('id_domain');
my $memory = $request->args('ram');
my $domain = $self->search_domain_by_id($id_domain);
$domain->set_memory($memory);
}
sub _cmd_shutdown_node($self, $request) {
my $id_node = $request->args('id_node');
my $node = Ravada::VM->open($id_node);
......@@ -3402,15 +3480,19 @@ sub _remove_unnecessary_downs($self, $domain) {
sub _refresh_volatile_domains($self) {
my $sth = $CONNECTOR->dbh->prepare(
"SELECT id, name, id_vm FROM domains WHERE is_volatile=1"
"SELECT id, name, id_vm, id_owner FROM domains WHERE is_volatile=1"
);
$sth->execute();
while ( my ($id_domain, $name, $id_vm) = $sth->fetchrow ) {
while ( my ($id_domain, $name, $id_vm, $id_owner) = $sth->fetchrow ) {
my $domain = Ravada::Domain->open(id => $id_domain, _force => 1);
if ( !$domain || $domain->status eq 'down' || !$domain->is_active) {
if ($domain) {
$domain->_post_shutdown(user => $USER_DAEMON);
$domain->remove($USER_DAEMON);
} else {
my $sth= $CONNECTOR->dbh->prepare("DELETE FROM users WHERE id=?");
$sth->execute($id_owner);
$sth->finish;
}
my $sth_del = $CONNECTOR->dbh->prepare("DELETE FROM domains WHERE id=?");
$sth_del->execute($id_domain);
......@@ -3458,11 +3540,11 @@ sub _cmd_set_base_vm {
sub _cmd_cleanup($self, $request) {
$self->_clean_volatile_machines( request => $request);
$self->_clean_temporary_users( );
$self->_clean_requests('cleanup', $request);
$self->_clean_requests('cleanup', $request,'done');
$self->_clean_requests('enforce_limits', $request,'done');
$self->_clean_requests('refresh_vms', $request,'done');
$self->_wait_pids();
}
sub _req_method {
......@@ -3477,6 +3559,7 @@ sub _req_method {
,pause => \&_cmd_pause
,create => \&_cmd_create
,remove => \&_cmd_remove
,restore_domain => \&_cmd_restore_domain
,resume => \&_cmd_resume
,dettach => \&_cmd_dettach
,cleanup => \&_cmd_cleanup
......@@ -3488,9 +3571,12 @@ sub _req_method {
,add_disk => \&_cmd_add_disk
,copy_screenshot => \&_cmd_copy_screenshot
,cmd_cleanup => \&_cmd_cleanup
,remove_base => \&_cmd_remove_base
,spinoff => \&_cmd_spinoff
,set_base_vm => \&_cmd_set_base_vm
,remove_base_vm => \&_cmd_set_base_vm
,refresh_vms => \&_cmd_refresh_vms
,ping_backend => \&_cmd_ping_backend
,prepare_base => \&_cmd_prepare_base
......@@ -3499,7 +3585,8 @@ sub _req_method {
,list_vm_types => \&_cmd_list_vm_types
,enforce_limits => \&_cmd_enforce_limits
,force_shutdown => \&_cmd_force_shutdown
,rebase_volumes => \&_cmd_rebase_volumes
,rebase => \&_cmd_rebase
,refresh_storage => \&_cmd_refresh_storage
,refresh_machine => \&_cmd_refresh_machine
,domain_autostart=> \&_cmd_domain_autostart
......@@ -3507,8 +3594,6 @@ sub _req_method {
,add_hardware => \&_cmd_add_hardware
,remove_hardware => \&_cmd_remove_hardware
,change_hardware => \&_cmd_change_hardware
,change_max_memory => \&_cmd_change_max_memory
,change_curr_memory => \&_cmd_change_curr_memory
# Domain ports
,expose => \&_cmd_expose
......@@ -3692,6 +3777,26 @@ sub _enforce_limits_active($self, $request) {
}
}
sub _clean_temporary_users($self) {
my $sth_users = $CONNECTOR->dbh->prepare(
"SELECT u.id, d.id, u.date_created"
." FROM users u LEFT JOIN domains d "
." ON u.id = d.id_owner "
." WHERE u.is_temporary = 1 AND u.date_created < ?"
);
my $sth_del = $CONNECTOR->dbh->prepare(
"DELETE FROM users "
." WHERE is_temporary = 1 AND id=?"
);
my $one_day = _date_now(-24 * 60 * 60);
$sth_users->execute( $one_day );
while ( my ( $id_user, $id_domain, $date_created ) = $sth_users->fetchrow ) {
next if $id_domain;
$sth_del->execute($id_user);
}
}
sub _clean_volatile_machines($self, %args) {
my $request = delete $args{request};
......@@ -3706,8 +3811,13 @@ sub _clean_volatile_machines($self, %args) {
);
if ($domain_real) {
next if $domain_real->domain && $domain_real->is_active;
$domain_real->_post_shutdown();
$domain_real->remove($USER_DAEMON);
eval { $domain_real->_post_shutdown() };
warn $@ if $@;
eval { $domain_real->remove($USER_DAEMON) };
warn $@ if $@;
} elsif ($domain->{id_owner}) {
my $sth = $CONNECTOR->dbh->prepare("DELETE FROM users where id=?");
$sth->execute($domain->{id_owner});
}
$sth_remove->execute($domain->{id});
......@@ -3755,7 +3865,6 @@ sub _cmd_open_exposed_ports($self, $request) {
}
sub DESTROY($self) {
$self->_wait_pids();
}
=head2 version
......
lib/Ravada/Auth/LDAP.pm
View file @ cd53759d
......@@ -13,7 +13,10 @@ use Authen::Passphrase;
use Authen::Passphrase::SaltedDigest;
use Carp qw(carp);
use Data::Dumper;
use Digest::SHA qw(sha1_hex);
use Digest::SHA qw(sha1_hex sha256_hex);
use Encode;
use PBKDF2::Tiny qw/derive/;
use MIME::Base64;
use Moose;
use Net::LDAP;
use Net::LDAPS;
......@@ -43,6 +46,11 @@ our $STATUS_EOF = 1;
our $STATUS_DISCONNECTED = 81;
our $STATUS_BAD_FILTER = 89;
our $PBKDF2_SALT_LENGTH = 64;
our $PBKDF2_ITERATIONS_LENGTH = 4;
our $PBKDF2_HASH_LENGTH = 256;
our $PBKDF2_LENGTH = $PBKDF2_SALT_LENGTH + $PBKDF2_ITERATIONS_LENGTH + $PBKDF2_HASH_LENGTH;
=head2 BUILD
Internal OO build
......@@ -64,8 +72,7 @@ Adds a new user in the LDAP directory
=cut
sub add_user {
my ($name, $password, $is_admin) = @_;
sub add_user($name, $password, $storage='rfc2307', $algorithm=undef ) {
_init_ldap_admin();
......@@ -76,8 +83,6 @@ sub add_user {
if !_dc_base();
my ($givenName, $sn) = $name =~ m{(\w+)\.(.*)};
my $apr=Authen::Passphrase::SaltedDigest->new(passphrase => $password, algorithm => "MD5");
my %entry = (
cn => $name
, uid => $name
......@@ -87,7 +92,7 @@ sub add_user {
, givenName => ($givenName or $name)
, sn => ($sn or $name)
# , homeDirectory => "/home/$name"
,userPassword => $apr->as_rfc2307()
,userPassword => _password_store($password, $storage, $algorithm)
);
my $dn = "cn=$name,"._dc_base();
......@@ -97,6 +102,51 @@ sub add_user {
}
}
sub _password_store($password, $storage, $algorithm) {
return _password_rfc2307($password, $algorithm) if lc($storage) eq 'rfc2307';
return _password_pbkdf2($password, $algorithm) if lc($storage) eq 'pbkdf2';
confess "Error: Unknown storage '$storage'";
}
sub _password_pbkdf2($password, $algorithm='SHA-256') {