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 (I, I) 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 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 => ($_->get_value('fripostIsStatusPending') // '') eq 'TRUE' } } $lists->sorted('fvl') } =item B (I, I) 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 (I, I) 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 /\@/, email_to_ascii($l->{list}), 2; 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 $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 ', 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 (I, I) Tells whether the given list's status is I, 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 => [ '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 (I, I, I) 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 (I, I) 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 ); my ($l2,$d) = split /\@/, $l->{list}, 2; 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<< >> =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__