Commit f7a91fb7 authored by Fernando Verdugo's avatar Fernando Verdugo
Browse files

Merge branch 'develop' into fix/1201_renewMac

parents 21da7d5f 8998be51
......@@ -3,27 +3,5 @@
**Implemented enhancements:**
- Pools of virtual machines [\#1115]
- Run Ravada on Ubuntu Eoan [\#1177]
- Test mojo app [\#1137]
- Logout timeout on start machine too quick [\#1119]
- Do not remove the CD from the clones [\#1116]
- Pools of virtual machines [\#1115]
- Multiple copies of machines [\#1091]
- Frontend javascript and CSS from behind Firewall [\#993]
- Improve network ports management [\#265]
**Refactor**
- Refactor disk volumes management [\#1127]
**Bugfixes**
- Slow response with non-shared nodes [\#1188]
- Slides inputs in new machine are not right [\#1154]
- Some pages are displayed raw [\#1138]
- copy with pool fails [\#1131]
- Change current memory fails [\#1123]
- Access option missing in settings machine [\#1098]
- Improve languages detection support [\#1096]
- utf8mb3 character set is not supported [\#492]
......@@ -47,6 +47,7 @@ my $LIST;
my $HIBERNATE_DOMAIN;
my $START_DOMAIN;
my $SHUTDOWN_DOMAIN;
my $REMOVE_DOMAIN;
my $REBASE;
my $RUN_REQUEST;
......@@ -80,6 +81,7 @@ my $USAGE = "$0 "
." --start\n"
." --hibernate machine\n"
." --shutdown machine\n"
." --remove machine\n"
."\n"
."Operations modifiers:\n"
." --all : execute on all virtual machines\n"
......@@ -106,6 +108,7 @@ GetOptions ( help => \$help
,'url-isos=s'=> \$URL_ISOS
,'shutdown:s'=> \$SHUTDOWN_DOMAIN
,'hibernate:s'=> \$HIBERNATE_DOMAIN
,'remove:s'=> \$REMOVE_DOMAIN
,'disconnected'=> \$DISCONNECTED
,'remove-user=s'=> \$REMOVE_USER
,'make-admin=s' => \$MAKE_ADMIN_USER
......@@ -443,6 +446,20 @@ sub hibernate {
if !$domain_name && !$found;
}
sub remove_domain {
my $domain_name = shift;
my $rvd_back = Ravada->new(%CONFIG);
my $domain = $rvd_back->search_domain($domain_name);
die "Error: domain $domain_name not found\n" if !$domain;
Ravada::Request->remove_domain(
uid => Ravada::Utils::user_daemon()->id
,name => $domain->name
);
print "Removing $domain_name\n";
}
sub start_domain {
my $domain_name = shift;
......@@ -607,6 +624,7 @@ rebase() if $REBASE;
list($ALL) if $LIST;
hibernate($HIBERNATE_DOMAIN , $ALL) if defined $HIBERNATE_DOMAIN;
remove_domain($REMOVE_DOMAIN) if defined $REMOVE_DOMAIN;
start_domain($START_DOMAIN) if $START_DOMAIN;
shutdown_domain($SHUTDOWN_DOMAIN, $ALL, $HIBERNATED)
......
......@@ -16,6 +16,9 @@ my $DIR_SRC = getcwd;
my $DIR_DST;
my $DEBIAN = "DEBIAN";
my %COPY_RELEASES = (
'ubuntu-19.04'=> ['ubuntu-18.10','ubuntu-19.10']
);
my %DIR = (
templates => '/usr/share/ravada'
,'etc/ravada.conf' => 'etc'
......@@ -324,6 +327,18 @@ sub get_fallback {
print `etc/get_fallback.pl`;
}
sub copy_identical_releases {
for my $source (sort keys %COPY_RELEASES ) {
for my $copy (@{$COPY_RELEASES{$source}}) {
my $file_source = "$DIR_SRC/../ravada_release/ravada_${VERSION}_${source}_all.deb";
die "Error: No $file_source" if !-e $file_source;
my $file_copy = "$DIR_SRC/../ravada_release/ravada_${VERSION}_${copy}_all.deb";
copy($file_source, $file_copy) or die "Error: $!\n$file_source -> $file_copy";
}
}
exit;
}
#########################################################################
get_fallback();
......@@ -367,3 +382,5 @@ tar($dist);
create_md5sums();
create_deb($dist);
}
copy_identical_releases();
......@@ -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, 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.
......@@ -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
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.
control-ubuntu-19.04
\ No newline at end of file
......@@ -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.
......@@ -3,7 +3,7 @@ package Ravada;
use warnings;
use strict;
our $VERSION = '0.5.0-rc7';
our $VERSION = '0.6.0';
use Carp qw(carp croak);
use Data::Dumper;
......@@ -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);
......@@ -138,6 +139,7 @@ sub BUILD {
sub _install($self) {
$self->_create_tables();
$self->_upgrade_tables();
$self->_upgrade_timestamps();
$self->_update_data();
$self->_init_user_daemon();
}
......@@ -159,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);
......@@ -167,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;
}
......@@ -989,7 +997,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;
}
......@@ -1232,6 +1240,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');
......@@ -1261,6 +1270,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');
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');
......@@ -1274,6 +1290,30 @@ sub _upgrade_tables {
$self->_upgrade_table('domain_ports', 'internal_ip','char(200)');
}
sub _upgrade_timestamps($self) {
return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/;
my $req = Ravada::Request->ping_backend();
return if $req->{date_changed};
my @commands = qw(cleanup enforce_limits list_isos list_network_interfaces
manage_pools open_exposed_ports open_iptables ping_backend
refresh_machine refresh_storage refresh_vms
screenshot);
my $sql ="DELETE FROM requests WHERE "
.join(" OR ", map { "command = '$_'" } @commands);
my $sth = $CONNECTOR->dbh->prepare($sql);
$sth->execute();
$self->_upgrade_timestamp('requests','date_changed');
}
sub _upgrade_timestamp($self, $table, $field) {
my $sth = $CONNECTOR->dbh->prepare("ALTER TABLE $table change $field "
."$field timestamp DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP");
$sth->execute();
}
sub _connect_dbh {
my $driver= ($CONFIG->{db}->{driver} or 'mysql');;
......@@ -1401,6 +1441,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;
}
......@@ -2225,7 +2271,7 @@ sub _kill_stale_process($self) {
." AND pid IS NOT NULL "
." AND start_time IS NOT NULL "
);
$sth->execute(time - 5*scalar(@domains) + 60 );
$sth->execute(time - 5*scalar(@domains) - 60 );
while (my ($id, $pid, $command, $start_time) = $sth->fetchrow) {
if ($pid == $$ ) {
warn "HOLY COW! I should kill pid $pid stale for ".(time - $start_time)
......@@ -2261,7 +2307,8 @@ sub _domain_working {
}
my $sth = $CONNECTOR->dbh->prepare("SELECT id, status FROM requests "
." WHERE id <> ? AND id_domain=? "
." AND (status <> 'requested' AND status <> 'done' AND command <> 'set_base_vm')");
." AND (status <> 'requested' AND status <> 'done' AND status <> 'waiting' "
." AND command <> 'set_base_vm')");
$sth->execute($id_request, $id_domain);
my ($id, $status) = $sth->fetchrow;
# warn "CHECKING DOMAIN WORKING "
......@@ -2315,9 +2362,9 @@ sub _execute {
}
$request->status('working','') unless $request->status() eq 'waiting';
$request->pid($$);
$request->start_time(time);
$request->error('');
$request->status('working','');
if ($dont_fork || !$CAN_FORK) {
$self->_do_execute_command($sub, $request);
return;
......@@ -2363,7 +2410,6 @@ sub _do_execute_command {
if ($err) {
my $user = $request->defined_arg('user');
if ($user) {
warn "sending message to ".$user->id." ".$user->name;
my $subject = $err;
my $message = '';
if (length($subject) > 40 ) {
......@@ -2463,14 +2509,11 @@ sub _cmd_screenshot {
my $id_domain = $request->args('id_domain');
my $domain = $self->search_domain_by_id($id_domain);
my $bytes = 0;
if (!$domain->can_screenshot) {
die "I can't take a screenshot of the domain ".$domain->name;
} else {
$bytes = $domain->screenshot($request->args('filename'));
$bytes = $domain->screenshot($request->args('filename')) if !$bytes;
}
$request->error("No data received") if !$bytes;
$domain->screenshot();
}
}
sub _cmd_copy_screenshot {
......@@ -2496,6 +2539,28 @@ sub _cmd_copy_screenshot {
}
}
sub _upgrade_screenshots($self) {
my $sth = $CONNECTOR->dbh->prepare(
"SELECT id, name, file_screenshot FROM domains WHERE file_screenshot like '%' "
);
$sth->execute();
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);
eval {
$sth_update->execute(encode_base64($file), $id);
};
warn $@;
}
}
sub _cmd_create{
my $self = shift;
my $request = shift;
......@@ -2575,8 +2640,7 @@ sub _wait_pids {
for my $type ( keys %{$self->{pids}} ) {
for my $pid ( keys %{$self->{pids}->{$type}}) {
my $kid = waitpid($pid , WNOHANG);
last if $kid <= 0 ;
push @done, ($kid);
push @done, ($pid) if $kid == $pid || $kid == -1;
}
}
return if !@done;
......@@ -3381,15 +3445,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);
......@@ -3437,11 +3505,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 {
......@@ -3671,6 +3739,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};
......@@ -3685,8 +3773,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});
......@@ -3734,7 +3827,6 @@ sub _cmd_open_exposed_ports($self, $request) {
}
sub DESTROY($self) {
$self->_wait_pids();
}
=head2 version
......
......@@ -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') {
$algorithm = 'SHA-256' if ! defined $algorithm;
my $salt = encode('ascii',Ravada::Utils::random_name($PBKDF2_SALT_LENGTH));
die "wrong salt length ".length($salt)." != $PBKDF2_SALT_LENGTH"
if length($salt) != $PBKDF2_SALT_LENGTH;
my $iterations = 1024;
my $derive = derive($algorithm
, encode('ascii',$password)
, $salt
, $iterations
, $PBKDF2_HASH_LENGTH);
my $iterations_n = pack('N', $iterations);
die "wrong iterations length ".length($iterations_n)." != $PBKDF2_ITERATIONS_LENGTH"
if length($iterations_n) != $PBKDF2_ITERATIONS_LENGTH;
my $pbkdf2 = $iterations_n.$salt.$derive;
die "wrong pass length ".length($pbkdf2)." != $PBKDF2_LENGTH"
if length($pbkdf2) != $PBKDF2_LENGTH;
$algorithm =~ s/-//;
return "\{PBKDF2_$algorithm}"
.encode_base64($pbkdf2,"");
}
sub _password_rfc2307($password, $algorithm='MD5') {
my $apr=Authen::Passphrase::SaltedDigest->new(passphrase => $password
, algorithm => ($algorithm or 'MD5'));
return $apr->as_rfc2307();
}
=head2 remove_user
Removes the user
......@@ -139,7 +189,7 @@ sub search_user {
my $username = delete $args{name} or confess "Missing user name";
my $retry = (delete $args{retry} or 0);
my $field = (delete $args{field} or 'uid');
my $field = (delete $args{field} or $$CONFIG->{ldap}->{field} or 'uid');
my $ldap = (delete $args{ldap} or _init_ldap_admin());
my $base = (delete $args{base} or _dc_base());
my $typesonly= (delete $args{typesonly} or 0);
......@@ -348,10 +398,11 @@ sub login($self) {
}
$user_ok = $self->_login_bind()
if !exists $$CONFIG->{ldap}->{auth}
|| !$$CONFIG->{ldap}->{auth}
|| $$CONFIG->{ldap}->{auth} =~ /bind|all/i;
$user_ok = $self->_login_match() if !$user_ok;
if !exists $$CONFIG->{ldap}->{auth} || $$CONFIG->{ldap}->{auth} =~ /bind|all/i;
$user_ok = $self->_login_match()
if !$user_ok && exists $$CONFIG->{ldap}->{auth}
&& $$CONFIG->{ldap}->{auth} =~ /match|all/i;
$self->_check_user_profile($self->name) if $user_ok;
$LDAP_ADMIN->unbind if $LDAP_ADMIN && exists $self->{_auth} && $self->{_auth} eq 'bind';
......@@ -364,8 +415,15 @@ sub _login_bind {
my ($username, $password) = ($self->name , $self->password);
my $found = 0;
for my $user (search_user( name => $self->name , field => 'uid' )
,search_user( name => $self->name, field => 'cn')) {
my @user;
if (exists $$CONFIG->{ldap}->{field} && defined $$CONFIG->{ldap}->{field} ) {
@user = search_user( name => $self->name );
} else {
@user = (search_user(name => $self->name, field => 'uid')
,search_user(name => $self->name, field => 'cn'));
}
for my $user (@user) {
my $dn = $user->dn;
$found++;
my $mesg = $LDAP_ADMIN->bind($dn, password => $password);
......@@ -454,7 +512,47 @@ sub _match_password {
# ."\n"
# .sha1_hex($password);
return Authen::Passphrase->from_rfc2307($password_ldap)->match($password);
my ($storage) = $password_ldap =~ /^{([a-z0-9]+)[_}]/i;
my ($password_ldap_hex) = $password_ldap =~ /.*?}(.*)/;
return Authen::Passphrase->from_rfc2307($password_ldap)->match($password)
if $storage =~ /rfc2307|md5/i;
return _match_pbkdf2($password_ldap,$password) if $storage =~ /pbkdf2|SSHA/i;
confess "Error: storage $storage can't do match. Use bind.";
}
sub _ntohl {
return unless defined wantarray;
confess "Wrong number of arguments ($#_) to " . __PACKAGE__ . "::ntohl, called"
if @_ != 1 and !wantarray;
unpack('L*', pack('N*', @_));
}
sub _match_pbkdf2($password_db_64, $password) {
my ($sign,$password_db) = $password_db_64 =~ /(\{.*?})(.*)/;
$password_db=decode_base64($password_db);
my ($algorithm,$n) = $sign =~ /_(.*?)(\d+)}/;
die "password_db length wrong: ".length($password_db)
." != $PBKDF2_LENGTH"
if length($password_db) != $PBKDF2_LENGTH;