aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem.moulin@fripost.org>2013-01-29 02:37:58 +0100
committerGuilhem Moulin <guilhem.moulin@fripost.org>2013-01-29 02:37:58 +0100
commit7b81775603b8208c995cd1c4a15cd2a287009404 (patch)
treef8946c7eff5b1c8de2e3b6ee7944f8e5180891cc /lib
parentae6b8a2905bfc7905030479e06f3490f2c901099 (diff)
Bug fixes.
Diffstat (limited to 'lib')
-rw-r--r--lib/Fripost/Panel/Interface.pm38
-rw-r--r--lib/Fripost/Panel/Login.pm6
-rw-r--r--lib/Fripost/Schema.pm3
-rw-r--r--lib/Fripost/Schema/Auth.pm5
-rw-r--r--lib/Fripost/Schema/Domain.pm58
-rw-r--r--lib/Fripost/Schema/Util.pm79
6 files changed, 107 insertions, 82 deletions
diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm
index eb9d69a..a0c9dd9 100644
--- a/lib/Fripost/Panel/Interface.pm
+++ b/lib/Fripost/Panel/Interface.pm
@@ -19,7 +19,7 @@ use Fripost::Password;
use HTML::Entities 'encode_entities';
use URI::Escape::XS 'encodeURIComponent';
use Net::IDN::Encode qw/email_to_unicode email_to_ascii domain_to_ascii/;
-use Encode;
+use Encode ();
# This method is called right before the 'setup' method below. It
@@ -139,12 +139,11 @@ sub EditDomain : Runmode {
my $self = shift;
my %CFG = $self->cfg;
- # Get the domain name from the URL.
- my $domainname = ($self->split_path)[1];
-
my $q = $self->query;
return $self->redirect('./') if defined $q->param('cancel'); # Cancellation
+ # Get the domain name from the URL.
+ my $domainname = ($self->split_path)[1];
my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
my $error; # Tells whether the change submission has failed.
@@ -185,10 +184,13 @@ sub ListLocals : Runmode {
my $self = shift;
my %CFG = $self->cfg;
+ my $q = $self->query;
+ return $self->redirect('./') if defined $q->param('cancel'); # Cancellation
+
+ # Get the domain name from the URL.
my $domainname = ($self->split_path)[1];
my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
- my $q = $self->query;
if (defined $q->param('unlock')) {
# Unlock the domain, and come back to the home page.
# Errors are thrown away.
@@ -512,37 +514,18 @@ sub mkURL {
join '/', ($host, @path);
}
-sub mkLink {
- my $k = shift;
- my $d = shift;
- ( $k => encode_entities($d),
- $k.'URL' => &mkURL('.', $d) )
-}
-
sub userInfo {
my $self = shift;
my ($l,$d) = split_addr( $self->authen->username, -encode => 'unicode' );
my $root = $ENV{SCRIPT_NAME} // $self->cfg->{'cgi-bin'} // '';
$root =~ s@/$@@s;
- ( user_localpart => encode_entities($l)
+ ( user_localpart => encode_entities($l)
, user_domainpart => encode_entities($d)
- , userURL => &mkURL ($root, $d, $l)
+ , user_URL => &mkURL ($root, $d, $l)
)
}
-sub mkFormContentE { # TODO delete
- &mkFormContent (map { encode_entities ($_) } @_);
-}
-
-sub mkFormContent { # TODO delete
- join ("\x{0D}\x{0A}", @_);
-}
-
-sub mkDesc { # TODO delete
- my $desc = shift // return '';
- join '<br>', map {encode_entities($_)} @$desc;
-}
my @single_valued_keys = qw/isActive quota/;
my @multi_valued_keys = qw/description catchAll
@@ -561,7 +544,8 @@ sub fill_HTML_template_from_entry {
if ($key eq 'name') {
$vars{$key} = encode_entities($entry->{$key});
}
- elsif (grep {$key eq $_} ('URL', 'listURL', @single_valued_keys)) {
+ elsif (grep {$key eq $_} (qw/URL list_URL transport/,
+ @single_valued_keys)) {
$vars{$key} = $entry->{$key};
}
elsif (grep {$key eq $_} @multi_valued_keys) {
diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm
index 1eabafb..22a870a 100644
--- a/lib/Fripost/Panel/Login.pm
+++ b/lib/Fripost/Panel/Login.pm
@@ -23,7 +23,7 @@ use Fripost::Schema::Util 'split_addr';
use HTML::Entities 'encode_entities';
use URI::Escape::XS 'decodeURIComponent';
-use Encode;
+use Encode ();
# This method is called right before the 'setup' method below. It
# initializes the session and authentication configurations.
@@ -56,9 +56,7 @@ sub cgiapp_init {
$self->authen->config(
DRIVER => [ 'Generic', sub {
my ($u,$p) = @_;
- my $d = (split_addr($u))[1];
-
- unless (defined $d) {
+ unless ($u =~ /\@/) {
$CFG{default_realm} // return 0;
$u .= '@'.$CFG{default_realm};
}
diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm
index 7526077..42ebac5 100644
--- a/lib/Fripost/Schema.pm
+++ b/lib/Fripost/Schema.pm
@@ -19,15 +19,12 @@ use warnings;
use utf8;
use parent 'Fripost::Schema::Auth';
-use Net::LDAP;
-use Authen::SASL;
use Fripost::Schema::Util qw/canonical_dn ldap_explode_dn split_addr/;
use Fripost::Schema::Domain;
use Fripost::Schema::User;
use Fripost::Schema::Alias;
use Fripost::Schema::List;
use Fripost::Schema::Local;
-use Net::IDN::Encode 'email_to_ascii';
=head1 METHODS
diff --git a/lib/Fripost/Schema/Auth.pm b/lib/Fripost/Schema/Auth.pm
index c6325b8..d9c0267 100644
--- a/lib/Fripost/Schema/Auth.pm
+++ b/lib/Fripost/Schema/Auth.pm
@@ -253,10 +253,7 @@ converted to ASCII.
sub mail2dn {
my $self = shift;
- my $user = shift // return;
-
- $user =~ s/^([^\@]+)$/\@$1/;
- my ($l,$d) = split_addr($user, -encode => 'ascii');
+ my ($l,$d) = split_addr(shift, -encode => 'ascii') or return;
my @dn = ({fvd => $d}, @{$self->suffix});
unshift @dn, {fvl => $l} if $l;
diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm
index 3caffb5..4cc12e4 100644
--- a/lib/Fripost/Schema/Domain.pm
+++ b/lib/Fripost/Schema/Domain.pm
@@ -18,11 +18,12 @@ use utf8;
use parent 'Fripost::Schema';
use Fripost::Schema::Util qw/softdie dn2mail email_valid domain_valid
- canonical_dn ldap_explode_dn ldap_error/;
+ canonical_dn ldap_explode_dn ldap_error
+ ldap_assert_absent/;
use Fripost::Schema::Mail;
use Net::IDN::Encode qw/domain_to_ascii domain_to_unicode email_to_unicode/;
use URI::Escape::XS 'encodeURIComponent';
-use Encode;
+use Encode ();
use Net::Domain::TLD 'tld_exists';
use Net::DNS::Dig;
use Net::Whois::Parser 'parse_whois';
@@ -280,7 +281,7 @@ sub _entries_to_domains {
if not @$keys or grep { $_ eq 'description' } @$keys;
}
else {
- die "Missing translation for domain attribute ‘".$attr."’.";
+ die "Missing translation for domain attribute ‘".$attr."’";
}
}
@@ -327,7 +328,7 @@ sub _keys_to_attrs {
);
my %attrs;
foreach my $k (@_) {
- die "Missing translation for key ‘".$k."’."
+ die "Missing translation for key ‘".$k."’"
unless exists $map{$k};
if (ref $map{$k} eq 'ARRAY') {
$attrs{$_} = 1 for @{$map{$k}};
@@ -410,7 +411,7 @@ sub list_owner_emails {
my $domain;
until ( tld_exists($tld) ) {
- softdie ("‘".$domainname."’ has an Invalid TLD.", %options) // return
+ softdie ("‘".$domainname."’ has an Invalid TLD", %options) // return
unless $tld =~ /\./;
$domain = $tld;
@@ -495,25 +496,33 @@ sub add {
my $domainname = $domain->{name};
# Check domain validity.
- &_is_valid($domain, %options) // return;
- my $dn = $self->mail2dn( $domain->{name} );
-
- # Search for an existing domain with the same name.
- my $count = $self->search($domain->{name}, %options, '-count' => 1);
- softdie ( "Domain ‘".$domainname."’ already exists.", %options ) // return
- if not $options{'-append'} and $count;
- # Stop here in dry-run mode.
- return 1 if $options{'-dry-run'};
+ &_assert_valid($domain, %options) // return;
+
+ my $exists;
+ if ($options{'-dry-run'} or $options{'-append'}) {
+ # Search for an existing domain with the same name. We can't
+ # use our previously defined method here, since the current user
+ # may not have read access to the entry. There is a race
+ # condition since someone could modify the directory between
+ # this check and the actual insertion, but then the insertion
+ # would fail.
+ $exists = ldap_assert_absent( $self, $domain->{name}, undef, %options)
+ // return;
+ return 1 if $options{'-dry-run'};
+ }
# Convert the domain into a LDAP entry, and remove keys to empty values.
my %attrs = $self->_domain_to_entry (%$domain);
- Fripost::Schema::Util::clean_ldap_entry( \%attrs );
+ Fripost::Schema::Util::ldap_clean_entry( \%attrs );
my ($mesg, $token);
- if ($options{'-append'} and $count) {
+ my $dn = $self->mail2dn( $domain->{name} );
+ if ($options{'-append'} and $exists) {
# Replace single valued attributes; Add other attributes.
- my %unique = ( fripostIsStatusActive => $attrs{fripostIsStatusActive} );
- delete $attrs{$_} for (keys %unique);
+ my %unique;
+ foreach (qw/fripostIsStatusActive/) {
+ $unique{$_} = delete $attrs{$_} if exists $attrs{$_};
+ }
$mesg = $self->ldap->modify( $dn, replace => \%unique, add => \%attrs );
}
else {
@@ -528,6 +537,10 @@ sub add {
}
# The default owner is the current user.
$attrs{fripostOwner} //= [ $self->whoami ];
+ $options{'-die'} = { Net::LDAP::Constant::LDAP_ALREADY_EXISTS =>
+ "‘".$domainname."’ exists"
+ , Net::LDAP::Constant::LDAP_SUCCESS => 0 }
+ unless exists $options{'-die'};
$mesg = $self->ldap->add( $dn, attrs => [ %attrs ] );
}
@@ -594,7 +607,7 @@ sub _domain_to_entry {
[ map { $self->mail2dn($_) } @{$domain{postmaster}} ];
}
else {
- die "Missing translation for domain key ‘".$key."’.";
+ die "Missing translation for domain key ‘".$key."’";
}
}
return %entry;
@@ -681,7 +694,7 @@ sub replace {
return if $options{'-error'} && ${$options{'-error'}};
# Check domain validity.
- &_is_valid($domain, %options) // return;
+ &_assert_valid($domain, %options, -replace => 1) // return;
return 1 if $options{'-dry-run'};
my %entry = $self->_domain_to_entry (%$domain);
@@ -693,11 +706,12 @@ sub replace {
# Ensure that the given domain is valid.
-sub _is_valid {
+sub _assert_valid {
my $d = shift;
my %options = @_;
eval {
- Fripost::Schema::Util::must_attrs( $d, qw/name isActive/ );
+ Fripost::Schema::Util::must_attrs( $d, qw/name isActive/ )
+ unless $options{'-append'} or $options{'-replace'};
$d->{name} = domain_valid( domain_to_ascii ($d->{name}) );
$d->{catchAll} = [ map { email_valid($_, -prefix => 'fake') }
@{$d->{catchAll}} ]
diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm
index 59d724f..b3439cc 100644
--- a/lib/Fripost/Schema/Util.pm
+++ b/lib/Fripost/Schema/Util.pm
@@ -15,10 +15,11 @@ use Exporter 'import';
our @EXPORT_OK = qw /concat get_perms explode
must_attrs domain_valid email_valid split_addr dn2mail
canonical_dn ldap_explode_dn ldap_error ldap_and_filter
- clean_ldap_entry
- assert softdie/;
+ ldap_clean_entry
+ assert ldap_assert_absent softdie/;
use Email::Valid;
-use Net::IDN::Encode qw/domain_to_unicode email_to_unicode/;
+use Net::IDN::Encode qw/domain_to_unicode email_to_unicode
+ domain_to_ascii email_to_ascii/;
use Net::LDAP::Util;
use Encode;
@@ -89,7 +90,7 @@ sub get_perms {
sub must_attrs {
my $h = shift;
foreach (@_) {
- die 'Missing attribute: ‘'.$_."’\n"
+ die 'Missing value: ‘'.$_."’\n"
unless defined $h->{$_} and
(ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '')
}
@@ -110,14 +111,17 @@ sub email_valid {
$in = $options{'-prefix'}.$i if defined $options{'-prefix'};
Encode::_utf8_on($in);
Encode::_utf8_on($i);
- $in = Net::IDN::Encode::email_to_ascii($in);
-
- my $addr = Email::Valid::->address( -address => $in,
- -tldcheck => 1,
- -fqdn => 1 );
- my $match = defined $addr;
- $match &&= $addr eq $in if $options{'-exact'};
- unless ($match) {
+
+ my ($addr, $match);
+ eval {
+ $in = Net::IDN::Encode::email_to_ascii($in);
+ $addr = Email::Valid::->address( -address => $in,
+ -tldcheck => 1,
+ -fqdn => 1 );
+ $match = defined $addr;
+ $match &&= $addr eq $in if $options{'-exact'};
+ };
+ if ($@ || !$match) {
return if $options{'-nodie'};
die $mesg." ‘".$i."’\n";
}
@@ -157,24 +161,33 @@ sub split_addr {
my $addr = shift // return;
my %options = @_;
- $addr =~ /^(.*)\@([^\@]+)$/s;
- my ($l,$d) = ($1, $2);
-
+ Encode::_utf8_on($addr);
+ my $mesg = $addr =~ /\@/ ? "Invalid e-mail ‘".$addr."’" :
+ "Invalid domain ‘".$addr."’";
+ my $ret;
if (defined $options{'-encode'}) {
my $e = $options{'-encode'};
if ($e eq 'ascii') {
- Encode::_utf8_on($d);
- $d = Net::IDN::Encode::domain_to_ascii($d);
+ eval { $addr = $addr =~ /\@/ ? email_to_ascii($addr)
+ : domain_to_ascii($addr);
+ };
+ $ret = $@;
}
elsif ($e eq 'unicode') {
- $d = Net::IDN::Encode::domain_to_unicode($d);
+ eval { $addr = $addr =~ /\@/ ? email_to_unicode($addr)
+ : domain_to_unicode($addr);
+ };
+ $ret = $@;
}
else {
- softdie ("Unknown encoding: ". $e, %options);
- return;
+ die "Unknown encoding ‘".$e."’";
}
}
- return ($l,$d);
+ softdie ($mesg, %options) // return if $ret;
+ return ('',$addr) unless $addr =~ /\@/;
+
+ $addr =~ /^(.*)\@([^\@]+)$/;
+ return ($1,$2);
}
sub ldap_error {
@@ -252,7 +265,7 @@ sub ldap_and_filter {
}
-sub clean_ldap_entry {
+sub ldap_clean_entry {
my $attrs = shift;
foreach (keys %$attrs) {
@@ -270,6 +283,28 @@ sub clean_ldap_entry {
}
}
+sub ldap_assert_absent {
+ my $self = shift;
+ my $name = shift;
+ my $found = shift // "‘".$name."’ exists";
+ my %options = @_;
+
+ my $mesg = $self->ldap->search( base => $self->mail2dn( $name )
+ , scope => 'base'
+ , deref => 'never'
+ , filter => '(objectClass=*)'
+ , attrs => [ '1.1' ]
+ );
+ $options{'-die'} = { Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT => 0
+ , Net::LDAP::Constant::LDAP_SUCCESS =>
+ $options{'-append'} ? 0 : $found
+ };
+ ldap_error($mesg, %options) // return;
+ return $mesg->code eq Net::LDAP::Constant::LDAP_SUCCESS ? 1 :
+ $mesg->code eq Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT ? 0 :
+ undef
+}
+
=head1 AUTHOR
Guilhem Moulin C<< <guilhem at fripost.org> >>