From 99b3ecbaf20b4e47ee6a403fd30268939e6e1244 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 25 Jan 2013 02:49:26 +0100 Subject: Updated and redocumented Fripost::Schema::Domain. --- config.in | 4 + lib/Fripost/Panel/Interface.pm | 85 +++-- lib/Fripost/Panel/Login.pm | 23 +- lib/Fripost/Schema/Auth.pm | 24 +- lib/Fripost/Schema/Domain.pm | 797 +++++++++++++++++++++++++++++------------ lib/Fripost/Schema/Mail.pm | 58 +++ lib/Fripost/Schema/Util.pm | 64 +++- misc/deleteExpiredEntries.pl | 11 +- templates/edit-domain.html | 8 +- templates/list-domains.html | 2 +- templates/new-domain.tt | 2 + 11 files changed, 775 insertions(+), 303 deletions(-) create mode 100644 lib/Fripost/Schema/Mail.pm diff --git a/config.in b/config.in index 1d2e9f8..5f4c29a 100644 --- a/config.in +++ b/config.in @@ -26,3 +26,7 @@ gpg_private_key_passphrase = xxxxxxxxxxxx # URL prefixes of the admin web interface for the list managers. listurl_mailman = https://lists.fripost.org/mailman/admin/ listurl_schleuder = https://lists.fripost.org/schleuder/ + +webapp_url = http://localhost:8080/cgi-bin/ + +email_from = admin@fripost.org diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm index aee0df4..b0deeb0 100644 --- a/lib/Fripost/Panel/Interface.pm +++ b/lib/Fripost/Panel/Interface.pm @@ -40,17 +40,23 @@ sub ListDomains : StartRunmode { my %CFG = $self->cfg; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); - my @domains = $fp->domain->search( -concat => "\n", -die => 403); + my @domains = $fp->domain->search( undef, -die => 403, -sort => 1, + -keys => [qw/name isActive isPending description/]); + my $canIAdd = $fp->domain->domain->canIAdd; $fp->done; - my $template = $self->load_tmpl( 'list-domains.html', cache => 1, + my $template = $self->load_tmpl( 'list-domains.html', cache => 1 , loop_context_vars => 1 ); $template->param( $self->userInfo ); - $template->param( domains => [ map { { &mkLink( domain => $_->{domain}) - , isactive => $_->{isactive} - , ispending => $_->{ispending} - , description => $_->{description} } } - @domains ] + $template->param( canIAddDomain => $canIAdd ); + $template->param( domains => [ + map { + { &mkLink( domain => $_->{name}) + , isActive => $_->{isActive} + , isPending => $_->{isPending} + , description => &mkDesc($_->{description}) + } } + @domains ] ); return $template->output; } @@ -67,7 +73,8 @@ sub ListLocals : Runmode { my $q = $self->query; if (defined $q->param('unlock')) { - $fp->domain->unlock( $d, $q->param('unlock') ) + my $error; # TODO + $fp->domain->unlock( $d, $q->param('unlock'), -error => \$error ) if $q->param('unlock') ne ''; $fp->done; return $self->redirect('../'); @@ -158,7 +165,7 @@ sub ListLocals : Runmode { # In this Run Mode authenticated users can edit the domain description -# and catchalls, and toggle activation (if they have the permission). +# and catch-alls, and toggle activation (if they have the permission). sub EditDomain : Runmode { my $self = shift; my %CFG = $self->cfg; @@ -173,28 +180,29 @@ sub EditDomain : Runmode { my $error; # Tells whether the change submission has failed. if (defined $q->param('submit')) { # Changes have been submitted: process them - $error = $fp->domain->replace({ - domain => $d, - isactive => $q->param('isactive') // 1, - description => $q->param('description') // undef, - catchalls => $q->param('catchalls') // undef, - canAddAlias => $q->param('canAddAlias') // undef, - canAddList => $q->param('canAddList') // undef - }, -concat => "(\n|\x{0D}\x{0A})"); + $fp->domain->replace({ + name => $d, + isActive => $q->param('isActive') // 1, + description => $q->param('description'), + catchAlls => [ split /\x{0D}\x{0A}/, ($q->param('catchAlls')//'') ], +# canAddAlias => [ split /\x{0D}\x{0A}/, ($q->param('canAddAlias')//'') ], +# canAddList => [ split /\x{0D}\x{0A}/, ($q->param('canAddList')//'') ] + # ^ TODO: if postmaster + }, -error => \$error); } - my %domain = $fp->domain->get( $d, -die => 404 ); + my $domain = $fp->domain->search( $d, -die => 403, -filter => 'unlocked' ) // die "404\n"; $fp->done; my $template = $self->load_tmpl( 'edit-domain.html', cache => 1, , loop_context_vars => 1 ); $template->param( $self->userInfo ); $template->param( domain => encode_entities($d) - , isPostmaster => $domain{permissions} eq 'p'); + , isPostmaster => $domain->{permissions} eq 'p'); if ($error) { # Preserve the (incorrect) form - $template->param( isactive => $q->param('isactive') // 1 + $template->param( isActive => $q->param('isActive') // 1 , description => $q->param('description') // undef - , catchalls => $q->param('catchalls') // undef + , catchAlls => $q->param('catchAlls') // undef , canAddAlias => $q->param('canAddAlias') // undef , canAddList => $q->param('canAddList') // undef , error => encode_entities ($error) ); @@ -371,16 +379,19 @@ sub AddDomain : Runmode { and grep { $q->param('postmaster') eq $_ } @postmasters; } - $error = $fp->domain->add({ - domain => $domain, - send_token_to => $q->param('postmaster') // undef, - isactive => $q->param('isactive') // 1, - description => $q->param('description') // undef, - catchalls => $q->param('catchalls') // undef }, - -concat => "(\n|\x{0D}\x{0A})", + $fp->domain->add({ + name => $domain, + isActive => $q->param('isActive') // 1, +# description => $q->param('description') // undef, +# catchAlls => [ split /\x{0D}\x{0A}/, $q->param('catchAlls') ] + }, + '-send-confirmation-token' => $q->param('postmaster') // undef, '-dry-run' => not (defined $q->param('postmaster')), - -domainurl => $q->url.'/'.encode_entities($domain).'/' # TODO: try that in nginx - ) unless $error; + -error => \$error, + webapp_url => $self->cfg('webapp_url'), + tmpl_path => $self->cfg('tmpl_path'), + email_from => $self->cfg('email_from') + ); } $fp->done; @@ -396,7 +407,10 @@ sub AddDomain : Runmode { } else { $tmpl_file = 'add-domain-2.html'; - @postmasters = Fripost::Schema::Domain::->list_postmasters($domain); + @postmasters = Fripost::Schema::Domain::->list_admin_emails( + $domain, -error => \$error + ); + $tmpl_file = 'add-domain-1.html' if $error; } my $template = $self->load_tmpl( $tmpl_file, cache => 1, @@ -404,9 +418,9 @@ sub AddDomain : Runmode { $template->param( $self->userInfo ); $template->param( error => encode_entities ($error) ) if $error; - $template->param( isactive => $q->param('isactive') // 1 + $template->param( isActive => $q->param('isActive') // 1 , description => $q->param('description') // undef - , catchalls => $q->param('catchalls') // undef + , catchAlls => $q->param('catchAlls') // undef ); $template->param( domain => encode_entities($domain) ) if defined $domain; @@ -559,6 +573,11 @@ sub mkFormContent { join ("\x{0D}\x{0A}", @_); } +sub mkDesc { + my $desc = shift // return ''; + join '
', map {encode_entities($_)} @$desc; +} + =head1 AUTHOR Guilhem Moulin C<< >> diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm index 00fff72..736207d 100644 --- a/lib/Fripost/Panel/Login.pm +++ b/lib/Fripost/Panel/Login.pm @@ -7,7 +7,7 @@ use utf8; =head1 NAME -Login.pm - +Login.pm - Authentication subroutines for the Web Interface. =cut @@ -63,8 +63,6 @@ sub cgiapp_init { $CFG{default_realm} // return 0; $u .= '@'.$CFG{default_realm}; } - Encode::_utf8_on($u); - $u = email_to_ascii($u); my $fp = Fripost::Schema::->auth($u, $p, %CFG, -die => 0); return 0 unless defined $fp; $fp->done; @@ -105,16 +103,16 @@ sub setup { # /domain/{user,alias,list}/?query_url my ($null,$domain,$local,$crap) = $self->split_path; - return 'ListDomains' if (defined $null) and $null ne ''; + return 'ListDomains' if $null; - unless (defined $domain and $domain ne '') { + unless ($domain) { if (defined $a) { return 'AddDomain' if $a eq 'add'; } return 'ListDomains'; } - unless (defined $local and $local ne '') { + unless ($local) { if (defined $a) { return 'EditDomain' if $a eq 'edit'; return 'AddLocal' if $a eq 'add'; @@ -131,8 +129,7 @@ sub setup { # wanted to visit. sub okay : Runmode { my $self = shift; - my $redirect = $self->query->param('redirect') // - $self->query->url; + my $redirect = $self->query->param('redirect') // $self->query->url; return $self->redirect($redirect); } @@ -219,18 +216,20 @@ sub error_rm : ErrorRunmode { } } +# Split the URI; give the list of its components. +# The facing CGI script and trailing query are not considered. sub split_path { my $self = shift; my %options = @_; my $script = $ENV{SCRIPT_NAME} // $self->cfg->{'cgi-bin'} // ''; - $script =~ s@/$@@s; + $script =~ s@/$@@s; # Strip the trailing '/' off the script name my $uri = $self->query->request_uri; - $uri =~ s/^$script//s; - $uri =~ s/\?.*//s; + $uri =~ s/^$script//s; # Strip the facing CGI script name + $uri =~ s/\?.*//s; # Strip the query - map { my $x = decodeURIComponent($_); Encode::_utf8_on($x); $x } + map { decodeURIComponent($_); Encode::_utf8_on($_); $_ } (split /\//, $uri); } diff --git a/lib/Fripost/Schema/Auth.pm b/lib/Fripost/Schema/Auth.pm index 2df1a7e..c6325b8 100644 --- a/lib/Fripost/Schema/Auth.pm +++ b/lib/Fripost/Schema/Auth.pm @@ -68,7 +68,7 @@ the virtual entries. =back -Errors can be caught with options B<-die> and B<-errors>, see +Errors can be caught with options B<-die> and B<-error>, see B for details. =cut @@ -82,7 +82,7 @@ sub SASLauth { my $self = bless {}, $class; $self->suffix( ldap_explode_dn(@{$options{ldap_suffix}}) ); - $self->whoami( $self->mkdn($user) ); + $self->whoami( $self->mail2dn($user) ); $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/' , async => 0 ) ); assert( $self->ldap, -die => "Couldn't connect to the LDAP server." ); @@ -109,7 +109,7 @@ sub SASLauth { , callback => $callback ); my $host = $options{ldap_SASL_service_instance} // 'localhost'; my $conn = $sasl->client_new( 'ldap', $host ); - ldap_error ($conn, %options); + ldap_error ($conn, %options) // return; my $mesg = $self->ldap->bind( undef, sasl => $conn ); ldap_error ($mesg, %options) // return; @@ -145,7 +145,7 @@ the virtual entries. =back -Errors can be caught with options B<-die> and B<-errors>, see +Errors can be caught with options B<-die> and B<-error>, see B for details. =cut @@ -164,7 +164,7 @@ sub auth { } else { return unless defined $user; - $self->whoami( $self->mkdn($user) ); + $self->whoami( $self->mail2dn($user) ); } $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/' @@ -189,14 +189,14 @@ attribute of the DN associated with I. If I is left undefined, the new password is generated at random, and returned upon success. -Errors can be caught with options B<-die> and B<-errors>, see +Errors can be caught with options B<-die> and B<-error>, see B for details. =cut sub passwd { my $self = shift; - my $user = $self->mkdn(shift) // $self->whoami; + my $user = $self->mail2dn(shift) // $self->whoami; my $oldpw = shift; my $newpw = shift; my %options = @_; @@ -243,7 +243,7 @@ of hashes), defined in B. sub suffix { shift->_set_or_get('_suffix',@_); } -=item B ({I|I}) +=item B ({I|I}) Create the Distinguished Name associated with the I (may be an alias or a list name regardless) or I. The argument is first @@ -251,12 +251,16 @@ converted to ASCII. =cut -sub mkdn { +sub mail2dn { my $self = shift; my $user = shift // return; + + $user =~ s/^([^\@]+)$/\@$1/; my ($l,$d) = split_addr($user, -encode => 'ascii'); + my @dn = ({fvd => $d}, @{$self->suffix}); - unshift @dn, {fvl => $l} if defined $l and $l ne ''; + unshift @dn, {fvl => $l} if $l; + canonical_dn( @dn ); } diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm index 8c3586f..75a525d 100644 --- a/lib/Fripost/Schema/Domain.pm +++ b/lib/Fripost/Schema/Domain.pm @@ -2,11 +2,11 @@ package Fripost::Schema::Domain; =head1 NAME -Domain.pm - +Domain.pm - Domain related methods in the Fripost Schema =head1 DESCRIPTION -Domain.pm abstracts the LDAP schema definition and provides methods to +This module abstracts the LDAP schema definition and provides methods to add, list or delete virtual domains. =cut @@ -17,188 +17,403 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Net::LDAP qw/LDAP_SUCCESS LDAP_COMPARE_TRUE LDAP_NO_SUCH_OBJECT/; -use Fripost::Schema::Util qw/concat get_perms explode must_attrs - email_valid canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii domain_to_unicode - email_to_ascii email_to_unicode/; +use Fripost::Schema::Util qw/must_attrs softdie canonical_dn dn2mail email_valid + ldap_explode_dn ldap_error ldap_and_filter/; +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 Net::Domain::TLD 'tld_exists'; use Net::DNS::Dig; use Net::Whois::Parser 'parse_whois'; use String::Random; use Template; -use MIME::Entity; + +=head1 REPRESENTATION + +Domains are imported and exported as hash references, having the +following keys: + +=over 4 + +=item B + +A UTF-8 string representing the (internationalized) domain name. + +=item B => 0|1 + +Whether or not the domain is active. + +=item B => 0|1 + +Whether or not the domain is pending. This is key is ignored when adding +a new domain, unless the user is asking for a confirmation token. + +=item B + +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 +left empty to grant permissions to a whole domain. + +=item B + +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 +be left empty to grant permissions to a whole domain. + +=item B + +An optional array reference containing the (internationalized) e-mails +addresses of the domain owners (other than postmasters). + +=item B + +An optional array reference containing the (internationalized) e-mails +addresses of the domain postmasters. + +=item B + +An optional array reference containing the (internationalized) +catch-alls for that domain. Localparts may be left empty for domain +aliases. + +=item B + +An array reference containing UTF-8 string representing that domain. + +=item B + +An optional string representing the permission of the current user +against this domain. (Note that this key is ignored when inserting a new +domain, since the information is redundent with B, +B, B and B.) The string is a sequence of +characters which meaning is: + +=over 4 + +=item B + +The current user can add aliases under that domain (but is not listed +among domain owners or postmasters). + +=item B + +The current user can add mailing lists under that domain (but is not +listed among domain owners or postmasters). + +=item B + +The current user owns that domain. + +=item B

+ +The current user has postmaster rights on that domain. + +=back + +=back + +Note that when retrieving a domain from the database, only a subset of +these keys may be visible, hence exported. =head1 METHODS =over 4 -=item B (I) +=item B (I, I) + +Search for I, or list all the known (and visible) domains +when I is not defined. In list context, return a list of +domains represented as hash references, as explained above. In scalar +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 + +By default, I - when defined - is safely escaped before +insertion into the LDAP filter. This flag disables escaping. It is +useful if I contains wildcards for instance. + +=item B<-filter> => locked|unlocked + +Limit the search scope to pending / non-pending domains only. + +=item B<-keys> + +An array reference containing the attributes that are to be retrived +from the LDAP server. Note that Access Control List may prevent the +current user to read or even search anything, though. The default is to +retrieve every visible attribute, unless in void context where B<-keys> +is set to [] that is, no attribute is sent back to the client. + +=item B<-assert-exists> + +A custom error to be raised on empty result sets. When 0, it makes the +method returns the size of the result set. + +=item B<-sort> => 0|1 + +In list context, sort the results per domain name. + +=back -List every known (and visible) domain. The output is a array of hash -references, sorted by domain names. +Errors can be caught with options B<-die> and B<-error>, see +B for details. =cut sub search { my $self = shift; + my $domainname = shift; my %options = @_; - my $concat = $options{'-concat'}; - my $filter = '(objectClass=FripostVirtualDomain)'; + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + my @filters = ('objectClass=FripostVirtualDomain'); + + if ($domainname) { + $domainname = Net::LDAP::Util::escape_filter_value($domainname) + unless $options{'-no-escape'}; + push @filters, 'fvd='.$domainname; + } if (defined $options{'-filter'}) { - if ($options{'-filter'} eq 'locked') { - # Will only work if we're the owner, but otherwise we - # shouldn't see the domain anyway. - $filter = '(&'.$filter.'(fripostPendingToken=*))'; + push @filters, 'objectClass=FripostPendingEntry' + if $options{'-filter'} eq 'locked'; + push @filters, '!(objectClass=FripostPendingEntry)' + if $options{'-filter'} eq 'unlocked'; + } + + my $attrs = []; + if (not (defined wantarray)) { + # In void context, we are only interested in whether or not the + # result set is empty. + $attrs = [ '1.1' ]; + } + elsif (defined $options{'-keys'}) { + $attrs = @{$options{'-keys'}} ? [ &_keys_to_attrs(@{$options{'-keys'}}) ] + : [ '1.1' ]; + } + + my $domains = $self->ldap->search( base => canonical_dn(@{$self->suffix}) + , scope => 'one' + , deref => 'never' + , filter => ldap_and_filter(@filters) + , attrs => $attrs + ); + ldap_error($domains, %options) // return; + + softdie ($options{'-assert-exists'}, %options) // return + unless $domains->count; + return $domains->count if exists $options{'-assert-exists'}; + + &_entries_to_domains( $self->whoami, $options{'-keys'} // [], + wantarray ? ( $options{'-sort'} ? $domains->sorted('fvd') + : $domains->entries ) + : $domains->pop_entry + ); +} + +# Map a list of LDAP::Entry object into our public representation of +# domains. +sub _entries_to_domains { + my $user = lc shift; + my @dn = @{ldap_explode_dn $user}; + shift @dn; + my $parent = lc (canonical_dn @dn); + my $keys = shift; + + my @domains; + foreach my $entry (@_) { + + # Ignore bogus entries. + return unless defined $entry; + my %domain; + + foreach my $attr ($entry->attributes) { + my $val = $entry->get_value($attr, asref => 1); + if ($attr eq 'fvd') { + $domain{name} = domain_to_unicode($val->[0]) + if not @$keys or grep { $_ eq 'name' } @$keys; + } + elsif ($attr eq 'fripostIsStatusActive') { + $domain{isActive} = $val->[0] eq 'TRUE' + if not @$keys or grep { $_ eq 'isActive' } @$keys; + } + elsif ($attr eq 'objectClass') { + $domain{isPending} = scalar (grep { lc $_ eq lc 'FripostPendingEntry' } + @$val ) + if not @$keys or grep { $_ eq 'isPending' } @$keys; + } + elsif ($attr eq 'fripostCanAddAlias') { + $domain{canAddAlias} = [ map { dn2mail($_) } @$val ] + if not @$keys or grep { $_ eq 'canAddAlias' } @$keys; + } + elsif ($attr eq 'fripostCanAddList') { + $domain{canAddList} = [ map { dn2mail($_) } @$val ] + if not @$keys or grep { $_ eq 'canAddList' } @$keys; + } + elsif ($attr eq 'fripostOwner') { + $domain{owner} = [ map { dn2mail($_) } @$val ] + if not @$keys or grep { $_ eq 'owner' } @$keys; + } + elsif ($attr eq 'fripostPostmaster') { + $domain{postmaster} = [ map { dn2mail($_) } @$val ] + if not @$keys or grep { $_ eq 'postmaster' } @$keys; + } + elsif ($attr eq 'fripostOptionalMaildrop') { + $domain{catchAlls} = [ map { &_email_to_unicode($_) } @$val ] + if not @$keys or grep { $_ eq 'catchAlls' } @$keys; + } + elsif ($attr eq 'description') { + $domain{description} = [ map { Encode::_utf8_on($_); $_ } @$val ] + if not @$keys or grep { $_ eq 'description' } @$keys; + } + else { + die "Missing translation for domain attribute ‘".$attr."’."; + } } - elsif ($options{'-filter'} eq 'nonlocked') { - $filter = '(&'.$filter.'(!(fripostPendingToken=*)))'; + + # Add a 'permissions' key if wanted. + if ((not @$keys or grep { $_ eq 'permissions' } @$keys) and + grep { $entry->exists($_) } qw/fripostCanAddAlias fripostCanAddList + fripostOwner fripostPostmaster/) { + my $perms = ''; + $perms .= 'a' if $entry->exists('fripostCanAddAlias') and + grep { $user eq lc $_ or $parent eq lc $_ } + $entry->get_value('fripostCanAddAlias'); + $perms .= 'l' if $entry->exists('fripostCanAddList') and + grep { $user eq lc $_ or $parent eq lc $_ } + $entry->get_value('fripostCanAddList'); + $perms = 'o' if $entry->exists('fripostOwner') and + grep { $user eq lc $_ } + $entry->get_value('fripostOwner'); + $perms = 'p' if $entry->exists('fripostPostmaster') and + grep { $user eq lc $_ } + $entry->get_value('fripostPostmaster'); + $domain{permissions} = $perms; + } + + # Stop after the first processed domain in scalar mode. + return \%domain unless wantarray; + push @domains, \%domain; + } + return @domains; +} + + +# Map our domain keys into the LDAP attribute(s) that are required to +# fetch this information. +sub _keys_to_attrs { + my %map = ( name => 'fvd' + , isActive => 'fripostIsStatusActive' + , isPending => 'objectClass' + , canAddAlias => 'fripostCanAddAlias' + , canAddList => 'fripostCanAddList' + , owner => 'fripostOwner' + , postmaster => 'fripostPostmaster' + , catchAlls => 'fripostOptionalMaildrop' + , description => 'description' + , permissions => [ qw/fripostCanAddAlias fripostCanAddList + fripostOwner fripostPostmaster/ ] + ); + my %attrs; + foreach my $k (@_) { + die "Missing translation for key ‘".$k."’." + unless exists $map{$k}; + if (ref $map{$k} eq 'ARRAY') { + $attrs{$_} = 1 for @{$map{$k}}; } else { - die "Unknown filter: ".$options{'-filter'}."\n"; + $attrs{$map{$k}} = 1; } } - else { - my @domains0 = map {{ %$_, ispending => 1 }} - $self->search(%options, -filter => 'locked'); - my @domains1 = map {{ %$_, ispending => 0 }} - $self->search(%options, -filter => 'nonlocked'); - return sort {$a->{domain} cmp $b->{domain}} (@domains0, @domains1); - } + return keys %attrs; +} - my $domains = $self->ldap->search( - base => canonical_dn(@{$self->suffix}), - scope => 'one', - deref => 'never', - filter => $filter, - attrs => [ qw/fvd description fripostIsStatusActive/ ] - ); - if ($domains->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $domains->error."\n"; - } - return map { { domain => domain_to_unicode($_->get_value('fvd')) - , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE' - , description => concat($concat, $_->get_value('description')) - } - } - $domains->sorted('fvd') -} +=item B (I, I) -=item B (I, I) +Returns 0 or 1, depending on whether or not I has permission +to add new domains. If I is undefined, the current user is +considered instead. -Returns a hash with all the (visible) attributes for the given -*non-pending* domain. +Errors can be caught with options B<-die> and B<-error>, see +B for details. =cut -sub get { +sub canIAdd { my $self = shift; - my $d = domain_to_ascii(shift); + my @dn = @{ldap_explode_dn ($self->mail2dn(shift) // $self->whoami)}; + my $user = lc (canonical_dn @dn); + shift @dn; + my $parent = lc (canonical_dn @dn); my %options = @_; - my $concat = $options{'-concat'}; - - my $attrs = $options{'-attrs'} // - [ qw/fvd description - fripostIsStatusActive - fripostOptionalMaildrop - fripostCanAddAlias - fripostCanAddList - fripostOwner - fripostPostmaster/ ]; - - $attrs = [ '1.1' ] if $options{'-assert_exist'}; - - my $domains = $self->ldap->search( - base => canonical_dn({fvd => $d}, @{$self->suffix}), - scope => 'base', - deref => 'never', - filter => '(&(objectClass=FripostVirtualDomain) - (!(fripostPendingToken=*)))', - attrs => $attrs - ); - if ($domains->code) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die $domains->error."\n"; - } - # The following is not supposed to happen. - die "Error: Multiple matching entries found." if $domains->count > 1; - my $domain = $domains->pop_entry; - unless (defined $domain) { - die $options{'-die'}."\n" if defined $options{'-die'}; - die "No such such domain: ‘$d’\n"; - } - return if $options{'-assert_exist'}; - - return ( domain => domain_to_unicode($domain->get_value('fvd')) - , isactive => $domain->get_value('fripostIsStatusActive') eq 'TRUE' - , description => concat($concat, $domain->get_value('description')) - , catchalls => concat($concat, map { &_email_to_unicode ($_) } - $domain->get_value('fripostOptionalMaildrop')) - , permissions => get_perms($domain, $self->whoami) - , canAddAlias => concat($concat, map { &_email_to_unicode ($self->_dn2fvu($_)) } - $domain->get_value('fripostCanAddAlias')) - , canAddList => concat($concat, map { &_email_to_unicode ($self->_dn2fvu($_)) } - $domain->get_value('fripostCanAddList')) - ) + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + my $mesg = $self->ldap->search( base => canonical_dn(@{$self->suffix}) + , scope => 'base' + , deref => 'never' + , filter => 'objectClass=FripostVirtual' + , attrs => [ 'fripostCanAddDomain' ] + ); + ldap_error($mesg, %options) // return; + + # If these are raised, something is seriously wrong. + die "Empty virtual directory?" unless $mesg->count; + die "Multiple virtual directories?" unless $mesg->count == 1; + + my $base = $mesg->pop_entry // die "Empty virtual directory?"; + scalar (grep { lc $_ eq $user or lc $_ eq $parent } + $base->get_value('fripostCanAddDomain')); } -=item B (I, I) -Replace an existing domain with the given one. +=item B (I, I) + +Search for postmaster e-mail addresses for I. For +I itself and each of its parents, this routine searches 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 +B for details. =cut -sub replace { +sub list_admin_emails { my $self = shift; - my $d = shift; + my $domainname = shift; my %options = @_; - foreach (qw/description catchalls canAddAlias canAddList/) { - $d->{$_} = explode ($options{'-concat'}, $d->{$_}) - if defined $d->{$_}; - } + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; - eval { - &_is_valid($d); - my $dn = canonical_dn( {fvd => $d->{domain}}, @{$self->suffix} ); - my $mesg = $self->ldap->modify( $dn, - replace => { fripostIsStatusActive => $d->{isactive} ? - 'TRUE' : 'FALSE' - , description => $d->{description} - , fripostOptionalMaildrop => $d->{catchalls} - , fripostCanAddAlias => - [ map $self->_fvu2dn($_), - @{$d->{canAddAlias}} ] - , fripostCanAddList => - [ map $self->_fvu2dn($_), - @{$d->{canAddList}} ] - } ); - die $mesg->error."\n" if $mesg->code; - }; - return $@; -} - - -sub list_postmasters { - my $self = shift; - my $hostname = shift; my @postmasters; - - my $tld = domain_to_ascii($hostname); + my $tld = domain_to_ascii($domainname); my $domain; + until ( tld_exists($tld) ) { - die "‘".$hostname."’ has an Invalid TLD.\n" unless $tld =~ /\./; + softdie ("‘".$domainname."’ has an Invalid TLD.", %options) // return + unless $tld =~ /\./; $domain = $tld; + # 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); @@ -206,153 +421,278 @@ sub list_postmasters { $tld =~ s/^[^\.]*\.//; } + # Look for e-mail addresses in the WHOIS. my $info = parse_whois( domain => $domain ); - die "Cannot WHOIS ‘".$domain."’.\n" unless defined $info; if (defined $info) { push @postmasters, @{$info->{emails}}; } + else { + softdie ("Cannot WHOIS ‘".$domain."’", %options); + return; + } + # Apply a unique sort on the list. my %hash; - $hash{$_} = 1 for grep {email_valid($_ // '', -nodie => 1 )} - @postmasters; + $hash{$_} = 1 for grep {email_valid($_ // '', -nodie => 1 )} @postmasters; sort keys %hash; } + + +=item B (I, I) + +Add the domain I, represented by a hash reference as explained +above. If no owner is specified in I, the current user is +automatically promoted owner instead. + +The following options are considered: + +=over 4 + +=item B<-append> => 0|1 + +When I's is already present, the default is to raise an error. +This flag appends the attributes in the new I to the existing +one (or replace the old values in case of single-valued attributes). + +=item B<-dry-run> => 0|1 + +Merely simulate the insertion. I is still checked to be valid +and, unless B<-append> is set, its name is ensured not to be present in +the directory. + +=item B<-send-confirmation-token> => I + +When set, this option locks down the domain before inserting it, and +send a message to I with the unlocking token. + +=item B + +The URL to send, together with the token, to provide instructions how to +unlock the domain. + +=item B + +Where to find the e-mail template with the instructions how to unlock +the domain. + +=back + +Errors can be caught with options B<-die> and B<-error>, see +B for details. + +=cut + sub add { my $self = shift; - my $d = shift; + my $domain = shift; my %options = @_; - foreach (qw/description catchalls canAddAlias canAddList/) { - $d->{$_} = explode ($options{'-concat'}, $d->{$_}) - if defined $d->{$_}; + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + 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 $exists = $self->search($domain->{name}, %options, '-assert-exists' => 0); + softdie ( "Domain ‘".$domainname."’ already exists.", %options ) // return + if not $options{'-append'} and $exists; + # Stop here in dry-run mode. + 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 ); + + my ($mesg, $token); + if ($options{'-append'} and $exists) { + # Replace single valued attributes; Add other attributes. + my %unique = ( fripostIsStatusActive => $attrs{fripostIsStatusActive} ); + delete $attrs{$_} for (keys %unique); + $mesg = $self->ldap->modify( $dn, replace => \%unique, add => \%attrs ); } - - eval { - my $domain = $d->{domain}; - Encode::_utf8_on($domain); - &_is_valid($d); - - my $dn = canonical_dn( {fvd => $d->{domain}}, @{$self->suffix} ); - - my $mesg = $self->ldap->search( - base => $dn, - scope => 'base', - deref => 'never', - filter => 'objectClass=FripostVirtualDomain', - attrs => [ '1.1' ] ); - if ($mesg->code == LDAP_SUCCESS) { - die "Domain ‘".$domain."’ already exists.\n"; + else { + if ($options{'-send-confirmation-token'}) { + # Add the pending class, and generate a random token. + $attrs{objectClass} = [ qw/FripostVirtualDomain FripostPendingEntry/ ]; + $token = String::Random::->new->randregex('\w{32}'); + $attrs{fripostPendingToken} = $token; } - elsif ($mesg->code != LDAP_NO_SUCH_OBJECT) { - die $mesg->error."\n"; + else { + $attrs{objectClass} = 'FripostVirtualDomain'; } + # The default owner is the current user. + $attrs{fripostOwner} //= [ $self->whoami ]; + $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); + } - return if $options{'-dry-run'}; + ldap_error($mesg, %options) // return; + return 1 unless $options{'-send-confirmation-token'}; + + # Send token + email_valid ($options{'-send-confirmation-token'}); + my $tt = Template->new({ INCLUDE_PATH => $options{tmpl_path} + , INTERPOLATE => 1 }) + or die $Template::ERROR; + my $vars = { domain => $domainname, token => $token }; + $vars->{unlockurl} = $options{webapp_url} + .encodeURIComponent($domainname) + .'/?unlock='.$token + if defined $options{webapp_url}; + + my $data; + $tt->process( 'new-domain.tt', $vars, \$data) or die $tt->error; + Fripost::Schema::Mail::->new( From => $options{email_from} // + $ENV{USER}.'@localhost' + , To => $options{'-send-confirmation-token'} + , Subject => "Your new domain ".$domain->{name} + , Data => $data + )->send; + + 1; +} - my %attrs = ( objectClass => 'FripostVirtualDomain' - , fripostIsStatusActive => $d->{isactive} ? - 'TRUE' : 'FALSE' - ); - $attrs{description} = $d->{description} - if defined $d->{description} and @{$d->{description}}; - $attrs{fripostOptionalMaildrop} = $d->{catchalls} - if defined $d->{catchalls} and @{$d->{catchalls}}; +# Convert our representation of domains into a hash which keys are LDAP +# attributes. +sub _domain_to_entry { + my $self = shift; + my %domain = @_; + my %entry; - if (defined $d->{owner}) { - $attrs{fripostOwner} = $self->_fvu2dn($d->{owner}) - if $d->{owner} ne ''; + foreach my $key (keys %domain) { + if ($key eq 'name') { + # Its value is forced by the DN. + } + elsif ($key eq 'isActive') { + $entry{fripostIsStatusActive} = $domain{isActive} ? 'TRUE' : 'FALSE'; + } + elsif ($key eq 'description') { + $entry{description} = $domain{description}; + } + elsif ($key eq 'catchAlls') { + $entry{fripostOptionalMaildrop} = $domain{catchAlls}; + } + elsif ($key eq 'canAddAlias') { + $entry{fripostCanAddAlias} = + [ map { $self->mail2dn($_) } @{$domain{canAddAlias}} ]; + } + elsif ($key eq 'canAddList') { + $entry{fripostCanAddList} = + [ map { $self->mail2dn($_) } @{$domain{canAddList}} ]; + } + elsif ($key eq 'owner') { + $entry{fripostOwner} = + [ map { $self->mail2dn($_) } @{$domain{owner}} ]; + } + elsif ($key eq 'postmaster') { + $entry{fripostPostmaster} = + [ map { $self->mail2dn($_) } @{$domain{postmaster}} ]; } else { - $attrs{fripostOwner} = $self->whoami; + die "Missing translation for domain key ‘".$key."’."; } + } + return %entry; +} - my $token; - if (defined $d->{send_token_to}) { - $token = String::Random::->new->randregex('\w{32}'); - $attrs{fripostPendingToken} = $token - } - $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); - die $mesg->error."\n" if $mesg->code; - - - if (defined $d->{send_token_to}) { - my $tt = Template->new({ - INCLUDE_PATH => './templates', # TODO: use a config option - INTERPOLATE => 1, - }) or die $Template::ERROR."\n"; - - my $data; - my $vars = { domain => $domain, token => $token }; - $vars->{unlockurl} = $options{'-domainurl'}.'?unlock='.$token - if defined $options{'-domainurl'}; - $tt->process( 'new-domain.tt', $vars, \$data) - or die $tt->error."\n"; - - my $mail = MIME::Entity::->build( - From => 'Fripost Admin Panel ', - To => $d->{send_token_to}, - Subject => "Your new domain ".$d->{domain}, - Encoding => 'quoted-printable', - Charset => 'utf-8', - Data => $data - ); - $mail->sign( Signature => 'The Fripost administration team.'); - $mail->send; - } - }; - return $@; -} +=item B (I, I, I) + +Unlock the pending domain I, locked with I. + +Errors can be caught with options B<-die> and B<-error>, see +B for details. + +=cut + sub unlock { my $self = shift; - my $d = shift; + my $domainname = shift; my $token = shift; + my %options = @_; + + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; - my $dn = canonical_dn({fvd => domain_to_ascii($d)}, @{$self->suffix}); + my $dn = $self->mail2dn( $domainname ); my $mesg = $self->ldap->compare( $dn , attr => 'fripostPendingToken' , value => $token ); - die "Wrong unlock code for ‘".$d."’\n" - unless $mesg->code eq LDAP_COMPARE_TRUE; - - $mesg = $self->ldap->modify( $dn, delete => 'fripostPendingToken' ); - die $mesg->error."\n" if $mesg->code; + 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; + + $mesg = $self->ldap->modify( $dn, + delete => { 'objectClass' => 'FripostPendingEntry' + , 'fripostPendingToken' => [] + }); + ldap_error($mesg, %options); } -=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. + +=item B (I, I) + +Replace an existing domain with the given one. + +Errors can be caught with options B<-die> and B<-error>, see +B for details. =cut +sub replace { + my $self = shift; + my $domain = shift; + my %options = @_; + + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + &_is_valid($domain, %options); + my %entry = $self->_domain_to_entry (%$domain); + my $mesg = $self->ldap->modify( $self->mail2dn($domain->{name}) + , replace => \%entry ); + ldap_error($mesg, %options); +} + # Ensure that the given domain is valid. sub _is_valid { my $d = shift; - must_attrs( $d, qw/domain isactive/ ); - $d->{domain} = email_valid( $d->{domain}, -prefix => 'fake@', + my %options = @_; + eval { + must_attrs( $d, qw/name isActive/ ); + $d->{name} = email_valid( $d->{name}, -prefix => 'fake@', -error => 'Invalid domain', -exact => 1 ); - $d->{catchalls} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{catchalls}} ]; - $d->{canAddAlias} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{canAddAlias}} ]; - $d->{canAddList} = [ map { email_valid($_, -prefix => 'fake') } - @{$d->{canAddList}} ]; - - $d->{send_token_to} = email_valid( $d->{send_token_to} ) - if defined $d->{send_token_to}; + $d->{catchAlls} = [ map { email_valid($_, -prefix => 'fake') } + @{$d->{catchAlls}} ] + if $d->{catchAlls}; + $d->{canAddAlias} = [ map { email_valid($_, -prefix => 'fake') } + @{$d->{canAddAlias}} ] + if $d->{canAddAlias}; + $d->{canAddList} = [ map { email_valid($_, -prefix => 'fake') } + @{$d->{canAddList}} ] + if $d->{canAddList}; + $d->{owner} = [ map { email_valid($_, -prefix => 'fake') } + @{$d->{postmaster}} ] + if $d->{postmaster}; + $d->{postmaster} = [ map { email_valid($_, -prefix => 'fake') } + @{$d->{postmaster}} ] + if $d->{postmaster}; + }; + softdie ($@, %options); } @@ -363,6 +703,7 @@ sub _email_to_unicode { return email_to_unicode($email); } +=back =head1 AUTHOR diff --git a/lib/Fripost/Schema/Mail.pm b/lib/Fripost/Schema/Mail.pm new file mode 100644 index 0000000..309dad8 --- /dev/null +++ b/lib/Fripost/Schema/Mail.pm @@ -0,0 +1,58 @@ +package Fripost::Schema::Mail; + +=head1 NAME + +Mail.pm - Send clear, signed or encrypted e-mails. + +=head1 DESCRIPTION + +This module is adds GnuPG signing on top of MIME::Lite. Most of the +code comes from Mail::GnuPG. + +=cut + +use 5.010_000; +use strict; +use warnings; +use utf8; + +use MIME::Lite; + +sub new { + my $class = shift; + my $self = bless {}, $class; + my %msg = @_; + + $msg{Encoding} //= 'quoted-printable'; + $msg{Charset} //= 'utf-8'; + + $self->{_msg} = MIME::Lite->new(@_); + return $self; +} + +sub send { + my $self = shift; + print STDERR $self->{_msg}->as_string; + $self->{_msg}->send; +} + +=back + +=head1 AUTHOR + +Guilhem Moulin C<< >> + +=head1 COPYRIGHT + +Copyright 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 0f6821c..2c71411 100644 --- a/lib/Fripost/Schema/Util.pm +++ b/lib/Fripost/Schema/Util.pm @@ -13,11 +13,12 @@ use utf8; use Exporter 'import'; our @EXPORT_OK = qw /concat get_perms explode - must_attrs email_valid split_addr - canonical_dn ldap_explode_dn ldap_error + must_attrs email_valid split_addr dn2mail + canonical_dn ldap_explode_dn ldap_error ldap_and_filter + clean_ldap_entry assert softdie/; use Email::Valid; -use Net::IDN::Encode; +use Net::IDN::Encode qw/domain_to_unicode email_to_unicode/; use Net::LDAP::Util; use Encode; @@ -139,20 +140,24 @@ sub split_addr { my $addr = shift; my %options = @_; + $addr =~ /^(.*)\@([^@]+)$/s; + my ($l,$d) = ($1, $2); + if (defined $options{'-encode'}) { my $e = $options{'-encode'}; if ($e eq 'ascii') { - $addr = Net::IDN::Encode::email_to_ascii($addr); + Encode::_utf8_on($d); + $addr = Net::IDN::Encode::domain_to_ascii($d); } elsif ($e eq 'unicode') { - $addr = Net::IDN::Encode::email_to_unicode($addr); + $d = Net::IDN::Encode::domain_to_unicode($d); } else { - die "Unknown encoding: ". $e; + softdie ("Unknown encoding: ". $e, %options); + return; } } - - split /\@/, $addr, 2; + return ($l,$d); } sub ldap_error { @@ -180,8 +185,7 @@ sub ldap_error { $error = $mesg->error if $mesg->code; } - return $mesg unless defined $error; - return unless $error; + return 1 unless $error; if (defined $options{'-error'}) { ${$options{'-error'}} = $error; @@ -210,10 +214,50 @@ sub softdie { my $mesg = shift; my %options = @_; + return 1 unless $mesg; $options{'-die'} = $mesg; &assert (undef, %options); } +sub dn2mail { + my $dn = ldap_explode_dn(shift); + + return '@'. domain_to_unicode(lc $dn->[0]->{fvd}) + if exists $dn->[0]->{fvd}; + return email_to_unicode(lc $dn->[0]->{fvl} .'@'. lc $dn->[1]->{fvd}); +} + +sub ldap_and_filter { + my @filters = @_; + + if ($#filters == 0) { + return $filters[0]; + } + else { + @filters = map {'('.$_.')'} @filters; + return '(&'.(join '', @filters).')'; + } +} + + +sub clean_ldap_entry { + my $attrs = shift; + + foreach (keys %$attrs) { + if (defined $attrs->{$_}) { + if (ref $attrs->{$_} eq 'ARRAY') { + delete $attrs->{$_} unless @{$attrs->{$_}} + } + elsif (ref $attrs->{$_} eq '') { + delete $attrs->{$_} if $attrs->{$_} eq ''; + } + } + else { + delete $attrs->{$_}; + } + } +} + =head1 AUTHOR Guilhem Moulin C<< >> diff --git a/misc/deleteExpiredEntries.pl b/misc/deleteExpiredEntries.pl index 80dd79b..29e26b0 100755 --- a/misc/deleteExpiredEntries.pl +++ b/misc/deleteExpiredEntries.pl @@ -32,21 +32,22 @@ my $config = { ldap_bind_dn => [ 'cn=DeletePendingEntries','ou=services','o=mail , ldap_suffix => [ 'ou=virtual','o=mailHosting','dc=fripost,dc=dev' ] }; -my $fp = Fripost::Schema::->auth( undef, 'deletependingentries', %$config ); +my $fp = Fripost::Schema::Auth->auth( undef, 'deletependingentries', %$config ); my $maxage = $ARGV[0] // 86400; # 24h by default my $now = int(strftime "%s", gmtime); my $maxdate = Net::LDAP::Util::escape_filter_value( - strftime ("%Y%m%d%H%M%SZ", localtime($now - $maxage)) ); + strftime ("%Y%m%d%H%M%SZ", localtime($now - $maxage)) + ); my $entries = $fp->ldap->search ( base => Fripost::Schema::Util::canonical_dn(@{$fp->suffix}), scope => 'subtree', deref => 'never', - filter => "(&(fripostPendingToken=*) + filter => "(&(objectClass=FripostPendingEntry) (createTimestamp<=$maxdate))", - attrs => [], + attrs => [ '1.1' ], callback => \&delete_entry ); die $entries->error."\n" if $entries->code; @@ -55,7 +56,7 @@ $fp->done; sub delete_entry { my ($mesg, $obj) = @_; if (defined $obj and $obj->isa('Net::LDAP::Entry')) { -# print STDERR "Deleting DN ".$obj->dn."\n"; + print STDERR "Deleting DN ".$obj->dn."\n"; $obj->delete; my $mesg = $obj->update($fp->ldap); die $mesg->error."\n" if $mesg->code; diff --git a/templates/edit-domain.html b/templates/edit-domain.html index 39a1148..f3b6581 100644 --- a/templates/edit-domain.html +++ b/templates/edit-domain.html @@ -40,9 +40,9 @@

Status

- + +
Warning: emails are not delivered to users, @@ -60,7 +60,7 @@

Catch-All aliases

- +
An optional list of destinations (one e-mail address per line) that will receive mail sent to non existing recipients. diff --git a/templates/list-domains.html b/templates/list-domains.html index e31915f..13b8941 100644 --- a/templates/list-domains.html +++ b/templates/list-domains.html @@ -20,7 +20,7 @@
-

Manage domains[add]

+

Manage domains[add]

diff --git a/templates/new-domain.tt b/templates/new-domain.tt index e1491a3..fc482e3 100644 --- a/templates/new-domain.tt +++ b/templates/new-domain.tt @@ -28,3 +28,5 @@ current MX'es with the following command: Cheers, +-- +The Fripost administration team. -- cgit v1.2.3