diff options
Diffstat (limited to 'lib/Fripost/Schema/Local.pm')
| -rw-r--r-- | lib/Fripost/Schema/Local.pm | 171 |
1 files changed, 118 insertions, 53 deletions
diff --git a/lib/Fripost/Schema/Local.pm b/lib/Fripost/Schema/Local.pm index d6e32a2..90c37ba 100644 --- a/lib/Fripost/Schema/Local.pm +++ b/lib/Fripost/Schema/Local.pm @@ -17,9 +17,10 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Util qw/concat split_addr canonical_dn +use Fripost::Schema::Mail; +use Fripost::Schema::Util qw/split_addr canonical_dn ldap_error dn2mail softdie email_valid - ldap_assert_absent/; + ldap_assert_absent escape_filter_nostar/; use Net::IDN::Encode qw/email_to_ascii email_to_unicode/; use Net::LDAP::Util 'escape_filter_value'; @@ -51,8 +52,7 @@ An array reference containing UTF-8 strings describing the entry. =item B<isPending> => 0|1 (List only) Whether or not the entry is pending. New lists are always -marked as pending, and it is up to the list manager's side to unlock -them. +marked as pending, and are unlocked on the list manager side. =item B<quota> @@ -75,13 +75,13 @@ B<{SHA}>, B<{SSHA}>, B<{MD5}>, B<{SMD5}>, B<{CRYPT}> or B<{CLEARTEXT}>. =item B<forward> -(User only) An optional array reference containing a (internationalized) +(User only) An optional array reference containing (internationalized) e-mails addresses that will also receive every single message sent to that user. =item B<destination> -(Alias only) An array reference containing a (internationalized) e-mails +(Alias only) An array reference containing (internationalized) e-mails addresses that will receive messages sent to that alias. =item B<transport> mailman|schleuder @@ -108,13 +108,14 @@ The following options are considered: =over 4 -=item B<-no-escape> => 0|1 +=item B<-no-star-escape> => 0|1 By default, the local and domain parts of I<name> - when defined - are -safely escaped before insertion into the LDAP DN and filter. This flag -disables escaping. It is useful if I<name> contains wildcards for -instance. Note that in case the domain part contains wildcard, this -method will query the LDAP server for every single matching domain. +safely escaped before insertion into the LDAP DN and filter. When set, +this flag disables escaping of wildcards (*) in I<name>. It is useful if +I<name> contains wildcards for instance. Note that in case the domain +part contains wildcard, this method will query the LDAP server for every +single matching domain. =item B<-filter> => locked|unlocked @@ -143,7 +144,7 @@ In list context, sort the results per localpart. =back -Errors can be caught with options B<-die> and B<-error>, see +Errors can be caught with options B<-die> and B<-error>; See B<Fripost::Schema::Util> for details. =cut @@ -156,7 +157,6 @@ sub search { # Nothing to do after an error. return if $options{'-error'} && ${$options{'-error'}}; - my @filters; if (defined $options{'-type'}) { # Limit the scope to the given type. @@ -178,10 +178,10 @@ sub search { my @domainnames; if ($domainname) { - if ($options{'-no-escape'} and $domainname =~ /\*/) { + if ($options{'-no-star-escape'}) { # If the domain part contains a wildcard, we have to query # the LDAP server to list the matching domains. - my %opts = ( '-no-escape' => 1, -keys => [ 'name' ]) ; + my %opts = ( '-no-star-escape' => 1, -keys => [ 'name' ]) ; $opts{'-filter'} = 'unlocked'; foreach (qw/-filter -error -die/) { $opts{$_} = $options{$_} if $options{$_}; @@ -191,15 +191,15 @@ sub search { } else { # Otherwise, a single query is enough. - $domainname = Net::LDAP::Util::escape_dn_value($domainname) - unless $options{'-no-escape'}; + $domainname = Net::LDAP::Util::escape_dn_value($domainname); push @domainnames, $domainname; } } if ($localname) { - $localname = Net::LDAP::Util::escape_filter_value($localname) - unless $options{'-no-escape'}; + $localname = $options{'-no-star-escape'} ? + escape_filter_nostar $localname : + Net::LDAP::Util::escape_filter_value $localname; push @filters, 'fvl='.$localname; } @@ -231,7 +231,7 @@ sub search { , deref => 'never' , filter => $filter , attrs => $attrs - ); + ); ldap_error($locals, %options) // return; next unless defined wantarray; # We'll drop the result anyway @@ -360,10 +360,10 @@ sub _keys_to_attrs { } -my %list_commands = ( mailman => [ qw/admin bounces confirm join leave - owner request subscribe unsubscribe/ ] - , schleuder => [ qw/bounce sendkey/ ] - ); +our %list_commands = ( mailman => [ qw/admin bounces confirm join leave + owner request subscribe unsubscribe/ ] + , schleuder => [ qw/bounce sendkey/ ] + ); sub add { my $self = shift; @@ -372,13 +372,11 @@ sub add { # Nothing to do after an error. return if $options{'-error'} && ${$options{'-error'}}; - softdie ("No name specified", %options) // return - unless $local->{name} =~ /^.+\@[^\@]+$/; my $name = $local->{name}; - my ($localname, $domainname) = split_addr($name); # Check validity. &_assert_valid($local, %options) // return; + my ($localname, $domainname) = split_addr($name); my $exists; my $t = $local->{type}; @@ -463,14 +461,20 @@ sub add { return; } - # TODO: send a signed + encrypted mail +# my $member = dn2mail ($self->whoami); +# my $to = email_valid( 'mklist+'.$local->{transport}.'@fripost.org' ); +# Fripost::Schema::Mail::->new( +# From => 'Fripost Admin Panel <AdminWebPanel@fripost.org>', +# To => $to, +# Subject => "New ".$local->{transport}." list", +# Data => [ map { $_ . "\n"} ($local->{name}, $member, $pw) ] +# )->send(-sign => 1, -encrypt => 1); } else { $attrs{objectClass} = $t eq 'user' ? 'FripostVirtualUser' : $t eq 'alias'? 'FripostVirtualAlias' : ''; $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); - # TODO: send a welcome mail? } } @@ -526,7 +530,76 @@ sub _local_to_entry { } +# Create a local alias +sub _mkLocalAlias { + my $name = email_to_ascii(shift); + $name =~ /^(.+)@([^\@]+)/ or return; + return $1.'#'.$2; +} + + +=item B<replace> (I<entry>, I<OPTIONS>) + +Replace the existing entry (user, alias, or list) with the given one. + +=over 4 + +=item B<-dry-run> => 0|1 + +Merely simulate the replacement. I<entry> is still checked to be a valid +entry in the above representation. + +=back + +Errors can be caught with options B<-die> and B<-error>; See +B<Fripost::Schema::Util> for details. + +=cut + +sub replace { + my $self = shift; + my $local = shift; + my %options = @_; + + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + # Check validity. + &_assert_valid($local, %options, -replace => 1) // return; + return 1 if $options{'-dry-run'}; + + my %entry = $self->_local_to_entry (%$local); + my $mesg = $self->ldap->modify( $self->mail2dn($local->{name}) + , replace => \%entry ); + ldap_error($mesg, %options); +} + + + +=item B<delete> (I<name>, I<OPTIONS>) + +Delete the given user, alias or list I<name>. + +Errors can be caught with options B<-die> and B<-error>; See +B<Fripost::Schema::Util> for details. + +=cut + +sub delete { + my $self = shift; + my $name = shift; + my %options = @_; + + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + my $mesg = $self->ldap->delete( $self->mail2dn($name) ); + ldap_error($mesg, %options); +} + + +# Ensure that the given entry is valid. sub _assert_valid { my $l = shift; my %options = @_; @@ -534,21 +607,23 @@ sub _assert_valid { die "Unspecified type\n" unless defined $l->{type}; die "Unknown type ‘".$l->{type}."’\n" unless grep { $l->{type} eq $_ } qw/user alias list/; + + die "Unspecified name\n" unless $l->{name} =~ /^.+\@[^\@]+$/; my ($u, $d) = split_addr($l->{name}, -encode => 'ascii'); - return unless $u && $d; - # ^ To avoid unicode issues. - die "Recipient delimiter ‘+’ is not allowed in locaparts\n" - if $u =~ /\+/; # TODO: should be a config option - $l->{name} = email_valid( $u.'@'.$d, -exact => 1 ); + return unless $u and $d; + my $del = $options{recipient_delimiter} // '+'; + die "Recipient delimiter ‘".$del."’ is not allowed in locaparts\n" + if $u =~ /\Q$del\E/; + $l->{name} = email_valid( $l->{name}, -exact => 1 ); unless ($options{'-append'} or $options{'-replace'}) { - my @must = qw/name isActive/; + my @must; push @must, $l->{type} eq 'user' ? 'password' : - # TODO: ^ match 'quota' against the Dovecot specifications + # TODO: ^ match 'quota' against the Dovecot specifications? $l->{type} eq 'alias' ? 'destination' : $l->{type} eq 'list' ? qw/transport password/ : (); - Fripost::Schema::Util::must_attrs( $l, @must ); + Fripost::Schema::Util::mandatory_attrs( $l, @must ); } if ($l->{type} eq 'user') { @@ -556,41 +631,31 @@ sub _assert_valid { if $l->{forward}; } elsif ($l->{type} eq 'alias') { - $a->{destination} = [ map { email_valid($_) } @{$l->{destination}} ] + $l->{destination} = [ map { email_valid($_) } @{$l->{destination}} ] if $l->{destination}; } elsif ($l->{type} eq 'list') { + # The list manager won't allow arbitrary names. die "Invalid list name: ‘".$l->{name}."’\n" unless $u =~ /^[[:alnum:]_=\+\-\.]+$/; + # The list manager has to distinguish posts to commands. die "Invalid list name: ‘".$l->{name}."’\n" if defined $l->{transport} and - grep {$u =~ /-$_$/} @{$list_commands{$l->{transport}}}; + grep {$u =~ /-\Q$_\E$/} @{$list_commands{$l->{transport}}}; die "Invalid transport: ‘".$l->{transport}."’\n" if defined $l->{transport} and - not grep { $l->{transport} eq $_ } qw/schleuder mailman/; + not grep { $l->{transport} eq $_ } (keys %list_commands); $l->{transport} //= 'mailman' unless $options{'-append'} or $options{'-replace'}; } - + $l->{isActive} //= 1 unless $options{'-append'} or $options{'-replace'}; }; softdie ($@, %options); } -sub _mkLocalAlias { - my $name = email_to_ascii(shift); - $name =~ /^(.+)@([^\@]+)/ or return; - return $1.'#'.$2; -} - - - - - - - |