Bug fixes.

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