Bug fixes.

3 files changed, 94 insertions, 48 deletions

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> >>