path: root/lib/Fripost/Schema/Domain.pm

package Fripost::Schema::Domain;

=head1 NAME

Domain.pm - Domainpart related methods for the Fripost Schema

=head1 DESCRIPTION

This module abstracts the LDAP schema definition and provides methods to
add, list or delete virtual domains.

=cut

use 5.010_000;
use strict;
use warnings;
use utf8;

use parent 'Fripost::Schema';
use Fripost::Schema::Mail;
use Fripost::Schema::Util qw/softdie dn2mail email_valid domain_valid
                             canonical_dn ldap_explode_dn ldap_error
                             ldap_assert_absent escape_filter_nostar/;
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;

=head1 REPRESENTATION

Domains are imported and exported as hash references, with 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<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
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 owners or postmasters) under this domain. The local part may be
left empty to grant permissions to a whole domain.

=item B<canAddList>

An optional array reference containing the (internationalized) e-mails
addresses of users that have permission to create mailing lists (other
than domain owners or postmasters) 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<catchAll>

An optional array reference containing the (internationalized)
catch-alls for that domain. Localparts may be left empty for domain
aliases.

=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<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.

=over 4

=item B<-no-star-escape> => 0|1

By default, I<domainname> - when defined - is safely escaped before
insertion into the LDAP filter. When set, this flag disables escaping of
wildcards (*) in I<domainname>.

=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<-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 to the server.

=item B<-sort> => 0|1

In list context, sort the results per domain name.

=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 $domainname = shift;
    my %options = @_;

    # Nothing to do after an error.
    return if $options{'-error'} && ${$options{'-error'}};

    my @filters = ('objectClass=FripostVirtualDomain');

    if ($domainname) {
        my $d = domain_to_ascii($domainname);
        $d = $options{'-no-star-escape'} ?
                    escape_filter_nostar $d :
                    Net::LDAP::Util::escape_filter_value $d;
        push @filters, 'fvd='.$d;
    }

    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 $domains = $self->ldap->search( base => canonical_dn(@{$self->suffix})
                                     , scope => 'one'
                                     , deref => 'never'
                                     , filter => $filter
                                     , attrs => $attrs
                                     );
    ldap_error($domains, %options) // return;

    return unless defined wantarray;
    return $domains->count if $options{'-count'};

    &_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 = @{ldap_explode_dn shift};
    my @parent = @user;
    shift @parent;
    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{catchAll} = [ map { &_email_to_unicode($_) } @$val ]
                    if not @$keys or grep { $_ eq 'catchAll' } @$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."’";
            }
        }

        # Add a 'permissions' key if wanted.
        if ((not @$keys or grep { $_ eq 'permissions' } @$keys)) {
            my $perms = '';
            $perms .= 'a' if $entry->exists('fripostCanAddAlias') and
                             grep { &_dngrep ($_, \@user, \@parent) }
                                  $entry->get_value('fripostCanAddAlias');
            $perms .= 'l' if $entry->exists('fripostCanAddList') and
                             grep { &_dngrep ($_, \@user, \@parent) }
                                  $entry->get_value('fripostCanAddList');
            $perms  = 'o' if $entry->exists('fripostOwner') and
                             grep { &_dngrep ($_, \@user) }
                                  $entry->get_value('fripostOwner');
            $perms  = 'p' if $entry->exists('fripostPostmaster') and
                             grep { &_dngrep ($_, \@user) }
                                  $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'
              , catchAll => '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 {
            $attrs{$map{$k}} = 1;
        }
    }
    return keys %attrs;
}



=item B<canIAdd> (I<username>, 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.

Errors can be caught with options B<-die> and B<-error>; See
B<Fripost::Schema::Util> for details.

=cut

sub canIAdd {
    my $self = shift;
    my @user = @{ldap_explode_dn ($self->mail2dn(shift) // $self->whoami)};
    my @parent = @user;
    shift @parent;
    my %options = @_;

    # 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 { &_dngrep($_, \@user, \@parent) }
                 $base->get_value('fripostCanAddDomain'));
}



=item B<list_owner_emails> (I<domainname>, I<OPTIONS>)

Search for the e-mail addresses of the person(s) who registered
I<domainname> to a registar, hence who can claim "owning" this domain.

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.

=over 4

=item B<ignore-MX>

An array reference containing hostnames for which no postmaster will be
listed. (Typically, the host we control, since email will then not reach
end users.) Note that subdomains are automatically blacklisted.

=back

Errors can be caught with options B<-die> and B<-error>; See
B<Fripost::Schema::Util> for details.

=cut

sub list_owner_emails {
    my $self = shift;
    my $domainname = shift;
    my %options = @_;

    # Nothing to do after an error.
    return if $options{'-error'} && ${$options{'-error'}};

    my @postmasters;
    my $tld = domain_to_ascii($domainname);
    my $domain;

    until ( tld_exists($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
            unless !$options{'-ignore-MX'} or
                   grep { my ($mx, $ok) = ($_, 0);
                          foreach (@{$options{'-ignore-MX'}}) {
                              if ($mx =~ /\b\Q$_\E$/) { $ok = 1; last };
                          }
                          $ok;
                        } (values %mx);

        $tld =~ s/^[^\.]*\.//;
    }

    # Look for e-mail addresses in the WHOIS.
    my $info = parse_whois( domain => $domain );
    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;
    map {email_to_unicode $_} (sort keys %hash);
}



=item B<add> (I<domain>, I<OPTIONS>)

Add 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. (If you you want to add a non self-managed domain,
choose an empty string for the owner.)

=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.

=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 $domain = shift;
    my %options = @_;

    # Nothing to do after an error.
    return if $options{'-error'} && ${$options{'-error'}};

    my $domainname = $domain->{name};
    # Check domain validity.
    &_assert_valid($domain, %options) // return;

    my $exists;
    if ($options{'-dry-run'} or $options{'-append'}) {
        # Search for an existing domain with the same name. We can't
        # use our previously defined method here, since the current user
        # may not have read access to the entry. There is a race
        # condition since someone could modify the directory between
        # this check and the actual insertion, but then the insertion
        # would fail.
        $exists = ldap_assert_absent( $self, $domain->{name}, undef, %options)
            // return;
        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::ldap_clean_entry( \%attrs );

    my ($mesg, $token);
    my $dn = $self->mail2dn( $domain->{name} );
    if ($options{'-append'} and $exists) {
        # Replace single valued attributes; Add other attributes.
        my %unique;
        foreach (qw/fripostIsStatusActive/) {
            $unique{$_} = delete $attrs{$_} if exists $attrs{$_};
        }
        $mesg = $self->ldap->modify( $dn, replace => \%unique, add => \%attrs );
    }
    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;
        }
        else {
            $attrs{objectClass} = 'FripostVirtualDomain';
        }
        # The default owner is the current user.
        $attrs{fripostOwner} //= [ $self->whoami ];
        $options{'-die'} = { Net::LDAP::Constant::LDAP_ALREADY_EXISTS =>
                                "‘".$domainname."’ exists"
                           , Net::LDAP::Constant::LDAP_SUCCESS => 0 }
            unless exists $options{'-die'};
        $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] );
    }

    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 => $self->cfg('tmpl_path') // './'
                           , INTERPOLATE  => 1 })
                 or die $Template::ERROR;
    my $vars = { domain => $domainname, token => $token };
    $vars->{unlockurl} = ($self->cfg('webapp_url') // '')
                          .encodeURIComponent($domainname)
                          .'/?unlock='.$token;

    my $data;
    $tt->process( 'new-domain.tt', $vars, \$data) or die $tt->error;
    Fripost::Schema::Mail::->new( From    => $self->cfg('email_from') //
                                             $ENV{USER}.'@localhost'
                                , To      => $options{'-send-confirmation-token'}
                                , Subject => "Your new domain ".$domain->{name}
                                , Data    => $data
                                )->send;

    1;
}

# Convert our representation of domains into a hash which keys are LDAP
# attributes.
sub _domain_to_entry {
    my $self = shift;
    my %domain = @_;
    my %entry;

    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 'catchAll') {
            $entry{fripostOptionalMaildrop} = $domain{catchAll};
        }
        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 {
            die "Missing translation for domain key ‘".$key."’";
        }
    }
    return %entry;
}



=item B<replace> (I<domain>, I<OPTIONS>)

Replace an existing domain with the given one.

=over 4

=item B<-dry-run> => 0|1

Merely simulate the replacement. I<domain> is still checked to be a
valid domain in the above representation.

=back

Errors can be caught with options B<-die> and B<-error>; See
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'}};

    # Check domain validity.
    &_assert_valid($domain, %options, -replace => 1) // return;
    return 1 if $options{'-dry-run'};

    my %entry = $self->_domain_to_entry (%$domain);
    my $mesg = $self->ldap->modify( $self->mail2dn($domain->{name})
                                  , replace => \%entry );
    ldap_error($mesg, %options);
}



=item B<delete> (I<domainname>, I<OPTIONS>)

Delete the given I<domainname>.

Errors can be caught with options B<-die> and B<-error>; See
B<Fripost::Schema::Util> for details.

=cut

sub delete {
    my $self = shift;
    my $domainname = shift;
    my %options = @_;

    # Nothing to do after an error.
    return if $options{'-error'} && ${$options{'-error'}};

    my $mesg = $self->ldap->delete( $self->mail2dn($domainname) );
    ldap_error($mesg, %options);
}



# Ensure that the given domain is valid.
sub _assert_valid {
    my $d = shift;
    my %options = @_;
    eval {
        Fripost::Schema::Util::mandatory_attrs( $d, 'name' );
        $d->{isActive} //= 1 unless $options{'-append'} or $options{'-replace'};

        $d->{name} = domain_valid( $d->{name} );
        $d->{catchAll} = [ map { email_valid($_, '-allow-empty-local' => 1) }
                               @{$d->{catchAll}} ]
                if $d->{catchAll};
        $d->{canAddAlias} = [ map { email_valid($_, '-allow-empty-local' => 1) }
                                  @{$d->{canAddAlias}} ]
                if $d->{canAddAlias};
        $d->{canAddList} = [ map { email_valid($_, '-allow-empty-local' => 1) }
                                 @{$d->{canAddList}} ]
                if $d->{canAddList};
        $d->{owner} = [ map { email_valid($_) } @{$d->{owner}} ]
                if $d->{owner};
        $d->{postmaster} = [ map { email_valid($_) } @{$d->{postmaster}} ]
                if $d->{postmaster};
    };
    softdie ($@, %options);
}


# A variant of email_to_unicode that also takes care of domain aliases.
sub _email_to_unicode {
    my $email = shift;
    return '@'.domain_to_unicode($email) if $email =~ s/^\@//;
    return email_to_unicode($email);
}



# DN matching
sub _dngrep {
    my $x = ldap_explode_dn shift;
    scalar (grep {&_dngrep1 ($x, $_)} @_);
}

sub _dngrep1 {
    my ($x, $y) = @_;
    return unless $#$y == $#$x;
    for (my $i = 0; $i <= $#$x; $i++) {
        foreach (keys %{$x->[$i]}) {
            lc $x->[$i]->{$_} eq lc $y->[$i]->{$_} or return;
        }
    }
    return 1;
}

=back

=head1 AUTHOR

Guilhem Moulin C<< <guilhem at fripost.org> >>

=head1 COPYRIGHT

Copyright 2012,2013 Guilhem Moulin.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.

=cut

1;

__END__