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

package Fripost::Schema::List;

=head1 NAME

List.pm -

=head1 DESCRIPTION

List.pm abstracts the LDAP schema definition and provides methods to
add, list or delete virtual mailing lists.

=cut

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

use parent 'Fripost::Schema';
use Fripost::Schema::Misc qw/concat explode must_attrs email_valid/;
use Net::IDN::Encode qw/domain_to_ascii
                        email_to_ascii email_to_unicode/;
use Mail::GnuPG;
use MIME::Entity;


=head1 METHODS

=over 4

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

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

=cut

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

    my $filter = 'objectClass=FripostVirtualList';
    $filter = '(&('.$filter.')(!(fripostIsStatusPending=TRUE)))'
        if (defined $options{'-is_pending'}) and !$options{'-is_pending'};

    my $lists = $self->ldap->search(
                    base => "fvd=$domain,".$self->suffix,
                    scope => 'one',
                    deref => 'never',
                    filter => $filter,
                    attrs => [ qw/fvl description fripostIsStatusActive
                                  fripostListManager/ ]
                  );
    if ($lists->code) {
        die $options{'-die'}."\n" if defined $options{'-die'};
        die $lists->error."\n";
    }
    return map { { list => email_to_unicode($_->get_value('fvl'))
                 , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE'
                 , description => concat($concat, $_->get_value('description'))
                 , transport => $_->get_value('fripostListManager')
                 }
               }
               $lists->sorted('fvl')
}


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

Replace an existing list with the given one.

=cut

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

    $l->{description} = explode ($options{'-concat'}, $l->{description})
        if defined $l->{description};

    eval {
        my ($l2,$d) = split /\@/, email_to_ascii($l->{list}), 2;
        &_is_valid($l);
        my $l3 = { fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE'
                 , description => $l->{description} };
        $l3->{fripostListManager} = $l->{transport} if defined $l->{transport};
        my $mesg = $self->ldap->modify(
                       "fvl=$l2,fvd=$d,".$self->suffix,
                       replace => $l3 );
        die $mesg->error."\n" if $mesg->code;
    };
    return $@;
}


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

Add the given list.

=cut

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

    my $lname = $l->{list};
    $l->{description} = explode ($options{'-concat'}, $l->{description})
        if defined $l->{description};


    eval {
        my ($l2,$d) = split /\@/, email_to_ascii($l->{list}), 2;
        die "Missing list name\n" if $l eq '';
        must_attrs( $l, 'transport' );
        &_is_valid($l);
        die "‘".$l->{list}."‘ already exists\n"
            if $self->local->exists($l->{list},%options);

        my %attrs = ( objectClass => 'FripostVirtualList'
                    , fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE'
                    , fripostOwner => $self->whoami
                    , fripostListManager => $l->{transport}
                    , fripostIsStatusPending => 'TRUE'
                    , fripostLocalAlias => $l2.'#'.$d
                    );
        $attrs{description} = $l->{description}
            if defined $l->{description} and @{$l->{description}};

        my $mesg = $self->ldap->add( "fvl=$l2,fvd=$d,".$self->suffix,
                                     attrs => [ %attrs ] );
        if ($mesg->code) {
            die $options{'-die'}."\n" if defined $options{'-die'};
            die $mesg->error."\n";
        }
    };
    return $@ if $@;

    # Ask the list manager to create the list now.
    my $member = $self->whoami;
    $member =~ s/^fvu=([^,]+),fvd=([^,]+),.*$/$1\@$2/;
    my $mail = MIME::Entity::->build(
        From     => 'Fripost Admin Panel <AdminWebPanel@fripost.org>',
        To       => 'mklist+'.$l->{transport}.'@fripost.org',
        Subject  => "New ".$l->{transport}." list",
        Encoding => 'quoted-printable',
        Charset  => 'utf-8',
        Data     => [ map { $_ . "\n"} ($lname, $member, $l->{password}) ]
    );
    my $gpg = Mail::GnuPG::->new( %{$options{gpg}} );
    my $ret = $gpg->mime_sign( $mail );
    return join ("\n", @{$gpg->{last_message}}) if $ret;
    $mail->send;
    return 0;
}


=item B<is_pending> (I<list>, I<OPTIONS>)

Tells whether the given list's status is I<pending>, meaning an entry
has been created in the LDAP directory (for instance by the domain owner
from the Web Panel), but the local aliases have not yet been added by
the ListCreator entity, and the list is not known by the list manager.

=cut

sub is_pending {
    my $self = shift;
    my ($l,$d) = split /\@/, email_to_ascii(shift), 2;
    my %options = @_;

    my $mesg = $self->ldap->search(
                    base => "fvl=$l,fvd=$d,".$self->suffix,
                    scope => 'base',
                    deref => 'never',
                    filter => 'objectClass=FripostVirtualList',
                    attrs => [ 'fvl', 'fripostIsStatusPending' ]
                  );
    die "Error: ".$l.'@'.$d.": No such object in the LDAP directory\n"
        if $mesg->code == 32; # No such object; a common error here.
    die $mesg->error if $mesg->code;

    die "Error: Multiple matching entries found." if $mesg->count > 1;
    my $list = $mesg->pop_entry;

    die "Error: No matching entry found." unless defined $list;
    my $r = $list->get_value('fripostIsStatusPending');
    return (defined $r and $r eq 'TRUE');
}


=item B<add_commands> (I<list>, I<transport>, I<OPTIONS>)

Add the lists commands, and remove the pending status.

=cut

sub add_commands {
    my $self = shift;
    my ($l,$d) = split /\@/, email_to_ascii(shift), 2;
    my $cmds = shift;
    my %options = @_;

    my $mesg;
    foreach my $cmd (@$cmds) {
        $mesg = $self->ldap->add( "fvlc=$l-$cmd,fvl=$l,fvd=$d,".$self->suffix,
                       attrs => [ objectClass => 'FripostVirtualListCommand',
                                  FripostLocalAlias => $l.'-'.$cmd.'#'.$d ] );
        last if $mesg->code;
    }

    $mesg = $self->ldap->modify( "fvl=$l,fvd=$d,".$self->suffix,
                               , delete => 'fripostIsStatusPending' )
        unless $mesg->code;

    if ($mesg->code) {
        die $options{'-die'}."\n" if defined $options{'-die'};
        die $mesg->error."\n";
    }
}


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

Delete the given list. Note: this will NOT wipe the archives off the
disk, but merely delete the list entry in the LDAP directory.

=cut

sub delete {
    my $self = shift;
    my ($l,$d) = split /\@/, email_to_ascii(shift), 2;
    my %options = @_;

    my $mesg = $self->ldap->delete( "fvl=$l,fvd=$d,".$self->suffix );
    if ($mesg->code) {
        if (defined $options{'-die'}) {
            return $mesg->error unless $options{'-die'};
            die $options{'-die'}."\n";
        }
        die $mesg->error."\n";
    }
}


=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 alias is valid.
sub _is_valid {
    my $l = shift;
    must_attrs( $l, qw/list isactive/ );
    $l->{list} = email_valid( $l->{list}, -exact => 1 );

    die "Invalid transport: ‘".$l->{transport}."‘\n"
        if defined $l->{transport} and
            $l->{transport} !~ /^(schleuder|mailman)$/;
    # TODO: check commands
}


=head1 AUTHOR

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

=head1 COPYRIGHT

Copyright 2012 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__