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

package Fripost::Schema::Domain;

=head1 NAME

Domain.pm - Domain related methods in 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::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;

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

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) {
        $domainname = Net::LDAP::Util::escape_filter_value($domainname)
            unless $options{'-no-escape'};
        push @filters, 'fvd='.$domainname;
    }

    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 $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."’.";
            }
        }

        # 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 {
            $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 @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 = @_;

    # 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<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 list_admin_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
        if grep {!/\bfripost\.org$/} (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;
    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 $domain = shift;
    my %options = @_;

    # 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 );
    }
    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 ];
        $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 => $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;
}

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



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

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

    my $dn = $self->mail2dn( $domainname );
    my $mesg = $self->ldap->compare( $dn
                                   , attr => 'fripostPendingToken'
                                   , value => $token );
    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);
}






=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;
    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}} ]
                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);
}


# 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);
}

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