aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Fripost/Schema/List.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Fripost/Schema/List.pm')
-rw-r--r--lib/Fripost/Schema/List.pm306
1 files changed, 0 insertions, 306 deletions
diff --git a/lib/Fripost/Schema/List.pm b/lib/Fripost/Schema/List.pm
deleted file mode 100644
index 2c4d1bc..0000000
--- a/lib/Fripost/Schema/List.pm
+++ /dev/null
@@ -1,306 +0,0 @@
-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::Util qw/concat explode must_attrs email_valid
- split_addr canonical_dn/;
-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=*)))'
- if (defined $options{'-is_pending'}) and !$options{'-is_pending'};
-
- my $lists = $self->ldap->search(
- base => canonical_dn({fvd => $domain}, @{$self->suffix}),
- scope => 'one',
- deref => 'never',
- filter => $filter,
- attrs => [ qw/fvl description fripostIsStatusActive
- fripostIsStatusPending
- 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')
- , ispending => defined $_->get_value('fripostIsStatusPending')
- }
- }
- $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_addr( $l->{list}, -encode => 'ascii' );
- &_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(
- canonical_dn({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 {
- die "Missing list name\n" unless $l->{list} =~ /^.+\@.+$/;
- my ($l2,$d) = split_addr ( $l->{list}, -encode => 'ascii' );
- must_attrs( $l, 'transport' );
- &_is_valid($l);
- die "‘".$l->{list}."’ already exists\n"
- if $self->local->exists( $l->{list}, t => '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 $dn = canonical_dn({fvl => $l2}, {fvd => $d}, @{$self->suffix});
- my $mesg = $self->ldap->add( $dn, 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 = email_valid( $self->_dn2fvu($self->whoami), -exact => 1);
- my $to = email_valid( 'mklist+'.$l->{transport}.'@fripost.org' );
-
- my $mail = MIME::Entity::->build(
- From => 'Fripost Admin Panel <AdminWebPanel@fripost.org>',
- To => $to,
- 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_addr( shift, -encode => 'ascii' );
- my %options = @_;
-
- my $dn = canonical_dn({fvl => $l}, {fvd => $d}, @{$self->suffix});
- my $mesg = $self->ldap->search(
- base => $dn,
- scope => 'base',
- deref => 'never',
- filter => 'objectClass=FripostVirtualList',
- attrs => [ '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_addr( shift, -encode => 'ascii' );
- my $cmds = shift;
- my %options = @_;
-
- my $mesg;
- foreach my $cmd (@$cmds) {
- my $dn = canonical_dn( {fvlc => $l.'-'.$cmd}, {fvl => $l}, {fvd => $d},
- @{$self->suffix} );
- $mesg = $self->ldap->add( $dn,
- attrs => [ objectClass => 'FripostVirtualListCommand',
- FripostLocalAlias => $l.'-'.$cmd.'#'.$d ] );
- last if $mesg->code;
- }
-
- my $dn = canonical_dn( {fvl => $l}, {fvd => $d}, @{$self->suffix} );
- $mesg = $self->ldap->modify( $dn, 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_addr( shift, -encode => 'ascii' );
- my %options = @_;
-
- my $dn = canonical_dn( {fvl => $l}, {fvd => $d}, @{$self->suffix} );
- my $mesg = $self->ldap->delete( $dn );
- 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 );
-
- my ($l2,$d) = split_addr( $l->{list} );
- foreach ( qw/admin bounces confirm join leave owner request subscribe unsubscribe bounce sendkey/ ){
- die "Invalid list name: ‘".$l->{list}."’\n" if $l2 =~ /-$_$/;
- }
- die "Invalid list name: ‘".$l->{list}."’\n"
- unless $l->{list} =~ /^[[:alnum:]_=\+\-\.\@]+$/;
-
- die "Invalid transport: ‘".$l->{transport}."’\n"
- if defined $l->{transport} and
- $l->{transport} !~ /^(schleuder|mailman)$/;
-}
-
-
-=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__
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-07 20:31:58 +0000