Better checks for existing entries.

5 files changed, 39 insertions, 13 deletions

diff --git a/INSTALL b/INSTALL
index e40587b..4027c9d 100644
--- a/INSTALL
+++ b/INSTALL
@@ -20,6 +20,7 @@ apt-get install libnet-ldap-perl \
                 libdigest-perl \
                 libstring-mkpasswd-perl \
                 libnet-idn-encode-perl \
+                liburi-escape-xs-perl \
                 libmail-gnupg-perl
 
 
diff --git a/TODO.org b/TODO.org
index d9aa4a1..c8600ce 100644
--- a/TODO.org
+++ b/TODO.org
@@ -4,11 +4,11 @@ domains/emails to Punycode internally?
 
 * TODO What to do when a user wants to add a domain? Is it worth it to send a confirmation e-mail?
 
-* TODO Better check for existing lists (commands).
+* DONE Better check for existing lists (commands).
 - When adding a new alias/mailbox 'test', check for existing alias/mailbox 'test', and list 'test'.
 - When adding a new alias/mailbox 'test-request', check for existing alias/mailbox 'test-request', list 'test-request' *and* list 'test'. (The same for other list commands.)
 - When adding a new list 'test', check for existing alias/mailbox/list 'test', 'test-request',...
-- When adding a new list 'test-request', check for existing alias/mailbox/list 'test-request', 'test-request-request',... *and* list 'test'. (The same for other list commands.)
+- (Lists of the form 'test-request' are forbidden);
 
 * TODO Check for cycles when creating new aliases?
 (It is impossible since the authenticated user may not have full read access on the graph)
@@ -31,7 +31,7 @@ http://mark.stosberg.com/blog/2010/12/percent-encoding-uris-in-perl.html
 * CANCELED How should we encode the URL for internationalized domain names? Punicode vs. unicode vs. HTML entities?
 CLOSED: [2012-09-27 Thu 00:03]
 - CLOSING NOTE [2012-09-27 Thu 00:03] \\
-It's up to the browser (Firefox support unicode in URLs).
+It's up to the browser (Firefox supports unicode in URLs).
 
 * CANCELED Forbid UTF8 in the domain part of lists? (Test if the list
 managers support it at least.)
@@ -40,15 +40,15 @@ CLOSED: [2012-09-27 Thu 03:38]
 Mailman and Schleuder do not support IDNs, but we convert the list name
 into punicode first.
 
-* TODO Give the right for domain owners and postmaster to grant the right
+* TODO Give the right for domain owners and postmasters to grant the right
 to create aliases and lists.
 
 * TODO Give the right to appoint co owners (for list and aliases).
 
 * TODO Make every service use Kerberos, and remove the passphrase on
-their private keys.
+their GPG private keys.
 
-* TODO Check list names against mailman's and schleuder's regexps?
+* DONE Check list names against mailman's and schleuder's regexps?
 
 * TODO What to do when a list creation fails? Set up a new service
 to clean out the pending lists and domains if they have not been fixed
diff --git a/cgi-bin/index.fcgi b/cgi-bin/index.fcgi
index 8e551d8..5c73463 100755
--- a/cgi-bin/index.fcgi
+++ b/cgi-bin/index.fcgi
@@ -15,7 +15,7 @@ use CGI::Fast ();
 use File::Spec::Functions 'catfile';
 use lib 'lib';
 use Fripost::Panel::Interface;
-
+use CGI::Carp 'fatalsToBrowser';
 
 my $config_dir = '/etc/fripost-panel';
 my @config = catfile ('./', 'default.in');
diff --git a/lib/Fripost/Schema/List.pm b/lib/Fripost/Schema/List.pm
index 67da859..ad06b50 100644
--- a/lib/Fripost/Schema/List.pm
+++ b/lib/Fripost/Schema/List.pm
@@ -120,7 +120,7 @@ sub add {
         must_attrs( $l, 'transport' );
         &_is_valid($l);
         die "‘".$l->{list}."’ already exists\n"
-            if $self->local->exists($l->{list},%options);
+            if $self->local->exists( $l->{list}, t => 'list', %options );
 
         my %attrs = ( objectClass => 'FripostVirtualList'
                     , fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE'
@@ -267,10 +267,16 @@ sub _is_valid {
     must_attrs( $l, qw/list isactive/ );
     $l->{list} = email_valid( $l->{list}, -exact => 1 );
 
+    my ($l2,$d) = split /\@/, $l->{list}, 2;
+    foreach ( qw/admin bounces confirm join leave owner request subscribe unsubscribe bounce sendkey/ ){
+        die "Invalid list name: ‘".$l->{list}."’\n" if $l2 =~ /-$_$/;
+    }
+    die "Invalid list name: ‘".$l->{list}."’\n"
+        unless $l->{list} =~ /^[[:alnum:]_=\+\-\.\@]+$/;
+
     die "Invalid transport: ‘".$l->{transport}."’\n"
         if defined $l->{transport} and
             $l->{transport} !~ /^(schleuder|mailman)$/;
-    # TODO: check commands
 }
 
 
diff --git a/lib/Fripost/Schema/Local.pm b/lib/Fripost/Schema/Local.pm
index f497a4e..49c3d68 100644
--- a/lib/Fripost/Schema/Local.pm
+++ b/lib/Fripost/Schema/Local.pm
@@ -115,11 +115,29 @@ sub exists {
     # The trick is somewhat dirty, but it's safe enough since postfix
     # delivers to mailboxes, aliases, and lists with different
     # priorities (and lists have the lowest).
-#    $l =~ s/(.*)-(admin|bounces|confirm|join|leave|loop|owner|request|subscribe|unsubscribe|bounce|sendkey)$/$1/;
-    # ^ TODO
+    my @cmds = qw/admin bounces confirm join leave owner request subscribe unsubscribe bounce sendkey/;
+    my @tests = ( 'fvu='.$l, 'fva='.$l, 'fvl='.$l );
+
+    foreach (@cmds) {
+        # If the entry is of the form 'foo-command', we need to ensure
+        # that no list 'foo' exists, otherwise the new entry would
+        # override foo's command.
+        if ($l =~ s/-$_$//) {
+            push @tests, 'fvl='.$l;
+            last;
+        }
+    }
+    if (defined $options{t} and $options{t} eq 'list') {
+        # If that's a list that is to be created, we need to ensure that
+        # none of its commands exists.
+        foreach (@cmds) {
+            my $l2 = $l.'-'.$_;
+            push @tests, 'fvu='.$l2, 'fva='.$l2;
+        }
+    }
 
-    foreach my $t (qw/fvu fva fvl/) {
-        my $mesg = $self->ldap->search( base => "$t=$l,fvd=$d,".$self->suffix,
+    foreach (@tests) {
+        my $mesg = $self->ldap->search( base => "$_,fvd=$d,".$self->suffix,
                                         scope => 'base',
                                         deref => 'never',
                                         filter => 'objectClass=*'
@@ -129,6 +147,7 @@ sub exists {
             die $options{'-die'}."\n" if defined $options{'-die'};
             die $mesg->error."\n";
         }
+        
     }
     return 0;
 }