diff options
Diffstat (limited to 'lib/Fripost')
| -rw-r--r-- | lib/Fripost/Panel/Interface.pm | 88 | ||||
| -rw-r--r-- | lib/Fripost/Panel/Login.pm | 9 | ||||
| -rw-r--r-- | lib/Fripost/Schema.pm | 26 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Alias.pm | 201 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Auth.pm | 13 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Domain.pm | 143 | ||||
| -rw-r--r-- | lib/Fripost/Schema/List.pm | 306 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Local.pm | 171 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Mail.pm | 5 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Password.pm (renamed from lib/Fripost/Password.pm) | 4 | ||||
| -rw-r--r-- | lib/Fripost/Schema/User.pm | 231 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Util.pm | 99 |
12 files changed, 274 insertions, 1022 deletions
diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm index 7f7d770..b2ad686 100644 --- a/lib/Fripost/Panel/Interface.pm +++ b/lib/Fripost/Panel/Interface.pm @@ -15,7 +15,7 @@ use parent 'Fripost::Panel::Login'; use Fripost::Schema; use Fripost::Schema::Util 'split_addr'; -use Fripost::Password; +use Fripost::Schema::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/; @@ -72,7 +72,7 @@ sub AddDomain : Runmode { Encode::_utf8_on($domainname) if defined $domainname; my $session_param; - $session_param = 'AddDomain-owner-emails-'.domain_to_ascii($domainname) + $session_param = 'AddDomain-Owner-Emails-'.domain_to_ascii($domainname) if defined $domainname; my $error; # Tells whether the change submission has failed. @@ -83,7 +83,8 @@ sub AddDomain : Runmode { if (defined $q->param('owner') and defined $session_param) { # Ensure that the user didn't spoof the domain ownership. my @owners = split "\0", $self->session->param($session_param); - $error = "‘".$q->param('owner')."’ was not listed among the domain owners." + $error = "‘".$q->param('owner'). + "’ was not listed among the domain owners" unless defined $self->session->param($session_param) and grep { $q->param('owner') eq $_ } @owners; } @@ -107,14 +108,16 @@ sub AddDomain : Runmode { if (!$error and defined $domainname) { $tmpl_file = 'add-domain-2.html'; + my @exclude = qw/fripost.org/; @owners = Fripost::Schema::Domain::->list_owner_emails - ( $domainname, -error => \$error ); + ( $domainname, -error => \$error + ,'-ignore-MX' => \@exclude ); undef $tmpl_file if $error; } # Something went wrong, or the domain is unknown $tmpl_file //= 'add-domain-1.html'; - my $template = $self->load_tmpl( $tmpl_file, cache => 1, + my $template = $self->load_tmpl( $tmpl_file, cache => 1 , loop_context_vars => 1 ); $template->param( $self->userInfo ); $template->param( error => encode_entities ($error) ) if $error; @@ -125,7 +128,8 @@ sub AddDomain : Runmode { # spoofed email. $self->session->param( $session_param, join("\0", @owners) ); $self->session->flush; - $template->param( owners => [ map {{owner => $_}} @owners ] ) + $template->param( owners => + [ map {{owner => encode_entities $_}} @owners ] ) } return $template->output; @@ -158,7 +162,7 @@ sub EditDomain : Runmode { // die "404\n"; $fp->done; - my $template = $self->load_tmpl( 'edit-domain.html', cache => 1, + my $template = $self->load_tmpl( 'edit-domain.html', cache => 1 , loop_context_vars => 1 ); $template->param( $self->userInfo ); $template->param( isPostmaster => $domain->{permissions} =~ /p/ ); @@ -194,11 +198,17 @@ sub ListLocals : Runmode { if (defined $q->param('unlock')) { # Unlock the domain, and come back to the home page. # Errors are thrown away. - $fp->domain->unlock( $domainname, $q->param('unlock'), -error => undef ) + $fp->pending->unlock( $domainname, $q->param('unlock'), -error => undef ) if $q->param('unlock') ne ''; $fp->done; return $self->redirect('../'); } + if (defined $q->param('a') and $q->param('a') eq 'delete') { + # Delete the domain. + $fp->local->delete($domainname, -error => undef ); + $fp->done; + return $self->redirect('../'); + } # Query *the* matching domain, or 404. my $domain = $fp->domain->search( $domainname, -filter => 'unlocked' ) @@ -207,8 +217,8 @@ sub ListLocals : Runmode { # Query the users, aliases and lists under the given domain. my @locals = $fp->local->search ( $domainname, sort => 1); $fp->done; - map { $_->{name} = (split_addr $_->{name})[0]; # Remove the domainpart - $_->{URL} = &mkURL('.', $_->{name}) } # Add a URL + map { $_->{name}= (split_addr $_->{name})[0]; # Remove the domainpart + $_->{URL} = &mkURL('.', $_->{name}) }# Add a URL @locals; my @users = grep { $_->{type} eq 'user' } @locals; @@ -220,7 +230,7 @@ sub ListLocals : Runmode { email_to_ascii($_->{name}.'@'.$domainname) } @lists; - my $template = $self->load_tmpl( 'list-locals.html', cache => 1, + my $template = $self->load_tmpl( 'list-locals.html', cache => 1 , loop_context_vars => 1 ); $template->param( $self->userInfo ); @@ -243,7 +253,7 @@ sub ListLocals : Runmode { # Can the user add aliases? $template->param( canAddalias => $domain->{permissions} =~ /[aop]/ ); - $template->param( listCanAddAlias => [ map { {item => encode_entities($_)} } + $template->param( listCanAddAlias => [ map { {item => encode_entities $_} } @{$domain->{canAddAlias}} ] ) if $domain->{permissions} =~ /[op]/; # Should we list aliases? @@ -255,7 +265,7 @@ sub ListLocals : Runmode { # Can the user add lists? $template->param( canAddList => $domain->{permissions} =~ /[lop]/ ); - $template->param( listCanAddList => [ map { {item => encode_entities($_)} } + $template->param( listCanAddList => [ map { {item => encode_entities $_} } @{$domain->{canAddList}} ] ) if $domain->{permissions} =~ /[op]/; # Should we list lists? @@ -282,7 +292,7 @@ sub AddLocal : Runmode { # Get the domain name from the URL. my $domainname = ($self->split_path)[1]; - my $t = $q->param('t') // return $self->redirect('./'); + my $t = $q->param('t') or return $self->redirect('./'); return $self->redirect('./') unless grep { $t eq $_ } qw/user alias list/; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); @@ -305,10 +315,12 @@ sub AddLocal : Runmode { ." characters long."; } else { - $local->{password} = Fripost::Password::hash($q->param('password')); + $local->{password} = + Fripost::Schema::Password::hash($q->param('password')); } # TODO: inherit the user quota from the postmaster's? } + # Password needs special care $local->{password} = $q->param('password') if $t eq 'list'; $rest{gpg} = { use_agent => 0 @@ -334,11 +346,14 @@ sub AddLocal : Runmode { $template->param( $self->userInfo , domainname => encode_entities($domainname) , &fill_HTML_template_from_query ($q)); - $template->param( transport => - [ { item => 'mailman', selected => $q->param('transport') eq 'mailman', name => 'GNU Mailman' } - , { item => 'schleuder', selected => $q->param('transport') eq 'schleuder', name => 'Schleuder' } - ]) # TODO ugly - if $t eq 'list' and defined $q->param('transport'); + $template->param( transport => [ + map { { item => $_ + , name => ucfirst $_ + , selected => $q->param('transport') eq $_ + } } + (keys %Fripost::Schema::Local::list_commands) + ] ) + if $t eq 'list'; $template->param( error => encode_entities ($error) ) if $error; return $template->output; } @@ -361,8 +376,6 @@ sub EditLocal : Runmode { # Search for *the* matching user, alias or list. $fp->domain->search ($domainname, -filter => 'unlocked', -count => 1) or die "404\n"; - my $local = $fp->local->search ($name, -filter => 'unlocked') - or die "404\n"; my $error; # Tells whether the change submission has failed. if (defined $q->param('a') and $q->param('a') eq 'delete') { @@ -373,13 +386,15 @@ sub EditLocal : Runmode { return $self->redirect('../'); } } - $fp->done; + my $local = $fp->local->search ($name, -filter => 'unlocked') + or die "404\n"; + my $t = $local->{type}; if (defined $q->param('submit')) { # Changes have been submitted: process them my $local = &parse_CGI_query($q); - $local->{type} = $q->param('t'); $local->{name} = $name; + $local->{type} = $t; my %rest; if ($q->param('password') || $q->param('password2')) { @@ -397,26 +412,18 @@ sub EditLocal : Runmode { $local->{password} = Fripost::Password::hash($q->param('password')); } } + $fp->local->replace($local, -error => \$error); } + $fp->done; # Do not send passwords back to the sender. $q->delete(qw/password password2/); - my $t = $local->{type}; my $template = $self->load_tmpl( "edit-$t.html", cache => 1 ); $template->param( $self->userInfo , localpart => encode_entities($localname) , domainpart => encode_entities($domainname) ); - - if ($error) { - # Preserve the (incorrect) form, except the passwords - $template->param( &fill_HTML_template_from_query ($q) ); - } - else { - $template->param( &fill_HTML_template_from_entry ($local, - -hide => [qw/quota transport/]) ); - } - # TODO: submit + $template->param( &fill_HTML_template_from_query ($q) ); my $news = (defined $q->param('submit') or (defined $q->param('a') and $q->param('a') eq 'delete')); $template->param( newChanges => $news ); @@ -471,7 +478,7 @@ sub fill_HTML_template_from_entry { } elsif (grep {$key eq $_} (qw/URL list_URL transport/, @single_valued_keys)) { - $vars{$key} = $entry->{$key}; + $vars{$key} = encode_entities($entry->{$key}); } elsif (grep {$key eq $_} @multi_valued_keys) { my @array = map { encode_entities ($_) } @{$entry->{$key}}; @@ -492,9 +499,11 @@ sub fill_HTML_template_from_query { my %rest = @_; my %vars; - $params{$_} = encode_entities ($rest{$_}) for keys %rest; + $params{$_} = $rest{$_} for keys %rest; foreach my $key (keys %params) { - $vars{$key} = $params{$key} // undef + next unless defined $params{$key}; + Encode::_utf8_on($params{$key}); + $vars{$key} = encode_entities($params{$key}) if grep { $key eq $_ } ('name', @single_valued_keys, @multi_valued_keys); } $vars{isActive} //= 1; @@ -508,8 +517,9 @@ sub parse_CGI_query { $params{$_} = $rest{$_} for keys %rest; foreach my $key (keys %params) { + next unless defined $params{$key}; Encode::_utf8_on($params{$key}) if defined $params{$key}; - if ($key eq 'name') { + if (grep { $key eq $_ } qw/name transport/) { $entry->{$key} = $params{$key}; } elsif (grep {$key eq $_} @single_valued_keys) { diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm index 22a870a..3b2846a 100644 --- a/lib/Fripost/Panel/Login.pm +++ b/lib/Fripost/Panel/Login.pm @@ -19,7 +19,6 @@ use CGI::Application::Plugin::Redirect; use CGI::Application::Plugin::ConfigAuto 'cfg'; use Fripost::Schema; -use Fripost::Schema::Util 'split_addr'; use HTML::Entities 'encode_entities'; use URI::Escape::XS 'decodeURIComponent'; @@ -60,8 +59,8 @@ sub cgiapp_init { $CFG{default_realm} // return 0; $u .= '@'.$CFG{default_realm}; } - my $fp = Fripost::Schema::->auth($u, $p, %CFG, -die => 0); - return 0 unless defined $fp; + my $fp = Fripost::Schema::->auth($u, $p, %CFG, -error => undef) + // return 0; $fp->done; return $u; } ], @@ -223,8 +222,8 @@ sub split_path { $script =~ s@/$@@s; # Strip the trailing '/' off the script name my $uri = $self->query->request_uri; - $uri =~ s/^$script//s; # Strip the facing CGI script name - $uri =~ s/\?.*//s; # Strip the query + $uri =~ s/^\Q$script\E\b//s; # Strip the facing CGI script name + $uri =~ s/\?.*//s; # Strip the query map { my $x = decodeURIComponent($_); Encode::_utf8_on($x); $x } (split '/', $uri); diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm index 42ebac5..2d613f0 100644 --- a/lib/Fripost/Schema.pm +++ b/lib/Fripost/Schema.pm @@ -19,12 +19,12 @@ use warnings; use utf8; use parent 'Fripost::Schema::Auth'; -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::User; +#use Fripost::Schema::Alias; +#use Fripost::Schema::List; use Fripost::Schema::Local; +use Fripost::Schema::Pending; =head1 METHODS @@ -80,6 +80,7 @@ local-specific (users, aliases and lists) methods. sub local { bless shift, 'Fripost::Schema::Local'; } +sub pending { bless shift, 'Fripost::Schema::Pending'; } =back @@ -98,23 +99,6 @@ under the same terms as perl itself. =cut -sub _dn2fvu { - my $self = shift; - my $dn = ldap_explode_dn(shift); - - return '@'. $dn->[0]->{fvd} if exists $dn->[0]->{fvd}; - return $dn->[0]->{fvu} .'@'. $dn->[1]->{fvd}; -} -sub _fvu2dn { - my $self = shift; - my $email = shift; - my ($l,$d) = split_addr($email); - - my @dn = ({fvd => $d}, @{$self->suffix}); - unshift @dn, {fvu => $l} if defined $l and $l ne ''; - canonical_dn( @dn ); -} - 1; __END__ diff --git a/lib/Fripost/Schema/Alias.pm b/lib/Fripost/Schema/Alias.pm deleted file mode 100644 index 817f4a6..0000000 --- a/lib/Fripost/Schema/Alias.pm +++ /dev/null @@ -1,201 +0,0 @@ -package Fripost::Schema::Alias; - -=head1 NAME - -Alias.pm - - -=head1 DESCRIPTION - -Alias.pm abstracts the LDAP schema definition and provides methods to -add, list or delete virtual aliases. - -=cut - -use 5.010_000; -use strict; -use warnings; -use utf8; - -use parent 'Fripost::Schema'; -use Fripost::Schema::Util qw/concat explode must_attrs email_valid - split_addr canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; - - -=head1 METHODS - -=over 4 - -=item B<search> (I<domain>, I<OPTIONS>) - -List every known (and visible) alias under the given domain. The output -is a array of hash references, sorted by alias. - -=cut - -sub search { - my $self = shift; - my $domain = domain_to_ascii(shift); - my %options = @_; - my $concat = $options{'-concat'}; - - my $aliases = $self->ldap->search( - base => canonical_dn( {fvd => $domain}, @{$self->suffix} ), - scope => 'one', - deref => 'never', - filter => 'objectClass=FripostVirtualAlias', - attrs => [ qw/fva description fripostIsStatusActive - fripostMaildrop/ ] - ); - if ($aliases->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $aliases->error."\n"; - } - return map { { alias => email_to_unicode($_->get_value('fva')) - , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE' - , description => concat($concat, $_->get_value('description')) - , maildrop => concat($concat, map { email_to_unicode ($_) } - $_->get_value('fripostMaildrop')) - } - } - $aliases->sorted('fva') -} - - -=item B<replace> (I<alias>, I<OPTIONS>) - -Replace an existing alias with the given one. - -=cut - -sub replace { - my $self = shift; - my $a = shift; - my %options = @_; - - foreach (qw/description maildrop/) { - $a->{$_} = explode ($options{'-concat'}, $a->{$_}) - if defined $a->{$_}; - } - - eval { - my ($l,$d) = split_addr( $a->{alias}, -encode => 'ascii' ); - &_is_valid($a); - my $mesg = $self->ldap->modify( - canonical_dn({fva => $l}, {fvd => $d}, @{$self->suffix}), - replace => { fripostIsStatusActive => $a->{isactive} ? - 'TRUE' : 'FALSE' - , description => $a->{description} - , fripostMaildrop => $a->{maildrop} - } ); - die $mesg->error."\n" if $mesg->code; - }; - return $@; -} - - -=item B<add> (I<alias>, I<OPTIONS>) - -Add the given alias. - -=cut - -sub add { - my $self = shift; - my $a = shift; - my %options = @_; - - foreach (qw/description maildrop/) { - $a->{$_} = explode ($options{'-concat'}, $a->{$_}) - if defined $a->{$_}; - } - - eval { - die "Missing alias name\n" unless $a->{alias} =~ /^.+\@.+$/; - my ($l,$d) = split_addr( $a->{alias}, -encode => 'ascii' ); - &_is_valid($a); - die "‘".$a->{alias}."’ already exists\n" - if $self->local->exists($a->{alias},%options); - - my %attrs = ( objectClass => 'FripostVirtualAlias' - , fripostIsStatusActive => $a->{isactive} ? 'TRUE' : 'FALSE' - , fripostMaildrop => $a->{maildrop} - , fripostOwner => $self->whoami - ); - $attrs{description} = $a->{description} - if defined $a->{description} and @{$a->{description}}; - - my $dn = canonical_dn({fva => $l}, {fvd => $d}, @{$self->suffix}); - my $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); - if ($mesg->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $mesg->error."\n"; - } - }; - return $@; -} - - -=item B<delete> (I<alias>, I<OPTIONS>) - -Delete the given alias. - -=cut - -sub delete { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my %options = @_; - - my $mesg = $self->ldap->delete( canonical_dn( {fva => $l}, {fvd => $d}, - @{$self->suffix} ) ); - if ($mesg->code) { - if (defined $options{'-die'}) { - return $mesg->error unless $options{'-die'}; - die $options{'-die'}."\n"; - } - die $mesg->error."\n"; - } -} - - -=back - -=head1 GLOBAL OPTIONS - -If the B<-concat> option is present, it will intersperse multi-valued -attributes. Otherwise, an array reference containing every values will -be returned for these attributes. - -The B<-die> option, if present, overides LDAP croaks and errors. - -=cut - - -# Ensure that the given alias is valid. -sub _is_valid { - my $a = shift; - must_attrs( $a, qw/alias isactive maildrop/ ); - $a->{alias} = email_valid( $a->{alias}, -exact => 1 ); - $a->{maildrop} = [ map { email_valid($_) } @{$a->{maildrop}} ]; -} - - -=head1 AUTHOR - -Guilhem Moulin C<< <guilhem at fripost.org> >> - -=head1 COPYRIGHT - -Copyright 2012,2013 Guilhem Moulin. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or modify it -under the same terms as perl itself. - -=cut - -1; - -__END__ diff --git a/lib/Fripost/Schema/Auth.pm b/lib/Fripost/Schema/Auth.pm index d9c0267..f06ce4f 100644 --- a/lib/Fripost/Schema/Auth.pm +++ b/lib/Fripost/Schema/Auth.pm @@ -83,8 +83,8 @@ sub SASLauth { $self->suffix( ldap_explode_dn(@{$options{ldap_suffix}}) ); $self->whoami( $self->mail2dn($user) ); - $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/' - , async => 0 ) ); + $self->ldap( Net::LDAP::->new( $options{ldap_uri} + // 'ldap://127.0.0.1:389/' ) ); assert( $self->ldap, -die => "Couldn't connect to the LDAP server." ); my $callback; @@ -167,8 +167,8 @@ sub auth { $self->whoami( $self->mail2dn($user) ); } - $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/' - , async => 0 ) ); + $self->ldap( Net::LDAP::->new( $options{ldap_uri} + // 'ldap://127.0.0.1:389/' ) ); assert( $self->ldap, -die => "Couldn't connect to the LDAP server." ); my $mesg = $self->ldap->bind( $self->whoami, password => $pw ); @@ -253,7 +253,10 @@ converted to ASCII. sub mail2dn { my $self = shift; - my ($l,$d) = split_addr(shift, -encode => 'ascii') or return; + my $mail = shift // return; + + $mail =~ s/^\@//; + my ($l,$d) = split_addr($mail, -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 4cc12e4..f819348 100644 --- a/lib/Fripost/Schema/Domain.pm +++ b/lib/Fripost/Schema/Domain.pm @@ -17,10 +17,10 @@ use warnings; use utf8; use parent 'Fripost::Schema'; +use Fripost::Schema::Mail; use Fripost::Schema::Util qw/softdie dn2mail email_valid domain_valid canonical_dn ldap_explode_dn ldap_error - ldap_assert_absent/; -use Fripost::Schema::Mail; + ldap_assert_absent escape_filter_nostar/; use Net::IDN::Encode qw/domain_to_ascii domain_to_unicode email_to_unicode/; use URI::Escape::XS 'encodeURIComponent'; use Encode (); @@ -58,14 +58,14 @@ a new domain, unless the user is asking for a confirmation token. An optional array reference containing the (internationalized) e-mails addresses of users that have permission to create aliases (other than -domain owner or postmaster) under this domain. The local part may be +domain owners or postmasters) under this domain. The local part may be left empty to grant permissions to a whole domain. =item B<canAddList> An optional array reference containing the (internationalized) e-mails addresses of users that have permission to create mailing lists (other -than domain owner or postmaster) under this domain. The local part may +than domain owners or postmasters) under this domain. The local part may be left empty to grant permissions to a whole domain. =item B<owner> @@ -133,15 +133,13 @@ context, only the first domain found is returned. In void context, no attributes are returned from the LDAP server, but it may nevertheless be useful, to ensure that the result set is not empty for instance. -The following options are considered: - =over 4 -=item B<-no-escape> => 0|1 +=item B<-no-star-escape> => 0|1 By default, I<domainname> - when defined - is safely escaped before -insertion into the LDAP filter. This flag disables escaping. It is -useful if I<domainname> contains wildcards for instance. +insertion into the LDAP filter. When set, this flag disables escaping of +wildcards (*) in I<domainname>. =item B<-filter> => locked|unlocked @@ -158,7 +156,7 @@ is set to [] that is, no attribute is sent back to the client. =item B<-count> => 0|1 Return the number of entries in the result set. When set, the B<-keys> -option is bypassed not to ask any attribute from the server. +option is bypassed not to ask any attribute to the server. =item B<-sort> => 0|1 @@ -166,7 +164,7 @@ In list context, sort the results per domain name. =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 @@ -183,8 +181,9 @@ sub search { if ($domainname) { my $d = domain_to_ascii($domainname); - $d = Net::LDAP::Util::escape_filter_value($d) - unless $options{'-no-escape'}; + $d = $options{'-no-star-escape'} ? + escape_filter_nostar $d : + Net::LDAP::Util::escape_filter_value $d; push @filters, 'fvd='.$d; } @@ -348,7 +347,7 @@ Returns 0 or 1, depending on whether or not I<username> has permission to add new domains. If I<username> is undefined, the current user is considered instead. -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 @@ -393,7 +392,17 @@ for a valid WHOIS containing e-mails, and lists postmaster@hostname (RFC 822, appendix C.6) if hostname has a MX record and does not use ours yet. -Errors can be caught with options B<-die> and B<-error>, see +=over 4 + +=item B<ignore-MX> + +An array reference containing hostnames for which no postmaster will be +listed. (Typically, the host we control, since email will then not reach +end users.) Note that subdomains are automatically blacklisted. + +=back + +Errors can be caught with options B<-die> and B<-error>; See B<Fripost::Schema::Util> for details. =cut @@ -418,7 +427,13 @@ sub list_owner_emails { # Look for a valid MX record that is not ours. my %mx = Net::DNS::Dig->new()->for( $domain, 'MX' )->rdata; push @postmasters, 'postmaster@'.$domain # RFC 822, appendix C.6 - if grep {!/\bfripost\.org$/} (values %mx); + unless !$options{'-ignore-MX'} or + grep { my ($mx, $ok) = ($_, 0); + foreach (@{$options{'-ignore-MX'}}) { + if ($mx =~ /\b\Q$_\E$/) { $ok = 1; last }; + } + $ok; + } (values %mx); $tld =~ s/^[^\.]*\.//; } @@ -436,7 +451,7 @@ sub list_owner_emails { # Apply a unique sort on the list. my %hash; $hash{$_} = 1 for grep {email_valid($_ // '', -nodie => 1 )} @postmasters; - sort keys %hash; + map {email_to_unicode $_} (sort keys %hash); } @@ -448,8 +463,6 @@ owner is specified in I<domain>, the current user is automatically promoted owner. (If you you want to add a non self-managed domain, choose an empty string for the owner.) -The following options are considered: - =over 4 =item B<-append> => 0|1 @@ -481,7 +494,7 @@ the domain. =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 @@ -615,91 +628,62 @@ sub _domain_to_entry { -=item B<unlock> (I<domainname>, I<token>, I<OPTIONS>) - -Unlock the pending I<domainname>, locked with I<token>. +=item B<replace> (I<domain>, I<OPTIONS>) -The following options are considered: +Replace an existing domain with the given one. =over 4 =item B<-dry-run> => 0|1 -Merely simulate the unlock. I<token> is still checked to be a valid code. +Merely simulate the replacement. I<domain> is still checked to be a +valid domain in the above representation. =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 - -sub unlock { +sub replace { my $self = shift; - my $domainname = domain_to_ascii(shift); - my $token = shift; + my $domain = shift; my %options = @_; # Nothing to do after an error. return if $options{'-error'} && ${$options{'-error'}}; - my $dn = $self->mail2dn( $domainname ); - my $mesg = $self->ldap->compare( $dn - , attr => 'fripostPendingToken' - , value => $token ); - my $catch = { Net::LDAP::Constant::LDAP_COMPARE_TRUE => 0 - , Net::LDAP::Constant::LDAP_COMPARE_FALSE => - "Wrong unlock code for ‘".$domainname."’" - }; - ldap_error($mesg, %options, -die => $catch) // return; + # Check domain validity. + &_assert_valid($domain, %options, -replace => 1) // return; return 1 if $options{'-dry-run'}; - $mesg = $self->ldap->modify( $dn, - delete => { 'objectClass' => 'FripostPendingEntry' - , 'fripostPendingToken' => [] - }); + my %entry = $self->_domain_to_entry (%$domain); + my $mesg = $self->ldap->modify( $self->mail2dn($domain->{name}) + , replace => \%entry ); ldap_error($mesg, %options); } +=item B<delete> (I<domainname>, I<OPTIONS>) +Delete the given I<domainname>. - -=item B<replace> (I<domain>, I<OPTIONS>) - -Replace an existing domain with the given one. - -=over 4 - -=item B<-dry-run> => 0|1 - -Merely simulate the replacement. I<domain> is still checked to be a -valid domain in the above representation. - -=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 -sub replace { +sub delete { my $self = shift; - my $domain = shift; + my $domainname = shift; my %options = @_; # Nothing to do after an error. return if $options{'-error'} && ${$options{'-error'}}; - # Check domain validity. - &_assert_valid($domain, %options, -replace => 1) // return; - return 1 if $options{'-dry-run'}; - - my %entry = $self->_domain_to_entry (%$domain); - my $mesg = $self->ldap->modify( $self->mail2dn($domain->{name}) - , replace => \%entry ); + my $mesg = $self->ldap->delete( $self->mail2dn($domainname) ); ldap_error($mesg, %options); } @@ -710,23 +694,22 @@ sub _assert_valid { my $d = shift; my %options = @_; eval { - 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}} ] + Fripost::Schema::Util::mandatory_attrs( $d, 'name' ); + $d->{isActive} //= 1 unless $options{'-append'} or $options{'-replace'}; + + $d->{name} = domain_valid( $d->{name} ); + $d->{catchAll} = [ map { email_valid($_, '-allow-empty-local' => 1) } + @{$d->{catchAll}} ] if $d->{catchAll}; - $d->{canAddAlias} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{canAddAlias}} ] + $d->{canAddAlias} = [ map { email_valid($_, '-allow-empty-local' => 1) } + @{$d->{canAddAlias}} ] if $d->{canAddAlias}; - $d->{canAddList} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{canAddList}} ] + $d->{canAddList} = [ map { email_valid($_, '-allow-empty-local' => 1) } + @{$d->{canAddList}} ] if $d->{canAddList}; - $d->{owner} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{owner}} ] + $d->{owner} = [ map { email_valid($_) } @{$d->{owner}} ] if $d->{owner}; - $d->{postmaster} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{postmaster}} ] + $d->{postmaster} = [ map { email_valid($_) } @{$d->{postmaster}} ] if $d->{postmaster}; }; softdie ($@, %options); diff --git a/lib/Fripost/Schema/List.pm b/lib/Fripost/Schema/List.pm deleted file mode 100644 index 2c4d1bc..0000000 --- a/lib/Fripost/Schema/List.pm +++ /dev/null @@ -1,306 +0,0 @@ -package Fripost::Schema::List; - -=head1 NAME - -List.pm - - -=head1 DESCRIPTION - -List.pm abstracts the LDAP schema definition and provides methods to -add, list or delete virtual mailing lists. - -=cut - -use 5.010_000; -use strict; -use warnings; -use utf8; - -use parent 'Fripost::Schema'; -use Fripost::Schema::Util qw/concat explode must_attrs email_valid - split_addr canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; -use Mail::GnuPG; -use MIME::Entity; - - -=head1 METHODS - -=over 4 - -=item B<search> (I<domain>, I<OPTIONS>) - -List every known (and visible) list under the given domain. The output -is a array of hash references, sorted by list. - -=cut - -sub search { - my $self = shift; - my $domain = domain_to_ascii(shift); - my %options = @_; - my $concat = $options{'-concat'}; - - my $filter = 'objectClass=FripostVirtualList'; - $filter = '(&('.$filter.')(!(fripostIsStatusPending=*)))' - if (defined $options{'-is_pending'}) and !$options{'-is_pending'}; - - my $lists = $self->ldap->search( - base => canonical_dn({fvd => $domain}, @{$self->suffix}), - scope => 'one', - deref => 'never', - filter => $filter, - attrs => [ qw/fvl description fripostIsStatusActive - fripostIsStatusPending - fripostListManager/ ] - ); - if ($lists->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $lists->error."\n"; - } - return map { { list => email_to_unicode($_->get_value('fvl')) - , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE' - , description => concat($concat, $_->get_value('description')) - , transport => $_->get_value('fripostListManager') - , ispending => defined $_->get_value('fripostIsStatusPending') - } - } - $lists->sorted('fvl') -} - - -=item B<replace> (I<list>, I<OPTIONS>) - -Replace an existing list with the given one. - -=cut - -sub replace { - my $self = shift; - my $l = shift; - my %options = @_; - - $l->{description} = explode ($options{'-concat'}, $l->{description}) - if defined $l->{description}; - - eval { - my ($l2,$d) = split_addr( $l->{list}, -encode => 'ascii' ); - &_is_valid($l); - my $l3 = { fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE' - , description => $l->{description} }; - $l3->{fripostListManager} = $l->{transport} if defined $l->{transport}; - my $mesg = $self->ldap->modify( - canonical_dn({fvl => $l2}, {fvd => $d}, @{$self->suffix}), - replace => $l3 ); - die $mesg->error."\n" if $mesg->code; - }; - return $@; -} - - -=item B<add> (I<list>, I<OPTIONS>) - -Add the given list. - -=cut - -sub add { - my $self = shift; - my $l = shift; - my %options = @_; - - my $lname = $l->{list}; - $l->{description} = explode ($options{'-concat'}, $l->{description}) - if defined $l->{description}; - - - eval { - die "Missing list name\n" unless $l->{list} =~ /^.+\@.+$/; - my ($l2,$d) = split_addr ( $l->{list}, -encode => 'ascii' ); - must_attrs( $l, 'transport' ); - &_is_valid($l); - die "‘".$l->{list}."’ already exists\n" - if $self->local->exists( $l->{list}, t => 'list', %options ); - - my %attrs = ( objectClass => 'FripostVirtualList' - , fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE' - , fripostOwner => $self->whoami - , fripostListManager => $l->{transport} - , fripostIsStatusPending => 'TRUE' - , fripostLocalAlias => $l2.'#'.$d - ); - $attrs{description} = $l->{description} - if defined $l->{description} and @{$l->{description}}; - - my $dn = canonical_dn({fvl => $l2}, {fvd => $d}, @{$self->suffix}); - my $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); - if ($mesg->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $mesg->error."\n"; - } - }; - return $@ if $@; - - # Ask the list manager to create the list now. - - my $member = email_valid( $self->_dn2fvu($self->whoami), -exact => 1); - my $to = email_valid( 'mklist+'.$l->{transport}.'@fripost.org' ); - - my $mail = MIME::Entity::->build( - From => 'Fripost Admin Panel <AdminWebPanel@fripost.org>', - To => $to, - Subject => "New ".$l->{transport}." list", - Encoding => 'quoted-printable', - Charset => 'utf-8', - Data => [ map { $_ . "\n"} ($lname, $member, $l->{password}) ] - ); - my $gpg = Mail::GnuPG::->new( %{$options{gpg}} ); - my $ret = $gpg->mime_sign( $mail ); - return join ("\n", @{$gpg->{last_message}}) if $ret; - $mail->send; - return 0; -} - - -=item B<is_pending> (I<list>, I<OPTIONS>) - -Tells whether the given list's status is I<pending>, meaning an entry -has been created in the LDAP directory (for instance by the domain owner -from the Web Panel), but the local aliases have not yet been added by -the ListCreator entity, and the list is not known by the list manager. - -=cut - -sub is_pending { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my %options = @_; - - my $dn = canonical_dn({fvl => $l}, {fvd => $d}, @{$self->suffix}); - my $mesg = $self->ldap->search( - base => $dn, - scope => 'base', - deref => 'never', - filter => 'objectClass=FripostVirtualList', - attrs => [ 'fripostIsStatusPending' ] - ); - die "Error: ".$l.'@'.$d.": No such object in the LDAP directory\n" - if $mesg->code == 32; # No such object; a common error here. - die $mesg->error if $mesg->code; - - die "Error: Multiple matching entries found." if $mesg->count > 1; - my $list = $mesg->pop_entry; - - die "Error: No matching entry found." unless defined $list; - my $r = $list->get_value('fripostIsStatusPending'); - return (defined $r and $r eq 'TRUE'); -} - - -=item B<add_commands> (I<list>, I<transport>, I<OPTIONS>) - -Add the lists commands, and remove the pending status. - -=cut - -sub add_commands { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my $cmds = shift; - my %options = @_; - - my $mesg; - foreach my $cmd (@$cmds) { - my $dn = canonical_dn( {fvlc => $l.'-'.$cmd}, {fvl => $l}, {fvd => $d}, - @{$self->suffix} ); - $mesg = $self->ldap->add( $dn, - attrs => [ objectClass => 'FripostVirtualListCommand', - FripostLocalAlias => $l.'-'.$cmd.'#'.$d ] ); - last if $mesg->code; - } - - my $dn = canonical_dn( {fvl => $l}, {fvd => $d}, @{$self->suffix} ); - $mesg = $self->ldap->modify( $dn, delete => 'fripostIsStatusPending' ) - unless $mesg->code; - - if ($mesg->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $mesg->error."\n"; - } -} - - -=item B<delete> (I<list>, I<OPTIONS>) - -Delete the given list. Note: this will NOT wipe the archives off the -disk, but merely delete the list entry in the LDAP directory. - -=cut - -sub delete { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my %options = @_; - - my $dn = canonical_dn( {fvl => $l}, {fvd => $d}, @{$self->suffix} ); - my $mesg = $self->ldap->delete( $dn ); - if ($mesg->code) { - if (defined $options{'-die'}) { - return $mesg->error unless $options{'-die'}; - die $options{'-die'}."\n"; - } - die $mesg->error."\n"; - } -} - - -=back - -=head1 GLOBAL OPTIONS - -If the B<-concat> option is present, it will intersperse multi-valued -attributes. Otherwise, an array reference containing every values will -be returned for these attributes. - -The B<-die> option, if present, overides LDAP croaks and errors. - -=cut - - -# Ensure that the given alias is valid. -sub _is_valid { - my $l = shift; - must_attrs( $l, qw/list isactive/ ); - $l->{list} = email_valid( $l->{list}, -exact => 1 ); - - my ($l2,$d) = split_addr( $l->{list} ); - 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)$/; -} - - -=head1 AUTHOR - -Guilhem Moulin C<< <guilhem at fripost.org> >> - -=head1 COPYRIGHT - -Copyright 2012,2013 Guilhem Moulin. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or modify it -under the same terms as perl itself. - -=cut - -1; - -__END__ 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; -} - - - - - - - diff --git a/lib/Fripost/Schema/Mail.pm b/lib/Fripost/Schema/Mail.pm index c07c6d1..3f9ec73 100644 --- a/lib/Fripost/Schema/Mail.pm +++ b/lib/Fripost/Schema/Mail.pm @@ -19,6 +19,7 @@ use utf8; use MIME::Entity; use Mail::GnuPG; use Encode 'encode'; +use Net::IDN::Encode 'email_to_ascii'; my $DEBUG = 0; @@ -31,8 +32,8 @@ sub new { $msg{Encoding} //= 'quoted-printable'; $msg{Charset} //= 'utf-8'; - $msg{From} = Encode::encode( 'MIME-Q', $msg{From}) if $msg{From}; - $msg{To} = Encode::encode( 'MIME-Q', $msg{To}) if $msg{To}; + $msg{From} = Encode::encode( 'MIME-Q', email_to_ascii($msg{From})) if $msg{From}; + $msg{To} = Encode::encode( 'MIME-Q', email_to_ascii($msg{To})) if $msg{To}; $msg{Subject} = Encode::encode( 'MIME-Q', $msg{Subject}) if $msg{Subject}; my $msg = MIME::Entity::->build( %msg ); diff --git a/lib/Fripost/Password.pm b/lib/Fripost/Schema/Password.pm index c2905b2..cb2ac49 100644 --- a/lib/Fripost/Password.pm +++ b/lib/Fripost/Schema/Password.pm @@ -1,4 +1,4 @@ -package Fripost::Password; +package Fripost::Schema::Password; use 5.010_000; use strict; @@ -115,7 +115,7 @@ Copyright (c) 2010 Dominik Schulz (dominik.schulz@gauner.org). All rights reserv Copyright 2010,2011 Stefan Kangas, all rights reserved. -Copyright 2012 Guilhem Moulin, all rights reserved. +Copyright 2012,2013 Guilhem Moulin, all rights reserved. =head1 LICENSE diff --git a/lib/Fripost/Schema/User.pm b/lib/Fripost/Schema/User.pm deleted file mode 100644 index 3b5cfca..0000000 --- a/lib/Fripost/Schema/User.pm +++ /dev/null @@ -1,231 +0,0 @@ -package Fripost::Schema::User; - -=head1 NAME - -User.pm - - -=head1 DESCRIPTION - -User.pm abstracts the LDAP schema definition and provides methods to -add, list or delete virtual users. - -=cut - -use 5.010_000; -use strict; -use warnings; -use utf8; - -use parent 'Fripost::Schema'; -use Fripost::Schema::Util qw/concat explode must_attrs email_valid - split_addr canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; - - -=head1 METHODS - -=over 4 - -=item B<search> (I<domain>, I<OPTIONS>) - -List every known (and visible) user under the given domain. The -output is a array of hash references, sorted by user. - -=cut - -sub search { - my $self = shift; - my $d = domain_to_ascii(shift); - my %options = @_; - my $concat = $options{'-concat'}; - - my $users = $self->ldap->search( - base => canonical_dn( {fvd => $d}, @{$self->suffix} ), - scope => 'one', - deref => 'never', - filter => 'objectClass=FripostVirtualUser', - attrs => [ qw/fvu description fripostIsStatusActive - fripostOptionalMaildrop - fripostUserQuota/ ] - ); - if ($users->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $users->error."\n"; - } - return map { { user => email_to_unicode($_->get_value('fvu')) - , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE' - , description => concat($concat, $_->get_value('description')) - , forwards => concat($concat, map { email_to_unicode($_) } - $_->get_value('fripostOptionalMaildrop')) - , quota => $_->get_value('fripostUserQuota') // undef - } - } - $users->sorted('fvu') -} - - -=item B<replace> (I<user>, I<OPTIONS>) - -Replace an existing account with the given one. - -=cut - -sub replace { - my $self = shift; - my $u = shift; - my %options = @_; - - foreach (qw/description forwards/) { - $u->{$_} = explode ($options{'-concat'}, $u->{$_}) - if defined $u->{$_}; - } - - eval { - my ($l,$d) = split_addr( $u->{user}, -encode => 'ascii' ); - &_is_valid($u); - my $mesg = $self->ldap->modify( - canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ), - replace => { fripostIsStatusActive => $u->{isactive} ? - 'TRUE' : 'FALSE' - , description => $u->{description} - , fripostOptionalMaildrop => $u->{forwards} - } ); - die $mesg->error."\n" if $mesg->code; - }; - return $@; -} - - -=item B<passwd> (I<username>, I<password>, I<OPTIONS>) - -Change the password of the given user. I<password> is used raw, so you -may want to hash it before hand. - -=cut - -sub passwd { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my $pw = shift; - my %options = @_; - - my $mesg = $self->ldap->modify( - canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ), - replace => { userPassword => $pw } - ); - return "Cannot change password" if $mesg->code; -} - - - -=item B<add> (I<user>, I<OPTIONS>) - -Add the given account. - -=cut - -sub add { - my $self = shift; - my $u = shift; - my %options = @_; - - foreach (qw/description forwards/) { - $u->{$_} = explode ($options{'-concat'}, $u->{$_}) - if defined $u->{$_}; - } - - eval { - die "Missing user name\n" unless $u->{user} =~ /^.+\@.+$/; - my ($l,$d) = split_addr( $u->{user}, -encode => 'ascii' ); - &_is_valid($u); - die "‘".$u->{user}."’ already exists\n" - if $self->local->exists($u->{user},%options); - - my %attrs = ( objectClass => 'FripostVirtualUser' - , fripostIsStatusActive => $u->{isactive} ? 'TRUE' : 'FALSE' - , userPassword => $u->{password} - ); - $attrs{description} = $u->{description} - if defined $u->{description} and @{$u->{description}}; - $attrs{fripostUserQuota} = $u->{quota} if defined $u->{quota}; - $attrs{fripostOptionalMaildrop} = $u->{forwards} - if defined $u->{forwards} and @{$u->{forwards}}; - - my $mesg = $self->ldap->add( - canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ), - attrs => [ %attrs ] - ); - if ($mesg->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $mesg->error."\n"; - } - }; - return $@; -} - - -=item B<delete> (I<user>, I<OPTIONS>) - -Delete the given user. Note: this will NOT wipe the user off the disk, -but merely delete its entry in the LDAP directory. - -=cut - -sub delete { - my $self = shift; - my ($l,$d) = split_addr( shift, -encode => 'ascii' ); - my %options = @_; - - my $mesg = $self->ldap->delete( canonical_dn( {fvu => $l}, {fvd => $d}, - @{$self->suffix} ) ); - if ($mesg->code) { - if (defined $options{'-die'}) { - return $mesg->error unless $options{'-die'}; - die $options{'-die'}."\n"; - } - die $mesg->error."\n"; - } -} - - -=back - -=head1 GLOBAL OPTIONS - -If the B<-concat> option is present, it will intersperse multi-valued -attributes. Otherwise, an array reference containing every values will -be returned for these attributes. - -The B<-die> option, if present, overides LDAP croaks and errors. - -=cut - - -# Ensure that the given user is valid. -sub _is_valid { - my $u = shift; - must_attrs( $u, qw/user isactive/ ); - $u->{user} = email_valid( $u->{user}, -exact => 1); - $u->{forwards} = [ map { email_valid($_) } @{$u->{forwards}} ]; - # TODO: match 'quota' against the Dovecot specifications -} - - -=head1 AUTHOR - -Guilhem Moulin C<< <guilhem at fripost.org> >> - -=head1 COPYRIGHT - -Copyright 2012,2013 Guilhem Moulin. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or modify it -under the same terms as perl itself. - -=cut - -1; - -__END__ diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm index b3439cc..3ab6d68 100644 --- a/lib/Fripost/Schema/Util.pm +++ b/lib/Fripost/Schema/Util.pm @@ -12,10 +12,9 @@ use warnings; use utf8; use Exporter 'import'; -our @EXPORT_OK = qw /concat get_perms explode - must_attrs domain_valid email_valid split_addr dn2mail +our @EXPORT_OK = qw /mandatory_attrs domain_valid email_valid split_addr dn2mail canonical_dn ldap_explode_dn ldap_error ldap_and_filter - ldap_clean_entry + ldap_clean_entry escape_filter_nostar assert ldap_assert_absent softdie/; use Email::Valid; use Net::IDN::Encode qw/domain_to_unicode email_to_unicode @@ -24,70 +23,11 @@ use Net::LDAP::Util; use Encode; -# Let the first argument, if defined, intersperse the other arguments. -sub concat { - my $concat = shift; - - if (defined $concat) { - return join ($concat, @_); - } - else { - return [ @_ ]; - } -} - -# The reverse of 'concat': takes a single line, and split it along -# "concat", if defined. Returns an array reference in any case. -sub explode { - my $concat = shift; - - my $out; - if (defined $concat) { - $out = [ split /$concat/, $_[0] ]; - } - else { - $out = [ @_ ]; - } - [ grep { !/^\s*$/ } @$out ]; -} - - -# This subroutine displays the access that the given DN has on the entry. -# Possible values are : -# - '': no rights -# - a: can create aliases -# - l: can create lists -# - al: can create aliases & lists -# - o: owner -# - p: postmaster -sub get_perms { - my ($entry, $dn) = @_; - my @dn = @{ldap_explode_dn ($dn)}; - shift @dn; - my $dn2 = canonical_dn (@dn); - my $perms = ''; - - $perms .= 'a' - if grep { $dn eq $_ or $dn2 eq $_ } - $entry->get_value ('fripostCanAddAlias'); - - $perms .= 'l' - if grep { $dn eq $_ or $dn2 eq $_ } - $entry->get_value ('fripostCanAddList'); - - $perms = 'o' - if grep { $dn eq $_ } $entry->get_value('fripostOwner'); - - $perms = 'p' - if grep { $dn eq $_ } $entry->get_value('fripostPostmaster'); - - return $perms; -} # "&must_att $h qw/a b c .../" ensures that attributes a b c... are all # defined in the hash reference. -sub must_attrs { +sub mandatory_attrs { my $h = shift; foreach (@_) { die 'Missing value: ‘'.$_."’\n" @@ -97,8 +37,7 @@ sub must_attrs { } -# Ensure that the first argument is a valid email. Can also be used to -# check the validity of domains using the '-prefix' option. +# Ensure that the first argument is a valid email. # '-exact' forces the input to be a bare email, ("name <email>" is not # allowed). sub email_valid { @@ -106,9 +45,8 @@ sub email_valid { my %options = @_; my $i = $in; - $i =~ s/^[^<>]+\s<([^>]+)>/$1/; + $in = 'fake'.$i if defined $options{'-allow-empty-local'} and $i =~ /^\@/; my $mesg = $options{'-error'} // "Invalid e-mail"; - $in = $options{'-prefix'}.$i if defined $options{'-prefix'}; Encode::_utf8_on($in); Encode::_utf8_on($i); @@ -116,32 +54,34 @@ sub email_valid { eval { $in = Net::IDN::Encode::email_to_ascii($in); $addr = Email::Valid::->address( -address => $in, - -tldcheck => 1, - -fqdn => 1 ); + -tldcheck => 1, + -fqdn => 1 ); $match = defined $addr; - $match &&= $addr eq $in if $options{'-exact'}; + $match &&= $addr eq $in + if $options{'-exact'} or $options{'-allow-empty-local'}; }; if ($@ || !$match) { return if $options{'-nodie'}; die $mesg." ‘".$i."’\n"; } - $addr =~ s/^$options{'-prefix'}// if defined $options{'-prefix'}; + $addr =~ s/^fake\@/\@/ if defined $options{'-allow-empty-local'}; return $addr; } sub domain_valid { - my $domainname = shift; - Encode::_utf8_on($domainname); + my $in = shift; + Encode::_utf8_on($in); my %options = @_; - my $in = 'fake@'.Net::IDN::Encode::domain_to_ascii($domainname); - my $addr = Email::Valid::->address( -address => $in + my $domainname = Net::IDN::Encode::domain_to_ascii($in); + my $fake = 'fake@'.$domainname; + my $addr = Email::Valid::->address( -address => $fake , -tldcheck => 1 , -fqdn => 1 ); - unless (defined $addr and $addr eq $in) { + unless (defined $addr and $addr eq $fake) { return if $options{'-nodie'}; my $mesg = $options{'-die'} // "Invalid domain"; - die $mesg." ‘".$domainname."’\n"; + die $mesg." ‘".$in."’\n"; } return $domainname; } @@ -305,6 +245,11 @@ sub ldap_assert_absent { undef } + +sub escape_filter_nostar { + join '*', Net::LDAP::Util::escape_filter_value (split '\*', shift); +} + =head1 AUTHOR Guilhem Moulin C<< <guilhem at fripost.org> >> |