diff options
Diffstat (limited to 'lib/Fripost')
| -rw-r--r-- | lib/Fripost/Panel/Interface.pm | 148 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Domain.pm | 22 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Local.pm | 312 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Util.pm | 2 |
4 files changed, 391 insertions, 93 deletions
diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm index 228233e..eb9d69a 100644 --- a/lib/Fripost/Panel/Interface.pm +++ b/lib/Fripost/Panel/Interface.pm @@ -51,7 +51,7 @@ sub ListDomains : StartRunmode { $template->param( $self->userInfo ); $template->param( canIAddDomain => $canIAdd ); $template->param( domains => [ map { { &fill_HTML_template_from_entry($_) - , URI => &mkURL('.', $_->{name}) + , URL => &mkURL('.', $_->{name}) , isPending => $_->{isPending} // 0 } } @domains ] ); @@ -59,6 +59,7 @@ sub ListDomains : StartRunmode { } + # Add a new (locked) domain. sub AddDomain : Runmode { my $self = shift; @@ -131,6 +132,7 @@ sub AddDomain : Runmode { } + # On this page, authenticated users can edit the domain description and # catch-alls, and toggle activation (if they have the permission). sub EditDomain : Runmode { @@ -177,106 +179,89 @@ sub EditDomain : Runmode { - - -# This Run Mode lists the known users, aliases and lists under the current -# domain. +# On this page, authenticated users can list the virtual users, aliases +# and lists under the current domain. sub ListLocals : Runmode { my $self = shift; my %CFG = $self->cfg; - my $d = ($self->split_path)[1]; + my $domainname = ($self->split_path)[1]; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); my $q = $self->query; if (defined $q->param('unlock')) { - my $error; # TODO - $fp->domain->unlock( $d, $q->param('unlock'), -error => \$error ) + # Unlock the domain, and come back to the home page. + # Errors are thrown away. + $fp->domain->unlock( $domainname, $q->param('unlock'), -error => undef ) if $q->param('unlock') ne ''; $fp->done; return $self->redirect('../'); } - # Query *the* matching domain - my %domain = $fp->domain->get( $d, -die => 404 ); - - # Query the users, aliases and lists under the given domain. We don't - # die with a HTTP error code here, as it is not supposed to crash. - my @users = $fp->user->search( $d ); - my @aliases = $fp->alias->search( $d ); - my @lists = $fp->list->search( $d ); + # Query *the* matching domain, or 404. + my $domain = $fp->domain->search( $domainname, -filter => 'unlocked' ) + // die "404\n"; + # 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 + @locals; + + my @users = grep { $_->{type} eq 'user' } @locals; + my @aliases = grep { $_->{type} eq 'alias'} @locals; + my @lists = grep { $_->{type} eq 'list' } @locals; + + # Add a link to the list (external) homepage. + map { $_->{listURL} = $CFG{'listurl_'.$_->{transport}}. + email_to_ascii($_->{name}.'@'.$domainname) } + @lists; my $template = $self->load_tmpl( 'list-locals.html', cache => 1, , loop_context_vars => 1 ); $template->param( $self->userInfo ); - $template->param( domain => encode_entities($domain{domain}) - , isactive => $domain{isactive} - , description => join ("\n", @{$domain{description}}) ); + $template->param( &fill_HTML_template_from_entry ($domain, + -loop => ['catchAll'] ) + , CAodd => not $#aliases % 2 ); + # Can the user edit the domain (change description, toggle - # activation, modify catchalls?) - $template->param( canEditDomain => $domain{permissions} =~ /[op]/ ); + # activation, modify catch-alls?) + $template->param( canEditDomain => $domain->{permissions} =~ /[op]/ ); # Can the user add users? - $template->param( canAddUser => $domain{permissions} =~ /p/ ); + $template->param( canAddUser => $domain->{permissions} =~ /p/ ); # Should we list users? $template->param( listUsers => $#users >= 0 || - $domain{permissions} =~ /p/ ); + $domain->{permissions} =~ /p/ ); $template->param( users => [ - map { { &mkLink(user => $_->{user}) - , description => join ("\n", @{$_->{description}}) - , isactive => $_->{isactive} - , forwards => [ map { {forward => encode_entities($_)} } - @{$_->{forwards}} ] - , quota => $_->{quota} - }; - } - @users - ]); + map { {&fill_HTML_template_from_entry ($_, -loop => ['forward'])} } + @users ]); # Can the user add aliases? - $template->param( canAddalias => $domain{permissions} =~ /[aop]/ ); - $template->param( listCanAddAlias => [ map { {user => encode_entities($_)} } - @{$domain{canAddAlias}} ] ) - if $domain{permissions} =~ /[op]/; + $template->param( canAddalias => $domain->{permissions} =~ /[aop]/ ); + $template->param( listCanAddAlias => [ map { {item => encode_entities($_)} } + @{$domain->{canAddAlias}} ] ) + if $domain->{permissions} =~ /[op]/; # Should we list aliases? $template->param( listAliases => $#aliases >= 0 || - $domain{permissions} =~ /[aop]/ ); + $domain->{permissions} =~ /[aop]/ ); $template->param( aliases => [ - map { { &mkLink(alias => $_->{alias}) - , description => join ("\n", @{$_->{description}}) - , isactive => $_->{isactive} - , destinations => [ map { {destination => encode_entities($_)} } - @{$_->{maildrop}} ] - }; - } - @aliases - ]); - $template->param( catchalls => [ map { {catchall => encode_entities($_)} } - @{$domain{catchalls}} ] - , CAodd => not $#aliases % 2); + map { {&fill_HTML_template_from_entry ($_, -loop => ['destination'])} } + @aliases ]); # Can the user add lists? - $template->param( canAddList => $domain{permissions} =~ /[lop]/ ); - $template->param( listCanAddList => [ map { {user => encode_entities($_)} } - @{$domain{canAddList}} ] ) - if $domain{permissions} =~ /[op]/; + $template->param( canAddList => $domain->{permissions} =~ /[lop]/ ); + $template->param( listCanAddList => [ map { {item => encode_entities($_)} } + @{$domain->{canAddList}} ] ) + if $domain->{permissions} =~ /[op]/; # Should we list lists? - $template->param( listLists => $#lists >= 0 || $domain{permissions} =~ /[lop]/ ); + $template->param( listLists => $#lists >= 0 || + $domain->{permissions} =~ /[lop]/ ); $template->param( lists => [ - map { { &mkLink(list => $_->{list}) - , description => join ("\n", @{$_->{description}}) - , isactive => $_->{isactive} - , ispending => $_->{ispending} - , transport => $_->{transport} - , listURL => $CFG{'listurl_'.$_->{transport}}. - email_to_ascii($_->{list}.'@'.$d) - }; - } - @lists - ]); + map { {&fill_HTML_template_from_entry ($_, -loop => ['destination'])} } + @lists ]); return $template->output; } @@ -531,7 +516,7 @@ sub mkLink { my $k = shift; my $d = shift; ( $k => encode_entities($d), - $k.'URI' => &mkURL('.', $d) ) + $k.'URL' => &mkURL('.', $d) ) } sub userInfo { @@ -542,41 +527,52 @@ sub userInfo { ( user_localpart => encode_entities($l) , user_domainpart => encode_entities($d) - , userURI => &mkURL ($root, $d, $l) + , userURL => &mkURL ($root, $d, $l) ) } -sub mkFormContentE { +sub mkFormContentE { # TODO delete &mkFormContent (map { encode_entities ($_) } @_); } -sub mkFormContent { +sub mkFormContent { # TODO delete join ("\x{0D}\x{0A}", @_); } -sub mkDesc { +sub mkDesc { # TODO delete my $desc = shift // return ''; join '<br>', map {encode_entities($_)} @$desc; } -my @single_valued_keys = qw/isActive/; +my @single_valued_keys = qw/isActive quota/; my @multi_valued_keys = qw/description catchAll - canAddAlias canAddList/; + canAddAlias canAddList + forward destination/; sub fill_HTML_template_from_entry { my $entry = shift; + my %options = @_; my %vars; foreach my $key (keys %$entry) { + next if $options{'-hide'} and + grep { $key eq $_ } @{$options{'-hide'}}; + if ($key eq 'name') { $vars{$key} = encode_entities($entry->{$key}); } - elsif (grep {$key eq $_} @single_valued_keys) { + elsif (grep {$key eq $_} ('URL', 'listURL', @single_valued_keys)) { $vars{$key} = $entry->{$key}; } elsif (grep {$key eq $_} @multi_valued_keys) { - $vars{$key} = join "\x{0D}\x{0A}", map { encode_entities ($_) } - @{$entry->{$key}}; + my @array = map { encode_entities ($_) } @{$entry->{$key}}; + if ($options{'-loop'} and + grep { $key eq $_ } @{$options{'-loop'}}) { + $vars{$key} = [ map {{item => $_}} @array ]; + } + else { + $vars{$key} = join "\x{0D}\x{0A}", @array; + } } } return %vars; diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm index 6ed22b6..3caffb5 100644 --- a/lib/Fripost/Schema/Domain.pm +++ b/lib/Fripost/Schema/Domain.pm @@ -2,7 +2,7 @@ package Fripost::Schema::Domain; =head1 NAME -Domain.pm - Domain related methods in the Fripost Schema +Domain.pm - Domainpart related methods for the Fripost Schema =head1 DESCRIPTION @@ -31,7 +31,7 @@ use Template; =head1 REPRESENTATION -Domains are imported and exported as hash references, having the +Domains are imported and exported as hash references, with the following keys: =over 4 @@ -44,6 +44,10 @@ A UTF-8 string representing the (internationalized) domain name. Whether or not the domain is active. +=item B<description> + +An array reference containing UTF-8 strings describing the domain. + =item B<isPending> => 0|1 Whether or not the domain is pending. This is key is ignored when adding @@ -79,10 +83,6 @@ An optional array reference containing the (internationalized) catch-alls for that domain. Localparts may be left empty for domain aliases. -=item B<description> - -An array reference containing UTF-8 string representing that domain. - =item B<permissions> An optional string representing the permission of the current user @@ -154,10 +154,10 @@ 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<-count> +=item B<-count> => 0|1 -Returns the number of entries in the result set. The B<-keys> option is -bypassed not to ask any attribute from the server. +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. =item B<-sort> => 0|1 @@ -285,9 +285,7 @@ sub _entries_to_domains { } # Add a 'permissions' key if wanted. - if ((not @$keys or grep { $_ eq 'permissions' } @$keys) and - grep { $entry->exists($_) } qw/fripostCanAddAlias fripostCanAddList - fripostOwner fripostPostmaster/) { + if ((not @$keys or grep { $_ eq 'permissions' } @$keys)) { my $perms = ''; $perms .= 'a' if $entry->exists('fripostCanAddAlias') and grep { $user eq lc $_ or $parent eq lc $_ } diff --git a/lib/Fripost/Schema/Local.pm b/lib/Fripost/Schema/Local.pm index 7a1ae22..1f09f66 100644 --- a/lib/Fripost/Schema/Local.pm +++ b/lib/Fripost/Schema/Local.pm @@ -2,12 +2,12 @@ package Fripost::Schema::Local; =head1 NAME -Local.pm - +Local.pm - Localpart related method for the Fripost Schema =head1 DESCRIPTION -Local.pm abstracts the LDAP schema definition and provides methods to -search for virtual users, aliases or lists alltogether. +This module abstracts the LDAP schema definition and provides methods to +add, list or delete virtual users, aliases or lists. =cut @@ -17,11 +17,315 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Util qw/concat split_addr canonical_dn/; +use Fripost::Schema::Util qw/concat split_addr canonical_dn + ldap_error dn2mail/; use Net::IDN::Encode qw/email_to_ascii email_to_unicode/; use Net::LDAP::Util 'escape_filter_value'; +=head1 REPRESENTATION + +Virtual users, aliases and lists are imported and exported as hash +references, with the following keys: + +=over 4 + +=item B<name> + +A UTF-8 string representing the (internationalized) e-mail address for +the user, alias or list. + +=item B<type> => user|alias|list + +The type of the entry. + +=item B<isActive> => 0|1 + +Whether or not the entry is active. + +=item B<description> + +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. + +=item B<quota> + +(User only) A string e.g., C<100 MB> representing the current quota on +the user's mailboxes. + +=item B<owner> + +(Alias and list only) An optional array reference containing the +(internationalized) e-mails addresses of the entry owners. + +=item B<forward> + +(User only) An optional array reference containing a (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 +addresses that will receive messages sent to that alias. + +=item B<transport> mailman|schleuder + +(List only) The list manager associated with list entries. + + +=head1 METHODS + +=over 4 + +=item B<search> (I<name>, I<OPTIONS>) + +Search for I<name>, or list all the known (and visible) users, aliases +and lists when I<name> is not defined. If I<name> does not contain a '@' +symbol, it is interpreted as a domain name, which limits the scope of +that search. In list context, return a list of entries represented as +hash references, as explained above. In scalar context, only the first +entry 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, 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. + +=item B<-filter> => locked|unlocked + +Limit the search scope to pending / non-pending entries only. + +=item B<-type> => user|alias|list + +Limit the search scope to the given entry type. + +=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<-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. + +=item B<-sort> => 0|1 + +In list context, sort the results per localpart. + +=back + +Errors can be caught with options B<-die> and B<-error>, see +B<Fripost::Schema::Util> for details. + +=cut + +sub search { + my $self = shift; + my $in = shift; + my %options = @_; + + # Nothing to do after an error. + return if $options{'-error'} && ${$options{'-error'}}; + + # If there is not '@', we interpret $in as a domain name. + $in =~ s/^([^\@]+)$/\@$1/; + my ($localname, $domainname) = split_addr($in); + + my @filters; + if (defined $options{'-type'}) { + # Limit the scope to the given type. + if ($options{'-type'} eq 'user') { + push @filters, 'objectClass=FripostVirtualUser'; + } + elsif ($options{'-type'} eq 'alias') { + push @filters, 'objectClass=FripostVirtualAlias'; + } + elsif ($options{'-type'} eq 'list') { + push @filters, 'objectClass=FripostVirtualList'; + } + } + else { + push @filters, '(|(objectClass=FripostVirtualUser)'. + '(objectClass=FripostVirtualAlias)'. + '(objectClass=FripostVirtualList))'; + } + + my @domainnames; + if ($domainname) { + if ($options{'-no-escape'} and $domainname =~ /\*/) { + # 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' ]) ; + $opts{'-filter'} = 'unlocked'; + foreach (qw/-filter -error -die/) { + $opts{$_} = $options{$_} if $options{$_}; + } + push @domainnames, map {$_->{name}} + $self->domain->search($domainname, %opts); + } + else { + # Otherwise, a single query is enough. + $domainname = Net::LDAP::Util::escape_dn_value($domainname) + unless $options{'-no-escape'}; + push @domainnames, $domainname; + } + } + + if ($localname) { + $localname = Net::LDAP::Util::escape_filter_value($localname) + unless $options{'-no-escape'}; + push @filters, 'fvl='.$localname; + } + + if (defined $options{'-filter'}) { + 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 $filter = Fripost::Schema::Util::ldap_and_filter(@filters); + my $count = 0; + my @resultset; + foreach my $domainname (@domainnames) { + # For query the server for each matching domain. + my $locals = $self->ldap->search( base => $self->mail2dn('@'.$domainname) + , scope => 'one' + , deref => 'never' + , filter => $filter + , attrs => $attrs + ); + ldap_error($locals, %options) // return; + next unless defined wantarray; # We'll drop the result anyway + + if ($options{'-count'}) { + $count += $locals->count; + } + elsif (wantarray) { + push @resultset, + &_entries_to_locals( $domainname, $options{'-keys'}, + $locals->entries ); + } + else { + # In scalar context, we stop here if we got a match. + return &_entries_to_locals( $domainname, $options{'-keys'}, + $locals->pop_entry ) + if $locals->count; + } + } + + return $count if $options{'-count'}; + # In list context, we return the whole result set, maybe sorted. + $options{'-sort'} ? sort { $a->{name} cmp $b->{name} } @resultset + : @resultset; +} + + +# Map a list of LDAP::Entry object into our public representation of +# users, aliases and lists. +sub _entries_to_locals { + my $domainname = shift; + my $keys = shift // []; + + my @locals; + foreach my $entry (@_) { + + # Ignore bogus entries. + return unless defined $entry; + my %local; + + foreach my $attr ($entry->attributes) { + my $val = $entry->get_value($attr, asref => 1); + if ($attr eq 'fvl') { + $local{name} = email_to_unicode($val->[0].'@'.$domainname) + if not @$keys or grep { $_ eq 'name' } @$keys; + } + elsif ($attr eq 'fripostIsStatusActive') { + $local{isActive} = $val->[0] eq 'TRUE' + if not @$keys or grep { $_ eq 'isActive' } @$keys; + } + elsif ($attr eq 'objectClass') { + if (grep { lc $_ eq lc 'FripostVirtualUser' } @$val) { + $local{type} = 'user'; + } + elsif (grep { lc $_ eq lc 'FripostVirtualAlias' } @$val) { + $local{type} = 'alias'; + } + elsif (grep { lc $_ eq lc 'FripostVirtualList' } @$val) { + $local{type} = 'list'; + } + $local{isPending} = scalar (grep { lc $_ eq lc 'FripostPendingEntry' } + @$val ) + if not @$keys or grep { $_ eq 'isPending' } @$keys; + } + elsif ($attr eq 'description') { + $local{description} = [ map { Encode::_utf8_on($_); $_ } @$val ] + if not @$keys or grep { $_ eq 'description' } @$keys; + } + elsif ($attr eq 'fripostUserQuota') { + $local{quota} = $val->[0] + if not @$keys or grep { $_ eq 'quota' } @$keys; + } + elsif ($attr eq 'fripostOwner') { + $local{owner} = [ map { dn2mail($_) } @$val ] + if not @$keys or grep { $_ eq 'owner' } @$keys; + } + elsif ($attr eq 'fripostOptionalMaildrop') { + $local{forward} = [ map { email_to_unicode($_) } @$val ] + if not @$keys or grep { $_ eq 'forward' } @$keys; + } + elsif ($attr eq 'fripostMaildrop') { + $local{destination} = [ map { email_to_unicode($_) } @$val ] + if not @$keys or grep { $_ eq 'destination' } @$keys; + } + elsif ($attr eq 'fripostListManager') { + $local{transport} = $val->[0] + if not @$keys or grep { $_ eq 'transport' } @$keys; + } + else { + die "Missing translation for local attribute ‘".$attr."’."; + } + } + + # Stop after the first processed domain in scalar mode. + return \%local unless wantarray; + push @locals, \%local; + } + return @locals; +} + + + =head1 METHODS =over 4 diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm index d5e122e..59d724f 100644 --- a/lib/Fripost/Schema/Util.pm +++ b/lib/Fripost/Schema/Util.pm @@ -154,7 +154,7 @@ sub ldap_explode_dn { } sub split_addr { - my $addr = shift; + my $addr = shift // return; my %options = @_; $addr =~ /^(.*)\@([^\@]+)$/s; |