diff options
author | Guilhem Moulin <guilhem.moulin@fripost.org> | 2013-01-29 21:44:24 +0100 |
---|---|---|
committer | Guilhem Moulin <guilhem.moulin@fripost.org> | 2013-01-29 21:44:24 +0100 |
commit | 465f8ed1b317afb1c7aefde04e53118a19be1a18 (patch) | |
tree | b9f92574022267058f34326edfa25195afdc4e4b /lib/Fripost/Schema/List.pm | |
parent | 38bbf969d6c29891f40973a0db376d5f5ee5ab07 (diff) |
Finished the factoring of localpart-related methods.
Diffstat (limited to 'lib/Fripost/Schema/List.pm')
-rw-r--r-- | lib/Fripost/Schema/List.pm | 306 |
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__ |