diff options
Diffstat (limited to 'lib/Fripost/Schema/Domain.pm')
| -rw-r--r-- | lib/Fripost/Schema/Domain.pm | 797 |
1 files changed, 569 insertions, 228 deletions
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 |