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

package Fripost::Schema::Domain;

=head1 NAME

Domain.pm -

=head1 DESCRIPTION

Domain.pm 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/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 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 METHODS

=over 4

=item B<search> (I<OPTIONS>)

List every known (and visible) domain. The output is a array of hash
references, sorted by domain names.

=cut

sub search {
    my $self = shift;
    my %options = @_;
    my $concat = $options{'-concat'};

    my $domains = $self->ldap->search(
                      base => canonical_dn(@{$self->suffix}),
                      scope => 'one',
                      deref => 'never',
                      filter => 'objectClass=FripostVirtualDomain',
                      attrs => [ qw/fvd description fripostIsStatusActive
                                    fripostIsStatusPending/ ]
                  );
    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'
                 , ispending => defined $_->get_value('fripostIsStatusPending')
                 , description => concat($concat, $_->get_value('description'))
                 }
               }
               $domains->sorted('fvd')
}


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

Returns a hash with all the (visible) attributes for the given domain.

=cut

sub get {
    my $self = shift;
    my $d = domain_to_ascii(shift);
    my %options = @_;
    my $concat = $options{'-concat'};

    my $domains = $self->ldap->search(
                      base => canonical_dn({fvd => $d}, @{$self->suffix}),
                      scope => 'base',
                      deref => 'never',
                      filter => 'objectClass=FripostVirtualDomain',
                      attrs => [ qw/fvd description
                                    fripostIsStatusActive
                                    fripostOptionalMaildrop
                                    fripostCanAddAlias
                                    fripostCanAddList
                                    fripostOwner
                                    fripostPostmaster/ ]
                  );
    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 ( 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'))
           )
}


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

Replace an existing domain with the given one.

=cut

sub replace {
    my $self = shift;
    my $d = shift;
    my %options = @_;

    foreach (qw/description catchalls canAddAlias canAddList/) {
        $d->{$_} = explode ($options{'-concat'}, $d->{$_})
            if defined $d->{$_};
    }

    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 $domain;
    until ( tld_exists($tld) ) {
        die "‘".$hostname."’ has an Invalid TLD.\n" unless $tld =~ /\./;
        $domain = $tld;

        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/^[^\.]*\.//;
    }

    my $info = parse_whois( domain => $domain );
#    die "Cannot WHOIS ‘".$domain."’.\n" unless defined $info;
    # TODO: there is a bug with the encoding
    if (defined $info) {
        push @postmasters, @{$info->{emails}};
    }

    my %hash;
    $hash{$_} = 1 for grep {email_valid($_ // '', -nodie => 1 )}
                           @postmasters;
    sort keys %hash;
}

sub add {
    my $self = shift;
    my $d = shift;
    my %options = @_;

    foreach (qw/description catchalls canAddAlias canAddList/) {
        $d->{$_} = explode ($options{'-concat'}, $d->{$_})
            if defined $d->{$_};
    }

    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 => [] );
        if ($mesg->code == 0) {
            die "Domain ‘".$domain."’ already exists.\n";
        }
        elsif ($mesg->code != 32) {
            die $mesg->error."\n";
        }

        return if $options{'-dry-run'};

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

        if (defined $d->{owner}) {
            $attrs{fripostOwner} = $self->_fvu2dn($d->{owner})
              if $d->{owner} ne '';
        }
        else {
            $attrs{fripostOwner} = $self->whoami;
        }

        my $token;
        if (defined $d->{send_token_to}) {
            $token = String::Random::->new->randregex('\w{32}');
            $attrs{fripostIsStatusPending} = $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->send;
        }

    };
    return $@;
}

sub unlock {
    my $self = shift;
    my $d = shift;
    my $code = shift;

    eval {
        my $dn = canonical_dn({fvd => domain_to_ascii($d)}, @{$self->suffix});
        my $domains = $self->ldap->search(
                          base => $dn,
                          scope => 'base',
                          deref => 'never',
                          filter => '(&(objectClass=FripostVirtualDomain)'.
                                      '(fripostIsStatusPending=*))',
                          attrs => [ 'fripostIsStatusPending' ]
                      );
        die $domains->error."\n" if $domains->code;

        my $domain = $domains->pop_entry;
        die "No such such domain: ‘".$d."’\n" unless defined $domain;

        die "Wrong unlock code for ‘".$d."’\n"
            unless $domain->get_value('fripostIsStatusPending') eq $code;
        # TODO: a more secure option would be to add a 'userPassword'
        # attribute to domains. We can bind as the domain to check the
        # validity of the token and add an ACL rule to give =z rights on
        # self and =0 for everyone else.

        my $mesg = $self->ldap->modify( $dn, delete => 'fripostIsStatusPending' );
        die $mesg->error."\n" if $mesg->code;
    };
    return $@;
}


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

=cut



# 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@',
                                              -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};
}


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


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