aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Fripost/Schema
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Fripost/Schema')
-rw-r--r--lib/Fripost/Schema/Auth.pm24
-rw-r--r--lib/Fripost/Schema/Domain.pm797
-rw-r--r--lib/Fripost/Schema/Mail.pm58
-rw-r--r--lib/Fripost/Schema/Util.pm64
4 files changed, 695 insertions, 248 deletions
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<Fripost::Schema::Util> 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<Fripost::Schema::Util> 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<username>.
If I<newpassword> 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<Fripost::Schema::Util> 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<Net::LDAP::Util>.
sub suffix { shift->_set_or_get('_suffix',@_); }
-=item B<mkdn> ({I<username>|I<domainname>})
+=item B<mail2dn> ({I<username>|I<domainname>})
Create the Distinguished Name associated with the I<username> (may be an
alias or a list name regardless) or I<domainname>. 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<name>
+
+A UTF-8 string representing the (internationalized) domain name.
+
+=item B<isActive> => 0|1
+
+Whether or not the domain is active.
+
+=item B<isPending> => 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<canAddAlias>
+
+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<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
+be left empty to grant permissions to a whole domain.
+
+=item B<owner>
+
+An optional array reference containing the (internationalized) e-mails
+addresses of the domain owners (other than postmasters).
+
+=item B<postmaster>
+
+An optional array reference containing the (internationalized) e-mails
+addresses of the domain postmasters.
+
+=item B<catchAlls>
+
+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
+against this domain. (Note that this key is ignored when inserting a new
+domain, since the information is redundent with B<canAddAlias>,
+B<canAddList>, B<owner> and B<postmaster>.) The string is a sequence of
+characters which meaning is:
+
+=over 4
+
+=item B<a>
+
+The current user can add aliases under that domain (but is not listed
+among domain owners or postmasters).
+
+=item B<l>
+
+The current user can add mailing lists under that domain (but is not
+listed among domain owners or postmasters).
+
+=item B<o>
+
+The current user owns that domain.
+
+=item B<p>
+
+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<search> (I<OPTIONS>)
+=item B<search> (I<domainname>, I<OPTIONS>)
+
+Search for I<domainname>, or list all the known (and visible) domains
+when I<domainname> 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<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.
+
+=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<Fripost::Schema::Util> 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<canIAdd> (I<username>, I<OPTIONS>)
-=item B<get> (I<domain>, I<OPTIONS>)
+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.
-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<Fripost::Schema::Util> 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<replace> (I<domain>, I<OPTIONS>)
-Replace an existing domain with the given one.
+=item B<list_admin_emails> (I<domainname>, I<OPTIONS>)
+
+Search for postmaster e-mail addresses for I<domainname>. For
+I<domainname> 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<Fripost::Schema::Util> 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<add> (I<domain>, I<OPTIONS>)
+
+Add the domain I<domain>, represented by a hash reference as explained
+above. If no owner is specified in I<domain>, the current user is
+automatically promoted owner instead.
+
+The following options are considered:
+
+=over 4
+
+=item B<-append> => 0|1
+
+When I<domain>'s is already present, the default is to raise an error.
+This flag appends the attributes in the new I<domain> 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<domain> 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<email>
+
+When set, this option locks down the domain before inserting it, and
+send a message to I<email> with the unlocking token.
+
+=item B<webapp_url>
+
+The URL to send, together with the token, to provide instructions how to
+unlock the domain.
+
+=item B<tmpl_path>
+
+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<Fripost::Schema::Util> 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 <AdminWebPanel@fripost.org>',
- 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<unlock> (I<domainname>, I<token>, I<OPTIONS>)
+
+Unlock the pending domain I<domainname>, locked with I<token>.
+
+Errors can be caught with options B<-die> and B<-error>, see
+B<Fripost::Schema::Util> 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<replace> (I<domain>, I<OPTIONS>)
+
+Replace an existing domain with the given one.
+
+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 $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<< <guilhem at fripost.org> >>
+
+=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<< <guilhem at fripost.org> >>
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:04:04 +0000