diff options
Diffstat (limited to 'lib/Sietima/Role')
| -rw-r--r-- | lib/Sietima/Role/AvoidDups.pm | 64 | ||||
| -rw-r--r-- | lib/Sietima/Role/Debounce.pm | 58 | ||||
| -rw-r--r-- | lib/Sietima/Role/Headers.pm | 164 | ||||
| -rw-r--r-- | lib/Sietima/Role/ManualSubscription.pm | 64 | ||||
| -rw-r--r-- | lib/Sietima/Role/NoMail.pm | 48 | ||||
| -rw-r--r-- | lib/Sietima/Role/ReplyTo.pm | 136 | ||||
| -rw-r--r-- | lib/Sietima/Role/SubjectTag.pm | 73 | ||||
| -rw-r--r-- | lib/Sietima/Role/SubscriberOnly.pm | 98 | ||||
| -rw-r--r-- | lib/Sietima/Role/SubscriberOnly/Drop.pm | 43 | ||||
| -rw-r--r-- | lib/Sietima/Role/SubscriberOnly/Moderate.pm | 280 | ||||
| -rw-r--r-- | lib/Sietima/Role/WithMailStore.pm | 48 | ||||
| -rw-r--r-- | lib/Sietima/Role/WithOwner.pm | 67 | ||||
| -rw-r--r-- | lib/Sietima/Role/WithPostAddress.pm | 60 |
13 files changed, 791 insertions, 412 deletions
diff --git a/lib/Sietima/Role/AvoidDups.pm b/lib/Sietima/Role/AvoidDups.pm index e0a5bae..3fe6182 100644 --- a/lib/Sietima/Role/AvoidDups.pm +++ b/lib/Sietima/Role/AvoidDups.pm @@ -4,26 +4,9 @@ use Sietima::Policy; use Email::Address; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: prevent people from receiving the same message multiple times -=head1 SYNOPSIS - - my $sietima = Sietima->with_traits('AvoidDups')->new(\%args); - -=head1 DESCRIPTION - -A L<< C<Sietima> >> list with this role applied will not send a -message to a subscriber, if that subscriber is already mentioned in -the C<To:> or C<Cc:> header fields, because they can be assumed to be -already receiving the message directly from the sender. - -=modif C<subscribers_to_send_to> - -Filters out subscribers that L<match|Sietima::Subscriber/match> the -addresses in the C<To:> or C<Cc:> headers of the incoming email. - -=cut around subscribers_to_send_to => sub ($orig,$self,$mail) { my @already_receiving = map { @@ -43,3 +26,48 @@ around subscribers_to_send_to => sub ($orig,$self,$mail) { }; 1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::AvoidDups - prevent people from receiving the same message multiple times + +=head1 VERSION + +version 1.0.5 + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('AvoidDups')->new(\%args); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will not send a +message to a subscriber, if that subscriber is already mentioned in +the C<To:> or C<Cc:> header fields, because they can be assumed to be +already receiving the message directly from the sender. + +=head1 MODIFIED METHODS + +=head2 C<subscribers_to_send_to> + +Filters out subscribers that L<match|Sietima::Subscriber/match> the +addresses in the C<To:> or C<Cc:> headers of the incoming email. + +=head1 AUTHOR + +Gianni Ceccarelli <dakkar@thenautilus.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/Debounce.pm b/lib/Sietima/Role/Debounce.pm index e6bd087..129fcff 100644 --- a/lib/Sietima/Role/Debounce.pm +++ b/lib/Sietima/Role/Debounce.pm @@ -3,9 +3,41 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: avoid mail loops + +my $been_there = 'X-Been-There'; + +around munge_mail => sub ($orig,$self,$incoming_mail) { + my $return_path = $self->return_path->address; + if (my $there = $incoming_mail->header_str($been_there)) { + return if $there =~ m{\b\Q$return_path\E\b}; + } + + $incoming_mail->header_str_set( + $been_there => $return_path, + ); + + return $self->$orig($incoming_mail); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::Debounce - avoid mail loops + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('Debounce')->new(\%args); @@ -18,28 +50,24 @@ have that same header. This prevents messages bounced by other services from being looped between the mailing list and those other services. -=modif C<munge_mail> +=head1 MODIFIED METHODS + +=head2 C<munge_mail> If the incoming email contains our C<X-Been-There:> header, this method will return an empty list (essentially dropping the message). Otherwise, the header is added, and the email is processed normally. -=cut +=head1 AUTHOR -my $been_there = 'X-Been-There'; +Gianni Ceccarelli <dakkar@thenautilus.net> -around munge_mail => sub ($orig,$self,$incoming_mail) { - my $return_path = $self->return_path->address; - if (my $there = $incoming_mail->header_str($been_there)) { - return if $there =~ m{\b\Q$return_path\E\b}; - } +=head1 COPYRIGHT AND LICENSE - $incoming_mail->header_str_set( - $been_there => $return_path, - ); +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. - return $self->$orig($incoming_mail); -}; +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. -1; +=cut diff --git a/lib/Sietima/Role/Headers.pm b/lib/Sietima/Role/Headers.pm index 794a5e9..2547b70 100644 --- a/lib/Sietima/Role/Headers.pm +++ b/lib/Sietima/Role/Headers.pm @@ -8,61 +8,9 @@ use Types::Standard qw(Str); use Sietima::Types qw(HeaderUriFromThings); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: adds standard list-related headers to messages -=head1 SYNOPSIS - - my $sietima = Sietima->with_traits('Headers')->new({ - %args, - name => $name_of_the_list, - }); - -=head1 DESCRIPTION - -A L<< C<Sietima> >> list with this role applied will add, to each -outgoing message, the set of headers defined in RFC 2919 and RFC 2369. - -This role uses the L<< C<list_addresses>|Sietima/list_addresses >> -method to determine what headers to add. - -If the C<name> attribute is set, a C<List-Id:> header will be added, -with a value built out of the name and the C<< -$self->list_addresses->{return_path} >> value (which is normally the -same as the L<< C<return_path>|Sietima/return_path >> attribute). - -Other C<List-*:> headers are built from the other values in the -C<list_addresses> hashref. Each of those values can be: - -=begin :list - -* an L<< C<Sietima::HeaderURI> >> object - -* a thing that can be passed to that class's constructor: - -=for :list -* an L<< C<Email::Address> >> object -* a L<< C<URI> >> object -* a string parseable as either - -* an arrayref containing any mix of the above - -=end :list - -As a special case, if C<< $self->list_addresses->{post} >> exists and -is false, the C<List-Post> header will have the value C<NO> to -indicate that the list does not accept incoming messages (e.g. it's an -announcement list). - -=attr C<name> - -Optional string, the name of the mailing list. If this attribute is -set, a C<List-Id:> header will be added, with a value built out of the -name and the C<< $self->list_addresses->{return_path} >> value (which -is normally the same as the L<< C<return_path>|Sietima/return_path >> -attribute). - -=cut has name => ( isa => Str, @@ -120,12 +68,6 @@ sub _add_headers_to($self,$message) { return; } -=modif C<munge_mail> - -This method adds list-management headers to each message returned by -the original method. - -=cut around munge_mail => sub ($orig,$self,$mail) { my @messages = $self->$orig($mail); @@ -134,3 +76,107 @@ around munge_mail => sub ($orig,$self,$mail) { }; 1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::Headers - adds standard list-related headers to messages + +=head1 VERSION + +version 1.0.5 + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('Headers')->new({ + %args, + name => $name_of_the_list, + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will add, to each +outgoing message, the set of headers defined in RFC 2919 and RFC 2369. + +This role uses the L<< C<list_addresses>|Sietima/list_addresses >> +method to determine what headers to add. + +If the C<name> attribute is set, a C<List-Id:> header will be added, +with a value built out of the name and the C<< +$self->list_addresses->{return_path} >> value (which is normally the +same as the L<< C<return_path>|Sietima/return_path >> attribute). + +Other C<List-*:> headers are built from the other values in the +C<list_addresses> hashref. Each of those values can be: + +=over 4 + +=item * + +an L<< C<Sietima::HeaderURI> >> object + +=item * + +a thing that can be passed to that class's constructor: + +=over 4 + +=item * + +an L<< C<Email::Address> >> object + +=item * + +a L<< C<URI> >> object + +=item * + +a string parseable as either + +=back + +=item * + +an arrayref containing any mix of the above + +=back + +As a special case, if C<< $self->list_addresses->{post} >> exists and +is false, the C<List-Post> header will have the value C<NO> to +indicate that the list does not accept incoming messages (e.g. it's an +announcement list). + +=head1 ATTRIBUTES + +=head2 C<name> + +Optional string, the name of the mailing list. If this attribute is +set, a C<List-Id:> header will be added, with a value built out of the +name and the C<< $self->list_addresses->{return_path} >> value (which +is normally the same as the L<< C<return_path>|Sietima/return_path >> +attribute). + +=head1 MODIFIED METHODS + +=head2 C<munge_mail> + +This method adds list-management headers to each message returned by +the original method. + +=head1 AUTHOR + +Gianni Ceccarelli <dakkar@thenautilus.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/ManualSubscription.pm b/lib/Sietima/Role/ManualSubscription.pm index c2711f0..ebda9c9 100644 --- a/lib/Sietima/Role/ManualSubscription.pm +++ b/lib/Sietima/Role/ManualSubscription.pm @@ -4,11 +4,45 @@ use Sietima::Policy; use Sietima::HeaderURI; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: adds standard list-related headers to messages with 'Sietima::Role::WithOwner'; + +around list_addresses => sub($orig,$self) { + my $list_name = $self->name // 'the list'; + + return +{ + $self->$orig->%*, + subscribe => Sietima::HeaderURI->new_from_address( + $self->owner, + { subject => "Please add me to $list_name" }, + ), + unsubscribe => Sietima::HeaderURI->new_from_address( + $self->owner, + { subject => "Please remove me from $list_name" }, + ), + }; +}; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::ManualSubscription - adds standard list-related headers to messages + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits( @@ -26,29 +60,23 @@ C<Headers>|Sietima::Role::Headers >>) applied will add, to each outgoing message, headers specifying that to subscribe and unsubscribe, people sould email the list owner. -=modif C<list_addresses> +=head1 MODIFIED METHODS + +=head2 C<list_addresses> This method declares two "addresses", C<subscribe> and C<unsubscribe>. Both are C<mailto:> URLs for the list L<owner|Sietima::Role::WithOwner/owner>, with different subjects. -=cut +=head1 AUTHOR -around list_addresses => sub($orig,$self) { - my $list_name = $self->name // 'the list'; +Gianni Ceccarelli <dakkar@thenautilus.net> - return +{ - $self->$orig->%*, - subscribe => Sietima::HeaderURI->new_from_address( - $self->owner, - { subject => "Please add me to $list_name" }, - ), - unsubscribe => Sietima::HeaderURI->new_from_address( - $self->owner, - { subject => "Please remove me from $list_name" }, - ), - }; -}; +=head1 COPYRIGHT AND LICENSE +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. -1; +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/NoMail.pm b/lib/Sietima/Role/NoMail.pm index 10071d6..6d46a3d 100644 --- a/lib/Sietima/Role/NoMail.pm +++ b/lib/Sietima/Role/NoMail.pm @@ -3,9 +3,33 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: don't send mail to those who don't want it + +around subscribers_to_send_to => sub ($orig,$self,$mail) { + return [ + grep { $_->prefs->{wants_mail} // 1 } + $self->$orig($mail)->@*, + ]; +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::NoMail - don't send mail to those who don't want it + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('NoMail')->new({ @@ -22,18 +46,22 @@ A L<< C<Sietima> >> list with this role applied will not send messages to subscribers that have the C<wants_mail> preference set to a false value. -=modif C<subscribers_to_send_to> +=head1 MODIFIED METHODS + +=head2 C<subscribers_to_send_to> Filters out subscribers that have the C<wants_mail> preference set to a false value. -=cut +=head1 AUTHOR -around subscribers_to_send_to => sub ($orig,$self,$mail) { - return [ - grep { $_->prefs->{wants_mail} // 1 } - $self->$orig($mail)->@*, - ]; -}; +Gianni Ceccarelli <dakkar@thenautilus.net> -1; +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/ReplyTo.pm b/lib/Sietima/Role/ReplyTo.pm index 6b21f20..f790842 100644 --- a/lib/Sietima/Role/ReplyTo.pm +++ b/lib/Sietima/Role/ReplyTo.pm @@ -6,9 +6,79 @@ use Sietima::Types qw(Address AddressFromStr); use List::AllUtils qw(part); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: munge the C<Reply-To> header + +with 'Sietima::Role::WithPostAddress'; + + +has munge_reply_to => ( + is => 'ro', + isa => Bool, + default => 0, +); + + +around munge_mail => sub ($orig,$self,$mail) { + my @messages = $self->$orig($mail); + my @ret; + for my $m (@messages) { + my ($leave,$munge) = part { + my $m = $_->prefs->{munge_reply_to}; + defined $m ? ( + $m ? 1 : 0 + ) : ( $self->munge_reply_to ? 1 : 0 ) + } $m->to->@*; + + if (not ($munge and $munge->@*)) { + # nothing to do + push @ret,$m; + } + elsif (not ($leave and $leave->@*)) { + # all these recipients want munging + $m->mail->header_str_set('Reply-To',$self->post_address->address); + push @ret,$m; + } + else { + # some want it, some don't: create two different messages + my $leave_message = Sietima::Message->new({ + mail => $m->mail, + from => $m->from, + to => $leave, + }); + + my $munged_mail = Email::MIME->new($m->mail->as_string); + $munged_mail->header_str_set('Reply-To',$self->post_address->address); + + my $munged_message = Sietima::Message->new({ + mail => $munged_mail, + from => $m->from, + to => $munge, + }); + + push @ret,$leave_message,$munged_message; + } + } + return @ret; +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::ReplyTo - munge the C<Reply-To> header + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('ReplyTo')->new({ @@ -36,26 +106,18 @@ not touched. This is a "sub-role" of L<< C<WithPostAddress>|Sietima::Role::WithPostAddress >>. -=cut - -with 'Sietima::Role::WithPostAddress'; +=head1 ATTRIBUTES -=attr C<munge_reply_to> +=head2 C<munge_reply_to> Optional boolean, defaults to false. If set to a true value, all messages will have their C<Reply-To:> header set to the value of the L<< /C<post_address> >> attribute. This setting can be overridden by individual subscribers with the C<munge_reply_to> preference. -=cut - -has munge_reply_to => ( - is => 'ro', - isa => Bool, - default => 0, -); +=head1 MODIFIED METHODS -=modif C<munge_mail> +=head2 C<munge_mail> For each message returned by the original method, this method partitions the subscribers, who are recipients of the message, @@ -74,49 +136,15 @@ don't, this method will clone the message, modify the header in one copy, set the appropriate part of the recipients to each copy, and pass both through. -=cut +=head1 AUTHOR -around munge_mail => sub ($orig,$self,$mail) { - my @messages = $self->$orig($mail); - my @ret; - for my $m (@messages) { - my ($leave,$munge) = part { - my $m = $_->prefs->{munge_reply_to}; - defined $m ? ( - $m ? 1 : 0 - ) : ( $self->munge_reply_to ? 1 : 0 ) - } $m->to->@*; +Gianni Ceccarelli <dakkar@thenautilus.net> - if (not ($munge and $munge->@*)) { - # nothing to do - push @ret,$m; - } - elsif (not ($leave and $leave->@*)) { - # all these recipients want munging - $m->mail->header_str_set('Reply-To',$self->post_address->address); - push @ret,$m; - } - else { - # some want it, some don't: create two different messages - my $leave_message = Sietima::Message->new({ - mail => $m->mail, - from => $m->from, - to => $leave, - }); - - my $munged_mail = Email::MIME->new($m->mail->as_string); - $munged_mail->header_str_set('Reply-To',$self->post_address->address); +=head1 COPYRIGHT AND LICENSE - my $munged_message = Sietima::Message->new({ - mail => $munged_mail, - from => $m->from, - to => $munge, - }); +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. - push @ret,$leave_message,$munged_message; - } - } - return @ret; -}; +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. -1; +=cut diff --git a/lib/Sietima/Role/SubjectTag.pm b/lib/Sietima/Role/SubjectTag.pm index 7602405..ac3f71c 100644 --- a/lib/Sietima/Role/SubjectTag.pm +++ b/lib/Sietima/Role/SubjectTag.pm @@ -4,9 +4,44 @@ use Sietima::Policy; use Types::Standard qw(Str); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: add a tag to messages' subjects + +has subject_tag => ( + is => 'ro', + isa => Str, + required => 1, +); + + +around munge_mail => sub ($orig,$self,$mail) { + my $tag = '['.$self->subject_tag.']'; + my $subject = $mail->header_str('Subject'); + unless ($subject =~ m{\Q$tag\E}) { + $mail->header_str_set( + Subject => "$tag $subject", + ); + } + return $self->$orig($mail); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::SubjectTag - add a tag to messages' subjects + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('SubjectTag')->new({ @@ -19,7 +54,9 @@ use namespace::clean; A L<< C<Sietima> >> list with this role applied will prepend the given tag to every outgoing message's C<Subject:> header. -=attr C<subject_tag> +=head1 ATTRIBUTES + +=head2 C<subject_tag> Required string. This string, enclosed by square brackets, will be prepended to the C<Subject:> header of outgoing messages. For example, @@ -30,30 +67,22 @@ If the incoming message's C<Subject:> header already contains the tag, the header will not be modified. This prevents getting subjects like "[foo] Re: [foo] Re: [foo] new stuff". -=cut +=head1 MODIFIED METHODS -has subject_tag => ( - is => 'ro', - isa => Str, - required => 1, -); - -=modif C<munge_mail> +=head2 C<munge_mail> The subject of the incoming email is modified to add the tag (unless it's already there). The email is then processed normally. -=cut +=head1 AUTHOR -around munge_mail => sub ($orig,$self,$mail) { - my $tag = '['.$self->subject_tag.']'; - my $subject = $mail->header_str('Subject'); - unless ($subject =~ m{\Q$tag\E}) { - $mail->header_str_set( - Subject => "$tag $subject", - ); - } - return $self->$orig($mail); -}; +Gianni Ceccarelli <dakkar@thenautilus.net> -1; +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/SubscriberOnly.pm b/lib/Sietima/Role/SubscriberOnly.pm index 6524d39..41002f3 100644 --- a/lib/Sietima/Role/SubscriberOnly.pm +++ b/lib/Sietima/Role/SubscriberOnly.pm @@ -7,9 +7,50 @@ use Types::Standard qw(Object CodeRef); use Type::Params qw(compile); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: base role for "closed" lists + +requires 'munge_mail_from_non_subscriber'; + +our $let_it_pass=0; ## no critic(ProhibitPackageVars) + + +around munge_mail => sub ($orig,$self,$mail) { + my ($from) = Email::Address->parse( $mail->header_str('from') ); + if ( $let_it_pass or + any { $_->match($from) } $self->subscribers->@* ) { + $self->$orig($mail); + } + else { + $self->munge_mail_from_non_subscriber($mail); + } +}; + + +sub ignoring_subscriberonly($self,$code) { + state $check = compile(Object,CodeRef); $check->(@_); + + local $let_it_pass = 1; + return $code->($self); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::SubscriberOnly - base role for "closed" lists + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS package Sietima::Role::SubscriberOnly::MyPolicy; @@ -29,7 +70,9 @@ with messages from non-subscribers. See L<< C<Sietima::Role::SubscriberOnly::Drop> >> and L<< C<Sietima::Role::SubscriberOnly::Moderate> >> for useable roles. -=require C<munge_mail_from_non_subscriber> +=head1 REQUIRED METHODS + +=head2 C<munge_mail_from_non_subscriber> sub munge_mail_from_non_subscriber($self,$mail) { ... } @@ -40,50 +83,37 @@ of L<< C<Sietima::Message> >> objects, just like C<munge_mail>. It can also have side-effects, like forwarding the email to the owner of the list. -=cut +=head1 METHODS -requires 'munge_mail_from_non_subscriber'; +=head2 C<ignoring_subscriberonly> -our $let_it_pass=0; ## no critic(ProhibitPackageVars) + $sietima->ignoring_subscriberonly(sub($s) { + $s->handle_mail($mail); + }); + +This method provides a way to run Sietima ignoring the "subscriber +only" beaviour. Your coderef will be passed a Sietima object that will +behave exactly as the invocant of this method, minus this role's +modifications. + +=head1 MODIFIED METHODS -=modif C<munge_mail> +=head2 C<munge_mail> If the incoming email's C<From:> header contains an address that L<matches|Sietima::Subscriber/match> any of the subscribers, the email is processed normally. Otherwise, L<< /C<munge_mail_from_non_subscriber> >> is invoked. -=cut +=head1 AUTHOR -around munge_mail => sub ($orig,$self,$mail) { - my ($from) = Email::Address->parse( $mail->header_str('from') ); - if ( $let_it_pass or - any { $_->match($from) } $self->subscribers->@* ) { - $self->$orig($mail); - } - else { - $self->munge_mail_from_non_subscriber($mail); - } -}; +Gianni Ceccarelli <dakkar@thenautilus.net> -=method C<ignoring_subscriberonly> +=head1 COPYRIGHT AND LICENSE - $sietima->ignoring_subscriberonly(sub($s) { - $s->handle_mail($mail); - }); +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. -This method provides a way to run Sietima ignoring the "subscriber -only" beaviour. Your coderef will be passed a Sietima object that will -behave exactly as the invocant of this method, minus this role's -modifications. +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. =cut - -sub ignoring_subscriberonly($self,$code) { - state $check = compile(Object,CodeRef); $check->(@_); - - local $let_it_pass = 1; - return $code->($self); -} - -1; diff --git a/lib/Sietima/Role/SubscriberOnly/Drop.pm b/lib/Sietima/Role/SubscriberOnly/Drop.pm index d9de94e..bfe7afb 100644 --- a/lib/Sietima/Role/SubscriberOnly/Drop.pm +++ b/lib/Sietima/Role/SubscriberOnly/Drop.pm @@ -3,9 +3,31 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: drop messages from non-subscribers + +with 'Sietima::Role::SubscriberOnly'; + + +sub munge_mail_from_non_subscriber { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::SubscriberOnly::Drop - drop messages from non-subscribers + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('SubscribersOnly::Drop')->new({ @@ -21,16 +43,21 @@ subscribers. This is a "sub-role" of L<< C<SubscribersOnly>|Sietima::Role::SubscriberOnly >>. -=cut - -with 'Sietima::Role::SubscriberOnly'; +=head1 METHODS -=method C<munge_mail_from_non_subscriber> +=head2 C<munge_mail_from_non_subscriber> Does nothing, returns an empty list. -=cut +=head1 AUTHOR -sub munge_mail_from_non_subscriber { } +Gianni Ceccarelli <dakkar@thenautilus.net> -1; +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/SubscriberOnly/Moderate.pm b/lib/Sietima/Role/SubscriberOnly/Moderate.pm index e7fbb7b..ec7454a 100644 --- a/lib/Sietima/Role/SubscriberOnly/Moderate.pm +++ b/lib/Sietima/Role/SubscriberOnly/Moderate.pm @@ -5,9 +5,142 @@ use Email::Stuffer; use Email::MIME; use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: moderate messages from non-subscribers + +with 'Sietima::Role::SubscriberOnly', + 'Sietima::Role::WithMailStore', + 'Sietima::Role::WithOwner'; + + +sub munge_mail_from_non_subscriber ($self,$mail) { + my $id = $self->mail_store->store($mail,'moderation'); + my $notice = Email::Stuffer + ->from($self->return_path->address) + ->to($self->owner->address) + ->subject("Message held for moderation - ".$mail->header_str('subject')) + ->text_body("Use id $id to refer to it") + ->attach( + $mail->as_string, + content_type => 'message/rfc822', + # some clients, most notably Claws-Mail, seem to have + # problems with encodings other than this + encoding => '7bit', + ); + $self->transport->send($notice->email,{ + from => $self->return_path, + to => [ $self->owner ], + }); + return; +} + + +sub resume ($self,$mail_id) { + my $mail = $self->mail_store->retrieve_by_id($mail_id); + $self->ignoring_subscriberonly( + sub($s) { $s->handle_mail($mail) }, + ); + $self->mail_store->remove($mail_id); +} + + +sub drop ($self,$mail_id) { + $self->mail_store->remove($mail_id); +} + + +sub list_mails_in_moderation_queue ($self,$runner,@) { + my $mails = $self->mail_store->retrieve_by_tags('moderation'); + $runner->out(sprintf 'There are %d messages held for moderation:',scalar($mails->@*)); + for my $mail ($mails->@*) { + $runner->out(sprintf '* %s %s "%s" (%s)', + $mail->{id}, + $mail->{mail}->header_str('From')//'<no from>', + $mail->{mail}->header_str('Subject')//'<no subject>', + $mail->{mail}->header_str('Date')//'<no date>', + ); + } +} + + +sub show_mail_from_moderation_queue ($self,$runner,@) { + my $id = $runner->parameters->{'mail-id'}; + my $mail = $self->mail_store->retrieve_by_id($id); + $runner->out("Message $id:"); + $runner->out($mail->as_string =~ s{\r\n}{\n}gr); +} + + +sub resume_mail_from_moderation_queue ($self,$runner,@) { + $self->resume($runner->parameters->{'mail-id'}); +} + + +sub drop_mail_from_moderation_queue ($self,$runner,@) { + $self->drop($runner->parameters->{'mail-id'}); +} + + +around command_line_spec => sub ($orig,$self) { + my $spec = $self->$orig(); + + # this allows us to tab-complete identifiers from the shell! + my $list_mail_ids = sub ($self,$runner,$args) { + $self->mail_store->retrieve_ids_by_tags('moderation'); + }; + # a little factoring: $etc->($command_name) generates the spec for + # sub-commands that require a mail id + my $etc = sub($cmd) { + return ( + summary => "$cmd the given mail, currently held for moderation", + parameters => [ + { + name => 'mail-id', + required => 1, + summary => "id of the mail to $cmd", + completion => { op => $list_mail_ids }, + }, + ], + ); + }; + + $spec->{subcommands}{'list-held'} = { + op => 'list_mails_in_moderation_queue', + summary => 'list all mails currently held for moderation', + }; + $spec->{subcommands}{'show-held'} = { + op => 'show_mail_from_moderation_queue', + $etc->('show'), + }; + $spec->{subcommands}{'resume-held'} = { + op => 'resume_mail_from_moderation_queue', + $etc->('resume'), + }; + $spec->{subcommands}{'drop-held'} = { + op => 'drop_mail_from_moderation_queue', + $etc->('drop'), + }; + + return $spec; +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::SubscriberOnly::Moderate - moderate messages from non-subscribers + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('SubscribersOnly::Moderate')->new({ @@ -32,42 +165,15 @@ C<SubscribersOnly>|Sietima::Role::SubscriberOnly >>, L<< C<WithMailStore>|Sietima::Role::WithMailStore >>, and L<< C<WithOwner>|Sietima::Role::WithOwner >>. -=cut - -with 'Sietima::Role::SubscriberOnly', - 'Sietima::Role::WithMailStore', - 'Sietima::Role::WithOwner'; +=head1 METHODS -=method C<munge_mail_from_non_subscriber> +=head2 C<munge_mail_from_non_subscriber> L<Stores|Sietima::MailStore/store> the email with the C<moderation> tag, and forwards it to the L<list owner|Sietima::Role::WithOwner/owner>. -=cut - -sub munge_mail_from_non_subscriber ($self,$mail) { - my $id = $self->mail_store->store($mail,'moderation'); - my $notice = Email::Stuffer - ->from($self->return_path->address) - ->to($self->owner->address) - ->subject("Message held for moderation - ".$mail->header_str('subject')) - ->text_body("Use id $id to refer to it") - ->attach( - $mail->as_string, - content_type => 'message/rfc822', - # some clients, most notably Claws-Mail, seem to have - # problems with encodings other than this - encoding => '7bit', - ); - $self->transport->send($notice->email,{ - from => $self->return_path, - to => [ $self->owner ], - }); - return; -} - -=method C<resume> +=head2 C<resume> $sietima->resume($mail_id); @@ -77,30 +183,14 @@ C<ignoring_subscriberonly>|Sietima::Role::SubscriberOnly/ignoring_subscriberonly >>. This will make sure that the email is not caught again by the subscriber-only filter. -=cut - -sub resume ($self,$mail_id) { - my $mail = $self->mail_store->retrieve_by_id($mail_id); - $self->ignoring_subscriberonly( - sub($s) { $s->handle_mail($mail) }, - ); - $self->mail_store->remove($mail_id); -} - -=method C<drop> +=head2 C<drop> $sietima->drop($mail_id); Given an identifier returned when L<storing|Sietima::MailStore/store> an email, this method deletes the email from the store. -=cut - -sub drop ($self,$mail_id) { - $self->mail_store->remove($mail_id); -} - -=method C<list_mails_in_moderation_queue> +=head2 C<list_mails_in_moderation_queue> $sietima->list_mails_in_moderation_queue($sietima_runner); @@ -112,22 +202,7 @@ L<< C<Sietima::Runner> >> object. This method is usually invoked from the command line, see L<< /C<command_line_spec> >>. -=cut - -sub list_mails_in_moderation_queue ($self,$runner,@) { - my $mails = $self->mail_store->retrieve_by_tags('moderation'); - $runner->out(sprintf 'There are %d messages held for moderation:',scalar($mails->@*)); - for my $mail ($mails->@*) { - $runner->out(sprintf '* %s %s "%s" (%s)', - $mail->{id}, - $mail->{mail}->header_str('From')//'<no from>', - $mail->{mail}->header_str('Subject')//'<no subject>', - $mail->{mail}->header_str('Date')//'<no date>', - ); - } -} - -=method C<show_mail_from_moderation_queue> +=head2 C<show_mail_from_moderation_queue> $sietima->show_mail_from_moderation_queue($sietima_runner); @@ -138,16 +213,7 @@ out|App::Spec::Runner/out> via the L<< C<Sietima::Runner> >> object. This method is usually invoked from the command line, see L<< /C<command_line_spec> >>. -=cut - -sub show_mail_from_moderation_queue ($self,$runner,@) { - my $id = $runner->parameters->{'mail-id'}; - my $mail = $self->mail_store->retrieve_by_id($id); - $runner->out("Message $id:"); - $runner->out($mail->as_string =~ s{\r\n}{\n}gr); -} - -=method C<resume_mail_from_moderation_queue> +=head2 C<resume_mail_from_moderation_queue> $sietima->resume_mail_from_moderation_queue($sietima_runner); @@ -158,13 +224,7 @@ it. This method is usually invoked from the command line, see L<< /C<command_line_spec> >>. -=cut - -sub resume_mail_from_moderation_queue ($self,$runner,@) { - $self->resume($runner->parameters->{'mail-id'}); -} - -=method C<drop_mail_from_moderation_queue> +=head2 C<drop_mail_from_moderation_queue> $sietima->drop_mail_from_moderation_queue($sietima_runner); @@ -174,13 +234,9 @@ of the message requested from the command line, and L<drops|/drop> it. This method is usually invoked from the command line, see L<< /C<command_line_spec> >>. -=cut +=head1 MODIFIED METHODS -sub drop_mail_from_moderation_queue ($self,$runner,@) { - $self->drop($runner->parameters->{'mail-id'}); -} - -=modif C<command_line_spec> +=head2 C<command_line_spec> This method adds the following sub-commands for the command line: @@ -218,49 +274,15 @@ identifier is expected as a positional parameter. =back -=cut +=head1 AUTHOR -around command_line_spec => sub ($orig,$self) { - my $spec = $self->$orig(); +Gianni Ceccarelli <dakkar@thenautilus.net> - # this allows us to tab-complete identifiers from the shell! - my $list_mail_ids = sub ($self,$runner,$args) { - $self->mail_store->retrieve_ids_by_tags('moderation'); - }; - # a little factoring: $etc->($command_name) generates the spec for - # sub-commands that require a mail id - my $etc = sub($cmd) { - return ( - summary => "$cmd the given mail, currently held for moderation", - parameters => [ - { - name => 'mail-id', - required => 1, - summary => "id of the mail to $cmd", - completion => { op => $list_mail_ids }, - }, - ], - ); - }; +=head1 COPYRIGHT AND LICENSE - $spec->{subcommands}{'list-held'} = { - op => 'list_mails_in_moderation_queue', - summary => 'list all mails currently held for moderation', - }; - $spec->{subcommands}{'show-held'} = { - op => 'show_mail_from_moderation_queue', - $etc->('show'), - }; - $spec->{subcommands}{'resume-held'} = { - op => 'resume_mail_from_moderation_queue', - $etc->('resume'), - }; - $spec->{subcommands}{'drop-held'} = { - op => 'drop_mail_from_moderation_queue', - $etc->('drop'), - }; +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. - return $spec; -}; +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. -1; +=cut diff --git a/lib/Sietima/Role/WithMailStore.pm b/lib/Sietima/Role/WithMailStore.pm index 7ca4b4e..c0cf995 100644 --- a/lib/Sietima/Role/WithMailStore.pm +++ b/lib/Sietima/Role/WithMailStore.pm @@ -4,9 +4,33 @@ use Sietima::Policy; use Sietima::Types qw(MailStore MailStoreFromHashRef); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: role for lists with a store for messages + +has mail_store => ( + is => 'ro', + isa => MailStore, + required => 1, + coerce => MailStoreFromHashRef, +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::WithMailStore - role for lists with a store for messages + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('WithMailStore')->new({ @@ -25,7 +49,9 @@ On its own, this role is not very useful, but other roles (like L<< C<SubscriberOnly::Moderate>|Sietima::Role::SubscriberOnly::Moderate >>) can have uses for an object that can persistently store messages. -=attr C<mail_store> +=head1 ATTRIBUTES + +=head2 C<mail_store> Required instance of an object that consumes the L<< C<Sietima::MailStore> >> role. Instead of passing an instance, you can @@ -33,13 +59,15 @@ pass a hashref (like in the L</synopsis>): the C<class> key provides the class name, and the rest of the hash will be passed to its constructor. -=cut +=head1 AUTHOR -has mail_store => ( - is => 'ro', - isa => MailStore, - required => 1, - coerce => MailStoreFromHashRef, -); +Gianni Ceccarelli <dakkar@thenautilus.net> -1; +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/WithOwner.pm b/lib/Sietima/Role/WithOwner.pm index 1dfd362..1793381 100644 --- a/lib/Sietima/Role/WithOwner.pm +++ b/lib/Sietima/Role/WithOwner.pm @@ -4,9 +4,41 @@ use Sietima::Policy; use Sietima::Types qw(Address AddressFromStr); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: role for lists with an owner + +has owner => ( + is => 'ro', + isa => Address, + required => 1, + coerce => AddressFromStr, +); + + +around list_addresses => sub($orig,$self) { + return +{ + $self->$orig->%*, + owner => $self->owner, + }; +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::WithOwner - role for lists with an owner + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('WithOwner')->new({ @@ -23,31 +55,28 @@ On its own, this role is not very useful, but other roles (like L<< C<SubscriberOnly::Moderate>|Sietima::Role::SubscriberOnly::Moderate >>) can have uses for an owner address. -=attr C<owner> +=head1 ATTRIBUTES + +=head2 C<owner> Required instance of L<< C<Email::Address> >>, coercible from a string. This is the address of the owner of the list. -=cut - -has owner => ( - is => 'ro', - isa => Address, - required => 1, - coerce => AddressFromStr, -); +=head1 MODIFIED METHODS -=modif C<list_addresses> +=head2 C<list_addresses> This method declares the C<owner> address. -=cut +=head1 AUTHOR -around list_addresses => sub($orig,$self) { - return +{ - $self->$orig->%*, - owner => $self->owner, - }; -}; +Gianni Ceccarelli <dakkar@thenautilus.net> -1; +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Sietima/Role/WithPostAddress.pm b/lib/Sietima/Role/WithPostAddress.pm index 333c5e3..0e22e52 100644 --- a/lib/Sietima/Role/WithPostAddress.pm +++ b/lib/Sietima/Role/WithPostAddress.pm @@ -4,9 +4,40 @@ use Sietima::Policy; use Sietima::Types qw(Address AddressFromStr); use namespace::clean; -# VERSION +our $VERSION = '1.0.5'; # VERSION # ABSTRACT: role for lists with a posting address + +has post_address => ( + is => 'lazy', + isa => Address, + coerce => AddressFromStr, +); +sub _build_post_address($self) { $self->return_path } + +around list_addresses => sub($orig,$self) { + return +{ + $self->$orig->%*, + post => $self->post_address, + }; +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::WithPostAddress - role for lists with a posting address + +=head1 VERSION + +version 1.0.5 + =head1 SYNOPSIS my $sietima = Sietima->with_traits('WithPostAddress')->new({ @@ -24,26 +55,23 @@ On its own, this role is not very useful, but other roles (like L<< C<ReplyTo>|Sietima::Role::ReplyTo >>) can have uses for a post address. -=attr C<post_address> +=head1 ATTRIBUTES + +=head2 C<post_address> An L<< C<Email::Address> >> object, defaults to the value of the L<< C<return_path>|Sietima/return_path >> attribute. This is the address that the mailing list receives messages at. -=cut +=head1 AUTHOR -has post_address => ( - is => 'lazy', - isa => Address, - coerce => AddressFromStr, -); -sub _build_post_address($self) { $self->return_path } +Gianni Ceccarelli <dakkar@thenautilus.net> -around list_addresses => sub($orig,$self) { - return +{ - $self->$orig->%*, - post => $self->post_address, - }; -}; +=head1 COPYRIGHT AND LICENSE -1; +This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |