diff options
42 files changed, 3408 insertions, 4 deletions
diff --git a/.proverc b/.proverc new file mode 100644 index 0000000..ad83f73 --- /dev/null +++ b/.proverc @@ -0,0 +1,2 @@ +--lib +--recurse @@ -0,0 +1,21 @@ +# TODO + +* bugs! + * messy permissions, we should set some umask (we'd like + group-writable mailstore) + * `umask 0007;` and a `chmod -R g+s store` seem to work well + enough for my installation + * maybe auto-mkpath for `::MailStore::FS`? +* list footer + * append to plain text single part + * or add a plain text (or HTML?) part if multi-part + * how do we deal with signed messages? + * seems to be a hard problem: + http://www.ietf.org/mail-archive/web/ietf-smtp/current/msg01078.html + * there's this script + https://stuff.mit.edu/~jik/software/mailman_mimedefang/ + https://stuff.mit.edu/~jik/software/mailman_mimedefang/mailman_mimedefang_fix_footer.pl.txt + * I'll probably go the stupid / simple way: just append text to the + whole body, and MIME be damned +* qmail-compatible wrapper (to map exit codes) + - requires exceptions to be thrown by the various pieces diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..f869156 --- /dev/null +++ b/cpanfile @@ -0,0 +1,31 @@ +#!/usr/bin/env cpanm --installdeps +# -*- mode: perl -*- +requires 'perl','>= 5.024'; +requires 'App::Spec'; +requires 'Digest::SHA'; +requires 'Email::Address'; +requires 'Email::MIME'; +requires 'Email::Sender'; +requires 'Email::Sender::Simple'; +requires 'Email::Stuffer'; +requires 'experimental'; +requires 'List::AllUtils'; +requires 'Moo'; +requires 'Moo::Role'; +requires 'MooX::Traits'; +requires 'namespace::clean'; +requires 'Try::Tiny'; +requires 'Path::Tiny'; +requires 'Type::Library'; +requires 'Type::Params'; +requires 'Types::Path::Tiny'; +requires 'Types::Standard'; +requires 'Type::Utils'; + +on 'test' => sub { + requires 'Data::Printer'; + requires 'Email::Sender::Transport::Test'; + requires 'Import::Into'; + requires 'Test2::API'; + requires 'Test2::Bundle::Extended'; +}; @@ -1,7 +1,8 @@ +name = Sietima author = Gianni Ceccarelli <dakkar@thenautilus.net> license = Perl_5 copyright_holder = Gianni Ceccarelli <dakkar@thenautilus.net> -copyright_year = 2015 +copyright_year = 2017 [GatherDir] @@ -19,7 +20,7 @@ filename = weaver.ini allow_dirty = dist.ini [Git::NextVersion] -first_version = 0.0.1 +first_version = 1.0.0 [CheckChangeLog] @@ -78,5 +79,4 @@ tag_format = v%v%t-dzilla branch = release/master tag_format = v%v%t -[ConfirmRelease] -[UploadToCPAN] +[FakeRelease] diff --git a/example/sietima b/example/sietima new file mode 100755 index 0000000..3e9e294 --- /dev/null +++ b/example/sietima @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use FindBin::libs; +use Sietima::Policy; +use Sietima::CmdLine; + +Sietima::CmdLine->new({ + traits => [qw( + NoMail + ReplyTo + Headers + WithOwner + Debounce + SubjectTag + SubscriberOnly::Moderate + WithMailStore + )], + args => { + owner => 'dakkar@thenautilus.net', + mail_store => { + class => 'Sietima::MailStore::FS', + root => '/tmp/sietima-store', + }, + return_path => 'dakkar-sietima@thenautilus.net', + subject_tag => 'Test', + subscribers => [ + 'dakkar-a@thenautilus.net', + { primary => 'dakkar-b@thenautilus.net', aliases => [ 'dakkar-bis@thenautilus.net' ] }, + { primary => 'dakkar-c@thenautilus.net', prefs => { wants_mail => 0 } }, + ], + }, +})->run; diff --git a/lib/Sietima.pm b/lib/Sietima.pm new file mode 100644 index 0000000..6cdf404 --- /dev/null +++ b/lib/Sietima.pm @@ -0,0 +1,330 @@ +package Sietima; +use Moo; +use Sietima::Policy; +use Types::Standard qw(ArrayRef Object FileHandle Maybe); +use Type::Params qw(compile); +use Sietima::Types qw(Address AddressFromStr + EmailMIME Message + Subscriber SubscriberFromAddress SubscriberFromStr SubscriberFromHashRef + Transport); +use Sietima::Message; +use Sietima::Subscriber; +use Email::Sender::Simple qw(); +use Email::Sender; +use Email::Address; +use namespace::clean; + +with 'MooX::Traits'; + +=head1 NAME + +Sietima - minimal mailing list manager + +=head1 SYNOPSIS + + use Sietima; + + Sietima->new({ + return_path => 'the-list@the-domain.tld', + subscribers => [ 'person@some.were', @etc ], + })->handle_mail_from_stdin; + +=head1 DESCRIPTION + +Sietima is a minimal mailing list manager written in modern Perl. It +aims to be the spiritual successor of L<Siesta>. + +The base C<Sietima> class does very little: it just puts the email +message from C<STDIN> into a new envelope using L<< /C<return_path> >> +as sender and all the L<< /C<subscribers> >> addresses as recipients, +and sends it. + +Additional behaviour is provided via traits / roles. This class +consumes L<< C<MooX::Traits> >> to simplify composing roles: + + Sietima->with_traits(qw(AvoidDups NoMail))->new(\%args); + +These are the traits provided with the default distribution: + +=over + +=item L<< C<AvoidDups>|Sietima::Role::AvoidDups >> + +prevents the sender from receiving copies of their own messages + +=item L<< C<Debounce>|Sietima::Role::Debounce >> + +avoids mail-loops using a C<X-Been-There> header + +=item L<< C<Headers>|Sietima::Role::Headers >> + +adds C<List-*> headers to all outgoing messages + +=item L<< C<NoMail>|Sietima::Role::NoMail >> + +avoids sending messages to subscribers who don't want them + +=item L<< C<ReplyTo>|Sietima::Role::ReplyTo >> + +optionally sets the C<Reply-To> header to the mailing list address + +=item L<< C<SubjectTag>|Sietima::Role::SubjectTag >> + +prepends a C<[tag]> to the subject header of outgoing messages that +aren't already tagged + +=item L<< C<SubscriberOnly::Drop>|Sietima::Role::SubscriberOnly::Drop >> + +silently drops all messages coming from addresses not subscribed to +the list + +=item L<< C<SubscriberOnly::Moderate>|Sietima::Role::SubscriberOnly::Moderate >> + +holds messages coming from addresses not subscribed to the list for +moderation, and provides commands to manage the moderation queue + +=back + +The only "configuration mechanism" currently supported is to +initialise a C<Sietima> object in your driver script, passing all the +needed values to the constructor. L<< C<Sietima::CmdLine> >> is the +recommended way of doing that: it adds command-line parsing capability +to Sietima. + +=head1 ATTRIBUTES + +=head2 C<return_path> + +A L<< C<Email::Address> >> instance, coerced from string if +necessary. This is the address that Sietima will send messages +I<from>. + +=cut + +has return_path => ( + isa => Address, + is => 'ro', + required => 1, + coerce => AddressFromStr, +); + +=head2 C<subscribers> + +An array-ref of L<< C<Sietima::Subscriber> >> objects, defaults to the +empty array. + +Each item can be coerced from a string or a L<< C<Email::Address> >> +instance, or a hashref of the form + + { address => $string, %other_attributes } + +The base Sietima class only uses the address of subscribers, but some +roles use the other attributes (L<< C<NoMail>|Sietima::Role::NoMail +>>, for example, uses the C<prefs> attribute, and L<< +C<SubscriberOnly> >> uses C<aliases> via L<< +C<match>|Sietima::Subscriber/match >>) + +=cut + +my $subscribers_array = ArrayRef[ + Subscriber->plus_coercions( + SubscriberFromAddress, + SubscriberFromStr, + SubscriberFromHashRef, + ) +]; +has subscribers => ( + isa => $subscribers_array, + is => 'lazy', + coerce => $subscribers_array->coercion, +); +sub _build_subscribers { +[] } + +=head2 C<transport> + +A L<< C<Email::Sender::Transport> >> instance, which will be used to +send messages. If not passed in, Sietima uses L<< +C<Email::Sender::Simple> >>'s L<< +C<default_transport>|Email::Sender::Simple/default_transport >>. + +=cut + +has transport => ( + isa => Transport, + is => 'lazy', +); +sub _build_transport { Email::Sender::Simple->default_transport } + +=head1 METHODS + +=head2 C<handle_mail_from_stdin> + + $sietima->handle_mail_from_stdin(); + +This is the main entry-point when Sietima is invoked from a MTA. It +will parse a L<< C<Email::MIME> >> object out of the standard input, +then pass it to L<< /C<handle_mail> >> for processing. + +=cut + +sub handle_mail_from_stdin($self,@) { + my $mail_text = do { local $/; <> }; + # we're hoping that, since we probably got called from an MTA/MDA, + # STDIN contains a well-formed email message, addressed to us + my $incoming_mail = Email::MIME->new(\$mail_text); + return $self->handle_mail($incoming_mail); +} + +=head2 C<handle_mail> + + $sietima->handle_mail($email_mime); + +Main driver method: converts the given email message into a list of +L<< C<Sietima::Message> >> objects by calling L<< /C<munge_mail> >>, +then sends each of them by calling L<< /C<send_message> >>. + +=cut + +sub handle_mail($self,$incoming_mail) { + state $check = compile(Object,EmailMIME); $check->(@_); + + my (@outgoing_messages) = $self->munge_mail($incoming_mail); + for my $outgoing_message (@outgoing_messages) { + $self->send_message($outgoing_message); + } + return; +} + +=head2 C<subscribers_to_send_to> + + my $subscribers_aref = $sietima->subscribers_to_send_to($email_mime); + +Returns an array-ref of L<< C<Sietima::Subscriber> >> objects that +should receive copies of the given email message. + +In this base class, it just returns the value of the L<< +/C<subscribers> >> attribute. Roles such as L<< +C<AvoidDups>|Sietima::Role::AvoidDups >> modify this method to exclude +some subscribers. + +=cut + +sub subscribers_to_send_to($self,$incoming_mail) { + state $check = compile(Object,EmailMIME); $check->(@_); + + return $self->subscribers; +} + +=head2 C<munge_mail> + + my @messages = $sietima->munge_mail($email_mime); + +Returns a list of L<< C<Sietima::Message> >> objects representing the +messages to send to subscribers, based on the given email message. + +In this base class, this method returns a single instance to send to +all L<< /C<subscribers_to_send_to> >>, containing exactly the given +email message. + +Roles such as L<< C<SubjectTag>|Sietima::Role::SubjectTag >> modify +this method to alter the message. + +=cut + +sub munge_mail($self,$incoming_mail) { + state $check = compile(Object,EmailMIME); $check->(@_); + + return Sietima::Message->new({ + mail => $incoming_mail, + from => $self->return_path, + to => $self->subscribers_to_send_to($incoming_mail), + }); +} + +=head2 C<send_message> + + $sietima->send_message($sietima_message); + +Sends the given L<< C<Sietima::Message> >> object via the L<< +/C<transport> >>, but only if the message's +L<envelope|Sietima::Message/envelope> specifies some recipients. + +=cut + +sub send_message($self,$outgoing_message) { + state $check = compile(Object,Message); $check->(@_); + + my $envelope = $outgoing_message->envelope; + if ($envelope->{to} && $envelope->{to}->@*) { + $self->transport->send( + $outgoing_message->mail, + $envelope, + ); + } + + return; +} + +sub _trait_namespace { 'Sietima::Role' } + +=head2 C<list_addresses> + + my $addresses_href = $sietima->list_addresses; + +Returns a hashref of L<< C<Email::Address> >> instances or strings, +that declare various addresses related to this list. + +This base class declares only the L<< /C<return_path> >>, and does not +use this method at all. + +The L<< C<Headers>|Sietima::Role::Headers >> role uses this to +populate the various C<List-*> headers. + +=cut + +sub list_addresses($self) { + return +{ + return_path => $self->return_path, + }; +} + +=head2 C<command_line_spec> + + my $app_spec_data = $sietima->command_line_spec; + +Returns a hashref describing the command line processing for L<< +C<App::Spec> >>. L<< C<Sietima::CmdLine> >> uses this to build the +command line parser. + +This base class declares a single sub-command: + +=over + +=item C<send> + +Invokes the L<< /C<handle_mail_from_stdin> >> method. + +For example, in a C<.qmail> file: + + |/path/to/sietima send + +=back + +Roles can extend this to provide additional sub-commands and options. + +=cut + +sub command_line_spec($self) { + return { + name => 'sietima', + title => 'a simple mailing list manager', + subcommands => { + send => { + op => 'handle_mail_from_stdin', + summary => 'send email from STDIN', + }, + }, + }; +} + +1; diff --git a/lib/Sietima/CmdLine.pm b/lib/Sietima/CmdLine.pm new file mode 100644 index 0000000..ee054d5 --- /dev/null +++ b/lib/Sietima/CmdLine.pm @@ -0,0 +1,150 @@ +package Sietima::CmdLine; +use Moo; +use Sietima::Policy; +use Sietima::Types qw(SietimaObj); +use Types::Standard qw(HashRef); +use Sietima; +use App::Spec; +use Sietima::Runner; +use namespace::clean; + +=head1 NAME + +Sietima::CmdLine - run Sietima as a command-line application + +=head1 SYNOPSIS + + use Sietima::CmdLine; + + Sietima::CmdLine->new({ + traits => [qw(SubjectTag)], + args => { + return_path => 'list@example.net', + subject_tag => 'Test', + subscribers => \@addresses, + })->run; + +=head1 DESCRIPTION + +This class simplifies the creation of a L<< C<Sietima> >> object, and +uses L<< C<App::Spec> >> to provide a command-line interface to it. + +=head1 ATTRIBUTES + +=head2 C<sietima> + +Required, an instance of L<< C<Sietima> >>. You can either construct +it yourself, or use the L<simplified building provided by the +constructor|/new>. + +=cut + +has sietima => ( + is => 'ro', + required => 1, + isa => SietimaObj, +); + +=head2 C<extra_spec> + +Optional hashref. Used inside L<< /C<app_spec> >>. If you're not +familiar with L<< C<App::Spec> >>, you probably don't want to touch +this. + +=cut + +has extra_spec => ( + is => 'ro', + isa => HashRef, + default => sub { +{} }, +); + +=head1 METHODS + +=head2 C<new> + + my $cmdline = Sietima::CmdLine->new({ + sietima => Sietima->with_traits(qw(SubjectTag))->new({ + return_path => 'list@example.net', + subject_tag => 'Test', + subscribers => \@addresses, + }), + }); + + my $cmdline = Sietima::CmdLine->new({ + traits => [qw(SubjectTag)], + args => { + return_path => 'list@example.net', + subject_tag => 'Test', + subscribers => \@addresses, + }); + +The constructor. In alternative to passing a L<< C<Sietima> >> +instance, you can pass C<traits> and C<args>, and the instance will be +built for you. The two calls above are equivalent. + +=cut + +sub BUILDARGS($class,@args) { + my $args = $class->next::method(@args); + $args->{sietima} //= do { + my $traits = delete $args->{traits} // []; + my $constructor_args = delete $args->{args} // {}; + Sietima->with_traits($traits->@*)->new($constructor_args); + }; + return $args; +} + +=head2 C<app_spec> + +Returns an instance of L<< C<App::Spec> >>, built from the +specification returned by calling L<< +C<command_line_spec>|Sietima/command_line_spec >> on the L<< +/C<sietima> >> object, modified by the L<< /C<extra_spec> >>. This +method, and the C<extra_spec> attribute, are probably only interesting +to people who are doing weird extensions. + +=cut + +has app_spec => ( + is => 'lazy', + init_arg => undef, +); + +sub _build_app_spec($self) { + my $spec_data = $self->sietima->command_line_spec(); + + return App::Spec->read({ + $spec_data->%*, + $self->extra_spec->%*, + }); +} + +=head2 C<runner> + +Returns an instance of L<< C<Sietima::Runner> >>, built from the L<< +/C<app_spec> >>. + +=head2 C<run> + +Delegates to the L<< /C<runner> >>'s L<< C<run>|App::Spec::Run/run >> method. + +Parser the command line arguments from C<@ARGV> and executes the +appropriate action. + +=cut + +has runner => ( + is => 'lazy', + init_arg => undef, + handles => [qw(run)], +); + +sub _build_runner($self) { + return Sietima::Runner->new({ + spec => $self->app_spec, + cmd => $self->sietima, + }); +} + +1; diff --git a/lib/Sietima/MailStore.pm b/lib/Sietima/MailStore.pm new file mode 100644 index 0000000..5e9aa82 --- /dev/null +++ b/lib/Sietima/MailStore.pm @@ -0,0 +1,98 @@ +package Sietima::MailStore; +use Moo::Role; +use Sietima::Policy; +use namespace::clean; + +=head1 NAME + +Sietima::MailStore - interface for mail stores + +=head1 DESCRPITON + +This role defines the interface that all mail stores must adhere +to. It does not provide any implementation. + +=head1 REQUIRED METHODS + +=head2 C<store> + + my $id = $ms->store($email_mime_object,@tags); + +Must persistently store the given email message (as an L<< +C<Email::Simple>> object or similar), associating it with the gives +tags (which must be strings). Must returns a unique identifier for the +stored message. It is acceptable if identical messages are +indistinguishable by the storage. + +=head2 C<retrieve_by_id> + + my $email_mime_object = $ms->retrieve_by_id($id); + +Given an identifier returned by L<< /C<store> >>, this method must +return the email message (as an L<< C<Email::Simple> >> or L<< +C<Email::MIME> >> object). + +If the message has been deleted, or the identifier is not recognised, +this method must return C<undef> in scalar context. + +=head2 C<retrieve_ids_by_tags> + + my @ids = $ms->retrieve_ids_by_tags(@tags)->@*; + +Given a list of tags (which must be strings), this method must return +an arrayref containing the identifiers of all (and only) the messages +that were stored associated with (at least) all those tags. The order +of the returned identifiers is not important. + +If there are no messages associated with the given tags, this method +must return an empty arrayref. + +For example: + + my $id1 = $ms->store($msg1,'t1'); + my $id2 = $ms->store($msg2,'t2'); + my $id3 = $ms->store($msg3,'t1','t2'); + + $ms->retrieve_ids_by_tags('t1') ==> [ $id3, $id1 ] + $ms->retrieve_ids_by_tags('t2') ==> [ $id2, $id3 ] + $ms->retrieve_ids_by_tags('t1','t2') ==> [ $id3 ] + $ms->retrieve_ids_by_tags('t3') ==> [ ] + +=head2 C<retrieve_by_tags> + + my @email_mime_objects = $ms->retrieve_by_tags(@tags)->@*; + +This method is similar to L<< /C<retrieve_ids_by_tags> >>, but it must +return an arrayref of hashrefs. For example: + + my $id1 = $ms->store($msg1,'t1'); + my $id2 = $ms->store($msg2,'t2'); + my $id3 = $ms->store($msg3,'t1','t2'); + + $ms->retrieve_ids_by_tags('t1') ==> [ + { id => $id3, mail => $msg3 }, + { id => $id1, mail => $msg1 }, + ] + +=head2 C<remove> + + $ms->remove($id); + +This method must remove the message corresponding to the given +identifier from the persistent storage. Removing a non-existent +message must succeed, and do nothing. + +=head2 C<clear> + + $ms->clear(); + +This method must remove all messages from the persistent +storage. Clearing a empty store must succeed, and do nothing. + +=cut + +requires 'store', + 'retrieve_ids_by_tags','retrieve_by_tags','retrieve_by_id', + 'remove','clear'; + +1; diff --git a/lib/Sietima/MailStore/FS.pm b/lib/Sietima/MailStore/FS.pm new file mode 100644 index 0000000..e4dfc4d --- /dev/null +++ b/lib/Sietima/MailStore/FS.pm @@ -0,0 +1,107 @@ +package Sietima::MailStore::FS; +use Moo; +use Sietima::Policy; +use Types::Path::Tiny qw(Dir); +use Types::Standard qw(Object ArrayRef Str slurpy); +use Type::Params qw(compile); +use Sietima::Types qw(EmailMIME TagName); +use Digest::SHA qw(sha1_hex); +use namespace::clean; + +with 'Sietima::MailStore'; + +has root => ( + is => 'ro', + required => 1, + isa => Dir, + coerce => 1, +); + +has [qw(_tagdir _msgdir)] => ( is => 'lazy' ); +sub _build__tagdir($self) { $self->root->child('tags') } +sub _build__msgdir($self) { $self->root->child('msgs') } + +sub BUILD($self,@) { + $self->$_->mkpath for qw(_tagdir _msgdir); + return; +} + +sub clear($self) { + do { $self->$_->remove_tree;$self->$_->mkpath } for qw(_tagdir _msgdir); + return; +} + +sub store($self,$mail,@tags) { + state $check = compile(Object,EmailMIME,slurpy ArrayRef[TagName]);$check->(@_); + + my $str = $mail->as_string; + my $id = sha1_hex($str); + + $self->_msgdir->child($id)->spew_raw($str); + + $self->_tagdir->child($_)->append("$id\n") for @tags; + + return $id; +} + +sub retrieve_by_id($self,$id) { + state $check = compile(Object,Str);$check->(@_); + + my $msg_path = $self->_msgdir->child($id); + return unless -e $msg_path; + return Email::MIME->new($msg_path->slurp_raw); +} + +sub _tagged_by($self,$tag) { + my $tag_file = $self->_tagdir->child($tag); + return unless -e $tag_file; + return $tag_file->lines({chomp=>1}); +} + +sub retrieve_ids_by_tags($self,@tags) { + state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_); + + my %msgs; + if (@tags) { + for my $tag (@tags) { + $_++ for @msgs{$self->_tagged_by($tag)}; + } + } + else { + $msgs{$_->basename}=0 for $self->_msgdir->children; + } + + my @ret; + for my $id (keys %msgs) { + next unless $msgs{$id} == @tags; + push @ret, $id; + } + return \@ret; +} + +sub retrieve_by_tags($self,@tags) { + state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_); + + my @ret; + for my $id ($self->retrieve_ids_by_tags(@tags)->@*) { + push @ret, { + id => $id, + mail => $self->retrieve_by_id($id), + }; + } + + return \@ret; +} + +sub remove($self,$id) { + state $check = compile(Object,Str);$check->(@_); + + for my $tag_file ($self->_tagdir->children) { + $tag_file->edit_lines( sub { $_='' if /\A\Q$id\E\n?\z/ } ); + } + $self->_msgdir->child($id)->remove; + + return; +} + +1; diff --git a/lib/Sietima/Message.pm b/lib/Sietima/Message.pm new file mode 100644 index 0000000..181575f --- /dev/null +++ b/lib/Sietima/Message.pm @@ -0,0 +1,103 @@ +package Sietima::Message; +use Moo; +use Sietima::Policy; +use Types::Standard qw(ArrayRef Object); +use Sietima::Types qw(Address AddressFromStr + Subscriber SubscriberFromAddress SubscriberFromStr + EmailMIME); +use Email::Address; +use Sietima::Subscriber; +use Email::MIME; +use namespace::clean; + +=head1 NAME + +Sietima::Message - an email message with an envelope + +=head1 SYNOPSIS + + use Sietima::Message; + + my $msg = Sietima::Message->new({ + mail => $email_mime_object, + from => 'sender@example.com', + to => [ 'recipient@example.com', 'also@example.com' ], + }); + +=head1 DESCRPITON + +This class pairs a L<< C<Email::MIME> >> object with its +envelope. Objects of this class are usually generated by L<< +C<Sietima::munge_mail>|Sietima/munge_mail >>, and consumed by L<< +C<Sietima::send_message>|Sietima/send_message >>. + +=head1 ATTRIBUTES + +All attributes are read-only and required. + +=head2 C<mail> + +An L<< C<Email::MIME> >> object, representing the message. + +=cut + +has mail => ( + is => 'ro', + isa => EmailMIME, + required => 1, +); + +=head2 C<from> + +An L<< C<Email::Address> >> object, coercible from a string, +representing the sender. + +=cut + +has from => ( + is => 'ro', + isa => Address, + coerce => AddressFromStr, + required => 1, +); + +=head2 C<to> + +An arrayref of L<< C<Sietima::Subscriber> >> objects, each coercible +from a string or an L<< C<Email::Address> >> object, representing the +recipients. + +=cut + +my $subscriber_array = ArrayRef[ + Subscriber->plus_coercions( + SubscriberFromStr, + SubscriberFromAddress, + ) +]; +has to => ( + isa => $subscriber_array, + is => 'ro', + coerce => $subscriber_array->coercion, + required => 1, +); + +=head1 METHODS + +=head2 C<envelope> + + my %envelope = $message->envelope->%*; + +Returns a hashref with envelope data, suitable for use with L<< +C<Email::Sender::Transport::send>|Email::Sender::Transport/send >>. + +=cut + +sub envelope ($self) { + return { + from => $self->from, + to => [ map { $_->address } $self->to->@* ], + } +} + +1; diff --git a/lib/Sietima/Policy.pm b/lib/Sietima/Policy.pm new file mode 100644 index 0000000..686a4cd --- /dev/null +++ b/lib/Sietima/Policy.pm @@ -0,0 +1,41 @@ +package Sietima::Policy; +use 5.024; +use strict; +use warnings; +use feature ':5.24'; +use experimental 'signatures'; + +=head1 NAME + +Sietima::Policy - pragma for Sietima modules + +=head1 SYNOPSIS + + use 5.024; + use strict; + use warnings; + use feature ':5.24'; + use experimental 'signatures'; + +or just: + + use Sietima::Policy; + +=head1 DESCRPITON + +This module imports the pragmas shown in the L</synopsis>. All Sietima +modules use it. + +=cut + +sub import { + # These affect the currently compiling scope, + # so no need for import::into + strict->import; + warnings->import; + experimental->import('signatures'); + feature->import(':5.24'); + return; +} + +1; diff --git a/lib/Sietima/Role/AvoidDups.pm b/lib/Sietima/Role/AvoidDups.pm new file mode 100644 index 0000000..ac633c0 --- /dev/null +++ b/lib/Sietima/Role/AvoidDups.pm @@ -0,0 +1,48 @@ +package Sietima::Role::AvoidDups; +use Moo::Role; +use Sietima::Policy; +use Email::Address; +use namespace::clean; + +=head1 NAME + +Sietima::Role::AvoidDups - 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. + +=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. + +=cut + +around subscribers_to_send_to => sub ($orig,$self,$mail) { + my @already_receiving = map { + Email::Address->parse($_) + } $mail->header_str('to'),$mail->header_str('cc'); + + my %already_receiving = map { + $_->address => 1 + } @already_receiving; + + return [ + grep { + not $already_receiving{$_->address} + } + $self->$orig($mail)->@*, + ]; +}; + +1; diff --git a/lib/Sietima/Role/Debounce.pm b/lib/Sietima/Role/Debounce.pm new file mode 100644 index 0000000..39ef936 --- /dev/null +++ b/lib/Sietima/Role/Debounce.pm @@ -0,0 +1,48 @@ +package Sietima::Role::Debounce; +use Moo::Role; +use Sietima::Policy; +use namespace::clean; + +=head1 NAME + +Sietima::Role::Debounce - avoid mail loops + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('Debounce')->new(\%args); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will mark each message +with a C<X-Been-There:> header, and will not handle any messages that +have that same header. This prevents messages bounced by other +services from being looped between the mailing list and those other +services. + +=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 + +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; diff --git a/lib/Sietima/Role/Headers.pm b/lib/Sietima/Role/Headers.pm new file mode 100644 index 0000000..166b355 --- /dev/null +++ b/lib/Sietima/Role/Headers.pm @@ -0,0 +1,107 @@ +package Sietima::Role::Headers; +use Moo::Role; +use Try::Tiny; +use Sietima::Policy; +use Types::Standard qw(Str); +use namespace::clean; + +=head1 NAME + +Sietima::Role::Headers - 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. Those values can either be L<< +C<Email::Address> >> objects (in which case the header will have a +C<mailto:> URI as value) or strings (which will be used literally for +the value of the header). + +=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). + +=cut + +has name => ( + isa => Str, + is => 'ro', + required => 0, +); + +sub _add_headers_to($self,$message) { + my $addresses = $self->list_addresses; + my $mail = $message->mail; + + # see RFC 2919 "List-Id: A Structured Field and Namespace for the + # Identification of Mailing Lists" + my $return_path = delete $addresses->{return_path}; + if (my $name = $self->name) { + $mail->header_str_set( + 'List-Id', + sprintf '%s <%s>', $name,$return_path->address =~ s{\@}{.}r, + ); + } + + # if nobody declared a "post" address, let's guess it's the same + # as the address we send from + $addresses->{post} //= $return_path; + + for my $name (sort keys $addresses->%*) { + my $header_name = 'List-' . ucfirst($name =~ s{[^[:alnum:]]+}{-}gr); + my $address = $addresses->{$name}; + + # if it's not an Email::Address obect, we'll just take it as a + # string: it could be a non-mailto URI, see RFC 2369 "The Use + # of URLs as Meta-Syntax for Core Mail List Commands and their + # Transport through Message Header Fields" + + $mail->header_str_set( + $header_name => try { + sprintf '<mailto:%s>',$address->address + } catch { "$address" }, + ); + } + return; +} + +=head1 MODIFIED METHODS + +=head2 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); + $self->_add_headers_to($_) for @messages; + return @messages; +}; + +1; diff --git a/lib/Sietima/Role/NoMail.pm b/lib/Sietima/Role/NoMail.pm new file mode 100644 index 0000000..7db58da --- /dev/null +++ b/lib/Sietima/Role/NoMail.pm @@ -0,0 +1,42 @@ +package Sietima::Role::NoMail; +use Moo::Role; +use Sietima::Policy; +use namespace::clean; + +=head1 NAME + +Sietima::Role::NoMail - don't send mail to those who don't want it + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('NoMail')->new({ + %args, + subscribers => [ + { primary => 'write-only@example.com', prefs => { wants_mail => 0 } }, + @other_subscribers, + ], + }); + +=head1 DESCRIPTION + +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. + +=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 + +around subscribers_to_send_to => sub ($orig,$self,$mail) { + return [ + grep { $_->prefs->{wants_mail} // 1 } + $self->$orig($mail)->@*, + ]; +}; + +1; diff --git a/lib/Sietima/Role/ReplyTo.pm b/lib/Sietima/Role/ReplyTo.pm new file mode 100644 index 0000000..c9de1a4 --- /dev/null +++ b/lib/Sietima/Role/ReplyTo.pm @@ -0,0 +1,127 @@ +package Sietima::Role::ReplyTo; +use Moo::Role; +use Sietima::Policy; +use Types::Standard qw(Bool); +use Sietima::Types qw(Address AddressFromStr); +use List::AllUtils qw(part); +use namespace::clean; + +=head1 NAME + +Sietima::Role::ReplyTo - munge the C<Reply-To> header + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('ReplyTo')->new({ + %args, + return_path => 'list-bounce@example.com', + munge_reply_to => 1, + post_address => 'list@example.com', + subscribers => [ + { primary => 'special@example.com', prefs => { munge_reply_to => 0 } }, + @other_subscribers, + ], + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will, on request, set +the C<Reply-To:> header to the value of the L<< +C<post_address>|Sietima::Role::WithPostAddress >> attribute. + +This behaviour can be selected both at the list level (with the L<< +/C<munge_reply_to> >> attribute) and at the subscriber level (with the +C<munge_reply_to> preference). By default, the C<Reply-To:> header is +not touched. + +This is a "sub-role" of L<< +C<WithPostAddress>|Sietima::Role::WithPostAddress >>. + +=cut + +with 'Sietima::Role::WithPostAddress'; + +=head1 ATTRIBUTES + +=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 + +=head2 C<munge_mail> + +For each message returned by the original method, this method +partitions the subscribers, who are recipients of the message, +according to their C<munge_reply_to> preference (or the L<< +/C<munge_reply_to> >> attribute, if a subscriber does not have the +preference set). + +If no recipients want the C<Reply-To:> header modified, this method +will just pass the message through. + +If all recipients want the C<Reply-To:> header modified, this method +will set the header, and pass the modified message. + +If some recipients want the C<Reply-To:> header modified, and some +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 + +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; diff --git a/lib/Sietima/Role/SubjectTag.pm b/lib/Sietima/Role/SubjectTag.pm new file mode 100644 index 0000000..75170d7 --- /dev/null +++ b/lib/Sietima/Role/SubjectTag.pm @@ -0,0 +1,64 @@ +package Sietima::Role::SubjectTag; +use Moo::Role; +use Sietima::Policy; +use Types::Standard qw(Str); +use namespace::clean; + +=head1 NAME + +Sietima::Role::SubjectTag - add a tag to messages' subjects + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('SubjectTag')->new({ + %args, + subject_tag => 'foo', + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will prepend the given +tag to every outgoing message's C<Subject:> header. + +=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, +the code in the L</synopsis> would cause an incoming message with +subject "new stuff" to be sent out with subject "[foo] new stuff". + +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 + +has subject_tag => ( + is => 'ro', + isa => Str, + required => 1, +); + +=head1 MODIFIED METHODS + +=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 + +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; diff --git a/lib/Sietima/Role/SubscriberOnly.pm b/lib/Sietima/Role/SubscriberOnly.pm new file mode 100644 index 0000000..ff93076 --- /dev/null +++ b/lib/Sietima/Role/SubscriberOnly.pm @@ -0,0 +1,96 @@ +package Sietima::Role::SubscriberOnly; +use Moo::Role; +use Sietima::Policy; +use Email::Address; +use List::AllUtils qw(any); +use Types::Standard qw(Object CodeRef); +use Type::Params qw(compile); +use namespace::clean; + +=head1 NAME + +Sietima::Role::SubscriberOnly - base role for "closed" lists + +=head1 SYNOPSIS + + package Sietima::Role::SubscriberOnly::MyPolicy; + use Moo::Role; + use Sietima::Policy; + + sub munge_mail_from_non_subscriber($self,$mail) { ... } + +=head1 DESCRIPTION + +This is a base role; in other words, it's not useable directly. + +This role should be used when defining policies for "closed" lists: +lists that accept messages from subscribers, but do something special +with messages from non-subscribers. + +See L<< C<Sietima::Role::SubscriberOnly::Drop> >> and L<< +C<Sietima::Role::SubscriberOnly::Moderate> >> for useable roles. + +=head1 REQUIRED METHODS + +=head2 C<munge_mail_from_non_subscriber> + + sub munge_mail_from_non_subscriber($self,$mail) { ... } + +This method will be invoked from L<< C<munge_mail>|Sietima/munge_mail +>> whenever an email is processed that does not come from one of the +list's subscribers. This method should return a (possibly empty) list +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 + +requires 'munge_mail_from_non_subscriber'; + +our $let_it_pass=0; + +=head1 MODIFIED METHODS + +=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 + +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); + } +}; + +=head1 METHODS + +=head2 C<ignoring_subscriberonly> + + $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. + +=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 new file mode 100644 index 0000000..029889f --- /dev/null +++ b/lib/Sietima/Role/SubscriberOnly/Drop.pm @@ -0,0 +1,39 @@ +package Sietima::Role::SubscriberOnly::Drop; +use Moo::Role; +use Sietima::Policy; +use namespace::clean; + +=head1 NAME + +Sietima::Role::SubscriberOnly::Drop - drop messages from non-subscribers + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('SubscribersOnly::Drop')->new({ + %args, + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will silently discard +every incoming email that does not come from one of the list's +subscribers. + +This is a "sub-role" of L<< +C<SubscribersOnly>|Sietima::Role::SubscriberOnly >>. + +=cut + +with 'Sietima::Role::SubscriberOnly'; + +=head1 METHODS + +=head2 C<munge_mail_from_non_subscriber> + +Does nothing, returns an empty list. + +=cut + +sub munge_mail_from_non_subscriber { } + +1; diff --git a/lib/Sietima/Role/SubscriberOnly/Moderate.pm b/lib/Sietima/Role/SubscriberOnly/Moderate.pm new file mode 100644 index 0000000..750e4be --- /dev/null +++ b/lib/Sietima/Role/SubscriberOnly/Moderate.pm @@ -0,0 +1,242 @@ +package Sietima::Role::SubscriberOnly::Moderate; +use Moo::Role; +use Sietima::Policy; +use Email::Stuffer; +use Email::MIME; +use namespace::clean; + +=head1 NAME + +Sietima::Role::SubscriberOnly::Moderate - moderate messages from non-subscribers + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('SubscribersOnly::Moderate')->new({ + %args, + owner => 'listmaster@example.com', + mail_store => { + class => 'Sietima::MailStore::FS', + root => '/tmp', + }, + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will accept incoming +emails coming from non-subscribers, and store it for moderation. Each +such email will be forwarded (as an attachment) to the list's owner. + +The owner will the be able to delete the message, or allow it. + +This is a "sub-role" of L<< +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 + +=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; +} + +=head2 C<resume> + + $sietima->resume($mail_id); + +Given an identifier returned when L<storing|Sietima::MailStore/store> +an email, this method retrieves the email and re-processes it via L<< +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); +} + +=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); +} + +=head2 C<list_mails_in_moderation_queue> + + $sietima->list_mails_in_moderation_queue($sietima_runner); + +This method L<retrieves all the +identifiers|Sietima::MailStore/retrieve_by_tags> of messages tagged +C<moderation>, and L<prints them 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 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>', + ); + } +} + +=head2 C<show_mail_from_moderation_queue> + + $sietima->show_mail_from_moderation_queue($sietima_runner); + +This method L<retrieves the email|Sietima::MailStore/retrieve_by_id> +of the message requested from the command line, and L<prints it +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); +} + +=head1 MODIFIED METHODS + +=head2 C<command_line_spec> + +This method adds the following sub-commands for the command line: + +=over + +=item C<list-held> + + $ sietima list-held + +Invokes the L<< /C<list_mails_in_moderation_queue> >> method, printing +the identifiers of all messages held for moderation. + +=item C<show-held> + + $ sietima show-held 32946p6eu7867 + +Invokes the L<< /C<show_mail_from_moderation_queue> >> method, +printing one message held for moderation; the identifier is expected +as a positional parameter. + +=item C<resume-held> + + $ sietima resume-held 32946p6eu7867 + +Invokes the L<< /C<resume> >> method, causing the held message to be +processed normally; the identifier is expected as a positional +parameter. + +=item C<drop-held> + + $ sietima drop-held 32946p6eu7867 + +Invokes the L<< /C<drop> >> method, removing the held message; the +identifier is expected as a positional parameter. + +=back + +=cut + +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 => sub ($self,$runner,$args) { + $self->resume($runner->parameters->{'mail-id'}); + }, + $etc->('resume'), + }; + $spec->{subcommands}{'drop-held'} = { + op => sub ($self,$runner,$args) { + $self->drop($runner->parameters->{'mail-id'}); + }, + $etc->('drop'), + }; + + return $spec; +}; + +1; diff --git a/lib/Sietima/Role/WithMailStore.pm b/lib/Sietima/Role/WithMailStore.pm new file mode 100644 index 0000000..a2ae07c --- /dev/null +++ b/lib/Sietima/Role/WithMailStore.pm @@ -0,0 +1,48 @@ +package Sietima::Role::WithMailStore; +use Moo::Role; +use Sietima::Policy; +use Sietima::Types qw(MailStore MailStoreFromHashRef); +use namespace::clean; + +=head1 NAME + +Sietima::Role::WithMailStore - role for lists with a store for messages + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('WithMailStore')->new({ + %args, + mail_store => { + class => 'Sietima::MailStore::FS', + root => '/tmp', + }, + }); + +=head1 DESCRIPTION + +This role adds a L<< /C<mail_store> >> attribute. + +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. + +=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 +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 + +has mail_store => ( + is => 'ro', + isa => MailStore, + required => 1, + coerce => MailStoreFromHashRef, +); + +1; diff --git a/lib/Sietima/Role/WithOwner.pm b/lib/Sietima/Role/WithOwner.pm new file mode 100644 index 0000000..dccb904 --- /dev/null +++ b/lib/Sietima/Role/WithOwner.pm @@ -0,0 +1,50 @@ +package Sietima::Role::WithOwner; +use Moo::Role; +use Sietima::Policy; +use Sietima::Types qw(Address AddressFromStr); +use namespace::clean; + +=head1 NAME + +Sietima::Role::WithOwner - role for lists with an owner + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('WithOwner')->new({ + %args, + owner => 'listmaster@example.com', + }); + +=head1 DESCRIPTION + +This role adds an L<< /C<owner> >> attribute, and exposes it via the +L<< C<list_addresses>|Sietima/list_addresses >> method. + +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. + +=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, +); + +around list_addresses => sub($orig,$self) { + return +{ + $self->$orig->%*, + owner => $self->owner, + }; +}; + +1; diff --git a/lib/Sietima/Role/WithPostAddress.pm b/lib/Sietima/Role/WithPostAddress.pm new file mode 100644 index 0000000..79507ab --- /dev/null +++ b/lib/Sietima/Role/WithPostAddress.pm @@ -0,0 +1,52 @@ +package Sietima::Role::WithPostAddress; +use Moo::Role; +use Sietima::Policy; +use Sietima::Types qw(Address AddressFromStr); +use namespace::clean; + +=head1 NAME + +Sietima::Role::WithPostAddress - role for lists with a posting address + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('WithPostAddress')->new({ + %args, + return_path => 'list-bounce@example.com', + post_address => 'list@example.com', + }); + +=head1 DESCRIPTION + +This role adds an L<< /C<post_address> >> attribute, and exposes it +via the L<< C<list_addresses>|Sietima/list_addresses >> method. + +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. + +=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 + +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; diff --git a/lib/Sietima/Runner.pm b/lib/Sietima/Runner.pm new file mode 100644 index 0000000..64e23eb --- /dev/null +++ b/lib/Sietima/Runner.pm @@ -0,0 +1,33 @@ +package Sietima::Runner; +use Moo; +use Sietima::Policy; +use namespace::clean; + +=head1 NAME + +Sietima::Runner + +=head1 DESCRIPTION + +You should never need to care about this class, it's used internally +by L<< C<Sietima::CmdLine> >>. + +This is a subclass of L<< C<App::Spec::Run> >> that uses directly +itself to execute the built-in commands, instead of delegating to the +C<cmd> object (in our case, a C<Sietima> instance) which would +delegate back via L<< C<App::Spec::Run::Cmd> >>. + +=cut + +extends 'App::Spec::Run'; + +sub run_op($self,$op,$args=[]) { + if ($op =~ /^cmd_/) { + $self->$op($args); + } + else { + $self->cmd->$op($self,$args); + } +} + +1; diff --git a/lib/Sietima/Subscriber.pm b/lib/Sietima/Subscriber.pm new file mode 100644 index 0000000..96c7d3b --- /dev/null +++ b/lib/Sietima/Subscriber.pm @@ -0,0 +1,114 @@ +package Sietima::Subscriber; +use Moo; +use Sietima::Policy; +use Types::Standard qw(ArrayRef HashRef Object); +use Type::Params qw(compile); +use Sietima::Types qw(Address AddressFromStr); +use Email::Address; +use List::AllUtils qw(any); +use namespace::clean; + +=head1 NAME + +Sietima::Subscriber - a subscriber to a mailing list + +=head1 DESCRIPTION + +This class holds the primary email address for a mailing list +subscriber, together with possible aliases and preferences. + +=head1 ATTRIBUTES + +All attributes are read-only. + +=head2 C<primary> + +Required L<< C<Email::Address> >> object, coercible from a string. + +This is the primary address for the subscriber, the one where they +will receive messages from the mailing list. + +=cut + +has primary => ( + isa => Address, + is => 'ro', + required => 1, + coerce => AddressFromStr, + handles => [qw(address name original)], +); + +=head2 C<aliases> + +Arrayref of L<< C<Email::Address> >> objects, each coercible from a +string. Defaults to an empty arrayref. + +These are secondary addresses that the subscriber may write +from. Subscriber-only mailing lists should accept messages from any of +these addresses as if they were from the primary. The L<< /C<match> >> +simplifies that task. + +=cut + +my $address_array = ArrayRef[ + Address->plus_coercions( + AddressFromStr + ) +]; +has aliases => ( + isa => $address_array, + is => 'lazy', + coerce => $address_array->coercion, +); +sub _build_aliases { +[] } + +=head2 C<prefs> + +A hashref. Various preferences that may be interpreted by Sietima +roles. Defaults to an empty hashref. + +=cut + +has prefs => ( + isa => HashRef, + is => 'ro', + default => sub { +{} }, +); + +=head1 METHODS + +=head2 C<match> + + if ($subscriber->match($address)) { ... } + +Given a L<< C<Email::Address> >> object (or a string), this method +returns true if the address is equivalent to the +L</primary> or any of the L</aliases>. + +This method should be used to determine whether an address belongs to +a subscriber. + +=cut + +sub match { + # we can't use the sub signature here, because we need the + # coercion + state $check = compile(Object,Address->plus_coercions(AddressFromStr)); + my ($self,$addr) = $check->(@_); + + return any { $addr->address eq $_->address } + $self->primary, $self->aliases->@*; +} + +=head2 C<address> + +=head2 C<name> + +=head2 C<original> + +These methods delegate to L<< C<Email::Address> >>'s methods of the +same name, invoked on the L<primary address|/primary>. + +=cut + +1; diff --git a/lib/Sietima/Types.pm b/lib/Sietima/Types.pm new file mode 100644 index 0000000..1c75b1f --- /dev/null +++ b/lib/Sietima/Types.pm @@ -0,0 +1,178 @@ +package Sietima::Types; +use Sietima::Policy; +use Type::Utils -all; +use Types::Standard qw(Str HashRef); +use namespace::clean; +use Type::Library + -base, + -declare => qw(SietimaObj + Address AddressFromStr + TagName + EmailMIME Message + Subscriber SubscriberFromAddress SubscriberFromStr SubscriberFromHashRef + Transport MailStore MailStoreFromHashRef); + +=head1 NAME + +Sietima::Types - type library for Sietima + +=head1 DESCRIPTION + +This module is a L<< C<Type::Library> >>. It declares a few type +constraints nad coercions. + +=head1 TYPES + +=head2 C<SietimaObj> + +An instance of L<< C<Sietima> >>. + +=cut + +class_type SietimaObj, { class => 'Sietima' }; + +=head2 C<EmailMIME> + +An instance of L<< C<Email::MIME> >>. + +=cut + +class_type EmailMIME, { class => 'Email::MIME' }; + +=head2 C<Transport> + +An object that consumes the role L<< C<Email::Sender::Transport> >>. + +=cut + +role_type Transport, { role => 'Email::Sender::Transport' }; + +=head2 C<MailStore> + +An object that consumes the role L<< C<Sietima::MailStore> >>. + +Coercions: + +=over + +=item C<MailStoreFromHashRef> + + has store => ( isa => MailStore->plus_coercions(MailStoreFromHashRef) ); + +Using this coercion, a hashref of the form: + + { + class => 'Some::Store::Class', + %constructor_args, + } + +will be converted into an instance of C<Some::Store::Class> built with +the C<%constructor_args>. + +=back + +=cut + +role_type MailStore, { role => 'Sietima::MailStore' }; + +declare_coercion MailStoreFromHashRef, + to_type MailStore, from HashRef, + q{ require Module::Runtime; + Module::Runtime::use_module(delete $_->{class})->new($_); + }; + +=head2 C<Address> + +An instance of L<< C<Email::Address> >>. + +Coercions: + +=over + +=item C<AddressFromStr> + + has address => ( isa => Address->plus_coercions(AddressFromStr) ); + +Using this coercion, a string will be parsed into an L<< +C<Email::Address> >>. If the string contains more than one address, +only the first one will be used. + +=back + +=cut + +class_type Address, { class => 'Email::Address' }; +declare_coercion AddressFromStr, + to_type Address, from Str, + q{ (Email::Address->parse($_))[0] }; + +=head2 C<TagName> + +A string composed exclusively of "word" (C</\w/>) characters. Used by +L<mail stores|Sietima::MailStore> to tag messages. + +=cut + +declare TagName, as Str, + where { /\A\w+\z/ }, + inline_as sub($constraint,$varname,@){ + $constraint->parent->inline_check($varname) + .qq{ && ($varname =~/\\A\\w+\\z/) }; + }; + +=head2 C<Message> + +An instance of L<< C<Sietima::Message> >>. + +=cut + +class_type Message, { class => 'Sietima::Message' }; + +=head2 C<Subscriber> + +An instance of L<< C<Sietima::Subscriber> >>. + +Coercions: + +=over + +=item C<SubscriberFromAddress> + + has sub => ( isa => Subscriber->plus_coercions(SubscriberFromAddress) ); + +Using this coercion, an L<< C<Email::Address> >> will be converted +into a subscriber that has that address as its primary. + +=item C<SubscriberFromStr> + + has sub => ( isa => Subscriber->plus_coercions(SubscriberFromStr) ); + +Using this coercion, a string will be converted into a subscriber that +has the first address parsed from that string as its primary. + +=item C<SubscriberFromHashRef> + + has sub => ( isa => Subscriber->plus_coercions(SubscriberFromHashRef) ); + +Using this coercion, a hashref will be converted into a subscriber by +passing it to the constructor. + +=back + +=cut + +class_type Subscriber, { class => 'Sietima::Subscriber' }; + +declare_coercion SubscriberFromAddress, + to_type Subscriber, from Address, + q{ Sietima::Subscriber->new(primary=>$_) }; + +declare_coercion SubscriberFromStr, + to_type Subscriber, from Str, + q{ Sietima::Subscriber->new(primary=>(Email::Address->parse($_))[0]) }; + +declare_coercion SubscriberFromHashRef, + to_type Subscriber, from HashRef, + q{ Sietima::Subscriber->new($_) }; + +1; diff --git a/t/lib/Test/Sietima.pm b/t/lib/Test/Sietima.pm new file mode 100644 index 0000000..8a97fc6 --- /dev/null +++ b/t/lib/Test/Sietima.pm @@ -0,0 +1,189 @@ +package Test::Sietima; +use lib 't/lib'; +use Import::Into; +use Email::Stuffer; +use Email::Sender::Transport::Test; +use Data::Printer; +use Sietima; +use Test2::Bundle::Extended; +use Test2::API qw(context); +use Sietima::Policy; +use namespace::clean; + +sub import { + my $target = caller; + Test2::Bundle::Extended->import::into($target); + Test2::Plugin::DieOnFail->import::into($target); + Data::Printer->import::into($target); + Sietima::Policy->import::into($target); + + for my $function (qw(transport make_sietima make_mail + deliveries_are test_sending + run_cmdline_sub)) { + no strict 'refs'; + "${target}::${function}"->** = __PACKAGE__->can($function); + } + return; +} + +my $return_path = 'sietima-test@list.example.com'; + +sub transport { + state $transport = Email::Sender::Transport::Test->new; + return $transport; +} + +sub make_sietima (%args) { + my $class = 'Sietima'; + if (my $traits = delete $args{with_traits}) { + $class = $class->with_traits($traits->@*); + } + + $class->new({ + return_path => $return_path, + %args, + transport => transport(), + }); +} + +my $maybe = sub ($obj,$method,$arg) { + return $obj unless $arg; + return $obj->$method($arg); +}; + +my $mapit = sub ($obj,$method,$arg) { + return $obj unless $arg; + for my $k (keys $arg->%*) { + $obj = $obj->$method($k, $arg->{$k}); + } + return $obj; +}; + +sub make_mail (%args) { + Email::Stuffer + ->from($args{from}||'someone@users.example.com') + ->to($args{to}||$return_path) + ->$maybe(cc => $args{cc}) + ->$mapit(header => $args{headers}) + ->subject($args{subject}||'Test Message') + ->text_body($args{body}||'some simple message') + ->email; +} + +sub deliveries_are (%args) { + my $ctx = context(); + + my $checker; + if (my @mails = ($args{mails}||[])->@*) { + $checker = bag { + for my $m (@mails) { + item hash { + if (ref($m) eq 'HASH') { + field email => object { + call [cast=>'Email::MIME'] => $m->{o}; + }; + field envelope => hash { + field to => bag { + item $_ for $m->{to}->@*; + } if $m->{to}; + field from => $m->{from} if $m->{from}; + etc(); + }; + } + else { + field email => object { + call [cast=>'Email::MIME'] => $m; + }; + } + etc(); + }; + } + end(); + }; + } + elsif (my @recipients = do {my $to = $args{to}; ref($to) ? $to->@* : $to // () }) { + $checker = array { + item hash { + field envelope => hash { + field from => $args{from}||$return_path; + field to => bag { + for (@recipients) { + item $_; + } + end(); + }; + etc(); + }; + etc(); + }; + end(); + }; + } + else { + $checker = []; + } + + my @deliveries = transport->deliveries; + is( + \@deliveries, + $checker, + $args{test_message}//'the deliveries should be as expected', + np @deliveries, + ); + $ctx->release; +} + +sub test_sending (%args) { + my $ctx = context(); + + my $sietima = delete $args{sietima}; + if (!$sietima or ref($sietima) eq 'HASH') { + $sietima = make_sietima(%{$sietima||{}}); + } + my $mail = delete $args{mail}; + if (!$mail or ref($mail) eq 'HASH') { + $mail = make_mail( + to => $sietima->return_path, + %{$mail||{}}, + ); + } + + transport->clear_deliveries; + + ok( + lives { $sietima->handle_mail($mail) }, + 'should handle the mail', + $@, + ); + + $args{from} ||= $sietima->return_path; + $args{to} ||= [ map { $_->address} $sietima->subscribers->@* ]; + deliveries_are(%args); + + $ctx->release; +} + +sub run_cmdline_sub($sietima,$method,$options={},$parameters={}) { + require Sietima::Runner; + my $r = Sietima::Runner->new({ + options => $options, + parameters => $parameters, + cmd => $sietima, + op => $method, + }); + $r->response(App::Spec::Run::Response->new); + ok( + lives { $sietima->$method($r) }, + "calling $method should live", + ); + my %ret; + for my $output ($r->response->outputs->@*) { + $ret{ + $output->error ? 'error' : 'output' + } .= $output->content; + } + $ret{exit} = $r->response->exit(); + return \%ret; +} + +1; diff --git a/t/lib/Test/Sietima/MailStore.pm b/t/lib/Test/Sietima/MailStore.pm new file mode 100644 index 0000000..df4fb03 --- /dev/null +++ b/t/lib/Test/Sietima/MailStore.pm @@ -0,0 +1,63 @@ +package Test::Sietima::MailStore; +use Moo; +use Sietima::Policy; +use List::AllUtils qw(all first_index); +use Digest::SHA qw(sha1_hex); +use namespace::clean; + +with 'Sietima::MailStore'; + +has _mails => ( + is => 'rw', + default => sub { +{} }, +); + +sub clear { shift->_mails({}) } + +sub store ($self,$mail,@tags) { + my $str = $mail->as_string; + my $id = sha1_hex($str); + $self->_mails->{$id} = { + id => $id, + mail => $str, + tags => { map {$_ => 1;} @tags, }, + }; + return $id; +} + +sub retrieve_ids_by_tags ($self,@tags){ + my @ret; + for my $m (values $self->_mails->%*) { + next unless all { $m->{tags}{$_} } @tags; + push @ret, $m->{id}; + } + return \@ret; +} + +sub retrieve_by_tags ($self,@tags){ + my @ret; + for my $m (values $self->_mails->%*) { + next unless all { $m->{tags}{$_} } @tags; + push @ret, { + $m->%{id}, + mail => Email::MIME->new($m->{mail}) + }; + } + + return \@ret; +} + +sub retrieve_by_id ($self,$id) { + if (my $m = $self->_mails->{$id}) { + return Email::MIME->new($m->{mail}); + } + + return; +} + +sub remove($self,$id) { + delete $self->_mails->{$id}; + return; +} + +1; diff --git a/t/tests/sietima.t b/t/tests/sietima.t new file mode 100644 index 0000000..987cbdd --- /dev/null +++ b/t/tests/sietima.t @@ -0,0 +1,24 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +ok(make_sietima(),'should instantiate') or bail_out; + +subtest 'no subscribers' => sub { + test_sending( + to => [], + ); +}; + +subtest 'with subscribers' => sub { + my @subscriber_addresses = ( + 'one@users.example.com', + 'two@users.example.com', + ); + test_sending( + sietima => { subscribers => \@subscriber_addresses }, + to => \@subscriber_addresses, + ); +}; + +done_testing; diff --git a/t/tests/sietima/cmdline.t b/t/tests/sietima/cmdline.t new file mode 100644 index 0000000..bd24c84 --- /dev/null +++ b/t/tests/sietima/cmdline.t @@ -0,0 +1,82 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Path::Tiny; +use Sietima; +use Sietima::CmdLine; + +subtest 'given instance' => sub { + my $s = Sietima->new({ + return_path => 'list@example.com', + }); + my $c = Sietima::CmdLine->new({ + sietima => $s, + }); + is( + $c, + object { + call app_spec => object { + call name => 'sietima'; + call subcommands => hash { + field send => object { + call name => 'send'; + }; + etc; + }; + }; + call runner => object { + call cmd => $s; + }; + }, + 'spec & runner should be built', + ); +}; + +subtest 'built via args' => sub { + my $c = Sietima::CmdLine->new({ + args => { + return_path => 'list@example.com', + }, + }); + is( + $c, + object { + call sietima => object { + call return_path => 'list@example.com'; + }; + }, + 'sietima should be built', + ); +}; + +subtest 'built via args & traits' => sub { + my $c = Sietima::CmdLine->new({ + traits => [ qw(ReplyTo) ], + args => { + return_path => 'list@example.com', + }, + }); + DOES_ok( + $c->sietima, + ['Sietima::Role::ReplyTo'], + 'sietima should be built with the given trait', + ); +}; + +subtest 'extra spec' => sub { + my $c = Sietima::CmdLine->new({ + extra_spec => { name => 'different' }, + args => { + return_path => 'list@example.com', + }, + }); + is( + $c->app_spec, + object { + call name => 'different'; + }, + 'spec fields should be overridden', + ); +}; + +done_testing; diff --git a/t/tests/sietima/mailstore.t b/t/tests/sietima/mailstore.t new file mode 100644 index 0000000..7a2aa08 --- /dev/null +++ b/t/tests/sietima/mailstore.t @@ -0,0 +1,186 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Email::Stuffer; +use Path::Tiny; + +package TestClassWithMS { + use Moo; + use Sietima::Policy; + with 'Sietima::Role::WithMailStore'; +}; + +subtest 'Role::WithMailStore' => sub { + subtest 'plain instance' => sub { + require Test::Sietima::MailStore; + ok( + lives { + TestClassWithMS->new({ + mail_store => Test::Sietima::MailStore->new, + }) + }, + 'passing a test instance should work', + ); + }; + subtest 'type coercion' => sub { + my $tc; + my $root = Path::Tiny->tempdir; + ok( + lives { + $tc = TestClassWithMS->new({ + mail_store => { + class => 'Sietima::MailStore::FS', + root => $root, + }, + }) + }, + 'passing a hashref should work (and load the class)', + ); + is( + $tc->mail_store, + object { + prop blessed => 'Sietima::MailStore::FS'; + call root => $root; + }, + 'the mailstore should be built correctly', + ); + }; +}; + +sub mkmail($id) { + Email::Stuffer + ->from("from-${id}\@example.com") + ->to("to-${id}\@example.com") + ->subject("subject $id") + ->text_body("body $id \nbody body\n") + ->email; +} + +sub chkmail($id) { + object { + call [header=>'from'] => "from-${id}\@example.com"; + call [header=>'to'] => "to-${id}\@example.com"; + call [header=>'subject'] => "subject $id"; + call body => match qr{\bbody \Q$id\E\b}; + }; +} + +sub chk_multimail(@ids) { + return bag { + for my $id (@ids) { + item hash { + field id => D(); + field mail => chkmail($id); + end; + }; + } + end; + }; +} + +sub test_store($store) { + my %stored_id; + + subtest 'storing' => sub { + ok($stored_id{1}=$store->store(mkmail(1),'tag1','tag2')); + ok($stored_id{2}=$store->store(mkmail(2),'tag2')); + ok($stored_id{3}=$store->store(mkmail(3),'tag1')); + }; + + subtest 'retrieving by id' => sub { + is( + $store->retrieve_by_id($stored_id{$_}), + chkmail($_), + ) for 1..3; + }; + + subtest 'retrieving by tag' => sub { + my $tag1 = $store->retrieve_by_tags('tag1'); + is( + $tag1, + chk_multimail(1,3), + 'tag1 should have mails 1 & 3', + ); + + my $tag2 = $store->retrieve_by_tags('tag2'); + is( + $tag2, + chk_multimail(1,2), + 'tag1 should have mails 1 & 2', + ); + + my $tag12 = $store->retrieve_by_tags('tag2','tag1'); + is( + $tag12, + chk_multimail(1), + 'tag1+tag2 should have mail 1', + ); + + my $tag_all = $store->retrieve_by_tags(); + is( + $tag_all, + chk_multimail(1,2,3), + 'no tags should retrieve all mails', + ); + }; + + subtest 'retrieving ids by tag' => sub { + my $tag1 = $store->retrieve_ids_by_tags('tag1'); + is( + $tag1, + bag { item $stored_id{1}; item $stored_id{3}; end }, + 'tag1 should have ids 1 & 3', + ); + + my $tag2 = $store->retrieve_ids_by_tags('tag2'); + is( + $tag2, + bag { item $stored_id{1}; item $stored_id{2}; end }, + 'tag1 should have ids 1 & 2', + ); + + my $tag12 = $store->retrieve_ids_by_tags('tag2','tag1'); + is( + $tag12, + bag { item $stored_id{1}; end }, + 'tag1+tag2 should have id 1', + ); + + my $tag_all = $store->retrieve_ids_by_tags(); + is( + $tag_all, + bag { item $stored_id{1}; item $stored_id{2}; item $stored_id{3}; end }, + 'no tags should retrieve all ids', + ); + }; + + subtest 'removing' => sub { + $store->remove($stored_id{2}); + is( + $store->retrieve_by_tags('tag2'), + chk_multimail(1), + 'remove should remove', + ); + }; + + subtest 'clearing' => sub { + $store->clear; + is( + $store->retrieve_by_tags(), + [], + 'clear should clear', + ); + }; +} + +subtest 'test store' => sub { + test_store(Test::Sietima::MailStore->new); +}; + +subtest 'file store' => sub { + my $root = Path::Tiny->tempdir; + + test_store(Sietima::MailStore::FS->new({root => $root})); +}; + +done_testing; diff --git a/t/tests/sietima/message.t b/t/tests/sietima/message.t new file mode 100644 index 0000000..d1c548a --- /dev/null +++ b/t/tests/sietima/message.t @@ -0,0 +1,35 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Email::Stuffer; +use Sietima::Message; + +my $mail = Email::Stuffer + ->from('one@example.com') + ->to('two@example, three@example.com') + ->text_body('test message')->email; + +my $message = Sietima::Message->new({ + mail => $mail, + from => 'one@envelope.example.com', + to => [ + 'two@envelope.example.com', + 'three@envelope.example.com', + ], +}); + +is( + $message->envelope, + { + from => 'one@envelope.example.com', + to => bag { + item 'two@envelope.example.com'; + item 'three@envelope.example.com'; + }, + }, + 'the envelope should be built from the attributes', +); + +# I'm not sure I'll need 'clone', so I won't test it for the moment + +done_testing; diff --git a/t/tests/sietima/multi-role/debounce-moderate.t b/t/tests/sietima/multi-role/debounce-moderate.t new file mode 100644 index 0000000..e61c551 --- /dev/null +++ b/t/tests/sietima/multi-role/debounce-moderate.t @@ -0,0 +1,64 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Test::Sietima::MailStore; + +sub test_one($traits,$should_send=1) { + my @subscriber_addresses = ( + 'one@users.example.com', + 'two@users.example.com', + ); + my $owner = 'owner@lists.example.com'; + my $ms = Test::Sietima::MailStore->new(); + + my $s = make_sietima( + with_traits => $traits, + subscribers => \@subscriber_addresses, + owner => $owner, + mail_store => $ms, + ); + + test_sending( + sietima => $s, + mail => { from=>'someone@users.example.com' }, + mails => [{ + o => object { + call [header_str => 'subject'] => match qr{\bheld for moderation\b}; + }, + }], + ); + transport->clear_deliveries; + + my $to_moderate = $ms->retrieve_by_tags('moderation'); + my $msg_id = $to_moderate->[0]->{id}; + $s->resume($msg_id); + + if ($should_send) { + deliveries_are( + to => \@subscriber_addresses, + test_message => 'the resumed message should be sent', + ); + } + else { + deliveries_are( + mails => [], + test_message => 'the resumed message should be dropped', + ); + } +} + +# there's an ordering dependency between Debounce and Moderate: if we +# moderate a message that already has the X-Been-There header, it will +# be dropped when resumed; the simplest solution is to apply Debounce +# *before* Moderate, so messages are moderated *before* getting the +# anti-loop header + +subtest 'debounce first' => sub { + test_one(['Debounce','SubscriberOnly::Moderate'],1); +}; + +subtest 'moderate first' => sub { + test_one(['SubscriberOnly::Moderate','Debounce'],0); +}; + +done_testing; diff --git a/t/tests/sietima/role/avoid-dups.t b/t/tests/sietima/role/avoid-dups.t new file mode 100644 index 0000000..671d898 --- /dev/null +++ b/t/tests/sietima/role/avoid-dups.t @@ -0,0 +1,29 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +my $s = make_sietima( + with_traits => ['AvoidDups'], + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], +); + +subtest 'in cc' => sub { + test_sending( + sietima => $s, + mail => { cc => 'one@users.example.com' }, + to => ['two@users.example.com'], + ); +}; + +subtest 'in to' => sub { + test_sending( + sietima => $s, + mail => { to => $s->return_path . ' one@users.example.com' }, + to => ['two@users.example.com'], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/debounce.t b/t/tests/sietima/role/debounce.t new file mode 100644 index 0000000..ba7566c --- /dev/null +++ b/t/tests/sietima/role/debounce.t @@ -0,0 +1,37 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +my $s = make_sietima( + with_traits => ['Debounce'], + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], +); + +my $return_path = $s->return_path->address; + +subtest 'header should be added' => sub { + test_sending( + sietima => $s, + mails => [ + object { + call [ header_str => 'X-Been-There' ] => + match qr{\b\Q$return_path\E\b}; + }, + ], + ); +}; + +subtest 'header should inhibit sending' => sub { + test_sending( + sietima => $s, + mail => { + headers => { 'x-been-there' => $return_path }, + }, + to => [], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/headers.t b/t/tests/sietima/role/headers.t new file mode 100644 index 0000000..3052781 --- /dev/null +++ b/t/tests/sietima/role/headers.t @@ -0,0 +1,56 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +package Sietima::Role::ForTesting { + use Moo::Role; + use Sietima::Policy; + use Sietima::Types qw(AddressFromStr); + + around list_addresses => sub($orig,$self) { + return { + $self->$orig->%*, + test1 => AddressFromStr->coerce('name <someone@example.com>'), + 'test+2' => 'http://test.example.com', + }; + }; +}; + +my $s = make_sietima( + with_traits => ['Headers','WithOwner','ForTesting'], + name => 'test-list', + owner => 'owner@example.com', + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], +); + +subtest 'list headers should be added' => sub { + test_sending( + sietima => $s, + mails => [ + object { + call sub { +{ shift->header_str_pairs } } => hash { + field 'List-Id' => 'test-list <sietima-test.list.example.com>'; + field 'List-Owner' => '<mailto:owner@example.com>'; + field 'List-Post' => '<mailto:sietima-test@list.example.com>'; + field 'List-Test1' => '<mailto:someone@example.com>'; + field 'List-Test-2' => 'http://test.example.com'; + + field 'Date' => D(); + field 'MIME-Version' => D(); + field 'Content-Type' => D(); + field 'Content-Transfer-Encoding' => D(); + field 'From' => 'someone@users.example.com'; + field 'To' => 'sietima-test@list.example.com'; + field 'Subject' => 'Test Message'; + + end; + }; + }, + ], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/nomail.t b/t/tests/sietima/role/nomail.t new file mode 100644 index 0000000..2449f5a --- /dev/null +++ b/t/tests/sietima/role/nomail.t @@ -0,0 +1,41 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +subtest 'disabled' => sub { + my $s = make_sietima( + with_traits => ['NoMail'], + subscribers => [ + { + primary => 'one@users.example.com', + prefs => { wants_mail => 0 }, + }, + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + to => ['two@users.example.com'], + ); +}; + +subtest 'enabled' => sub { + my $s = make_sietima( + with_traits => ['NoMail'], + subscribers => [ + { + primary => 'one@users.example.com', + prefs => { wants_mail => 1 }, + }, + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + to => ['one@users.example.com','two@users.example.com'], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/replyto.t b/t/tests/sietima/role/replyto.t new file mode 100644 index 0000000..e39f8b3 --- /dev/null +++ b/t/tests/sietima/role/replyto.t @@ -0,0 +1,143 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +subtest 'disabled' => sub { + my $s = make_sietima( + with_traits => ['ReplyTo'], + munge_reply_to => 0, + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + mails => [ + object { + call [ header_str => 'reply-to' ] => undef; + }, + ], + ); +}; + +subtest 'enabled' => sub { + my $s = make_sietima( + with_traits => ['ReplyTo'], + munge_reply_to => 1, + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + mails => [ + object { + call [ header_str => 'reply-to' ] => $s->return_path->address; + }, + ], + ); +}; + +subtest 'enabled, custom post address' => sub { + my $post_address = 'the-list@example.com'; + my $s = make_sietima( + with_traits => ['ReplyTo'], + munge_reply_to => 1, + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], + post_address => $post_address, + ); + + is( + $s->list_addresses, + hash { + field return_path => $s->return_path; + field post => object { + call address => $post_address; + }; + }, + 'the custom post address should be set for the headers', + ); + + test_sending( + sietima => $s, + mails => [ + object { + call [ header_str => 'reply-to' ] => $post_address; + }, + ], + ); +}; + +subtest 'enabled for some' => sub { + my $s = make_sietima( + with_traits => ['ReplyTo'], + munge_reply_to => 0, + subscribers => [ + { + primary => 'one@users.example.com', + prefs => { munge_reply_to => 1 }, + }, + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + mails => [ + { + o => object { + call [ header_str => 'reply-to' ] => $s->return_path->address; + }, + to => [ 'one@users.example.com' ], + }, + { + o => object { + call [ header_str => 'reply-to' ] => undef; + }, + to => [ 'two@users.example.com' ], + }, + ], + ); +}; + + +subtest 'disabled for some' => sub { + my $s = make_sietima( + with_traits => ['ReplyTo'], + munge_reply_to => 1, + subscribers => [ + { + primary => 'one@users.example.com', + prefs => { munge_reply_to => 0 }, + }, + 'two@users.example.com', + ], + ); + + test_sending( + sietima => $s, + mails => [ + { + o => object { + call [ header_str => 'reply-to' ] => $s->return_path->address; + }, + to => [ 'two@users.example.com' ], + }, + { + o => object { + call [ header_str => 'reply-to' ] => undef; + }, + to => [ 'one@users.example.com' ], + }, + ], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/subject-tag.t b/t/tests/sietima/role/subject-tag.t new file mode 100644 index 0000000..e3a266b --- /dev/null +++ b/t/tests/sietima/role/subject-tag.t @@ -0,0 +1,42 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +my $s = make_sietima( + with_traits => ['SubjectTag'], + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], + subject_tag => 'foo', +); + +subtest 'adding tag' => sub { + test_sending( + sietima => $s, + mails => [ + object { + call [ header_str => 'Subject' ] => + '[foo] Test Message'; + }, + ], + ); +}; + +subtest 'tag already there' => sub { + my $subject = "[foo] \N{HEAVY BLACK HEART} test"; + test_sending( + sietima => $s, + mail => { + subject => $subject, + }, + mails => [ + object { + call [ header_str => 'Subject' ] => + $subject; + }, + ], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/subscriberonly/drop.t b/t/tests/sietima/role/subscriberonly/drop.t new file mode 100644 index 0000000..ac37346 --- /dev/null +++ b/t/tests/sietima/role/subscriberonly/drop.t @@ -0,0 +1,39 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +my @subscriber_addresses = ( + 'one@users.example.com', + { + primary => 'two@users.example.com', + aliases => [ 'two-two@users.example.com' ], + }, +); +my $s = make_sietima( + with_traits => ['SubscriberOnly::Drop'], + subscribers => \@subscriber_addresses, +); + +subtest 'from subscriber' => sub { + test_sending( + sietima => $s, + mail => { from=>'one@users.example.com' }, + ); +}; + +subtest 'from subscriber alias' => sub { + test_sending( + sietima => $s, + mail => { from=>'two-two@users.example.com' }, + ); +}; + +subtest 'from non-subscriber' => sub { + test_sending( + sietima => $s, + mail => { from=>'someone@users.example.com' }, + to => [], + ); +}; + +done_testing; diff --git a/t/tests/sietima/role/subscriberonly/moderate.t b/t/tests/sietima/role/subscriberonly/moderate.t new file mode 100644 index 0000000..44999bd --- /dev/null +++ b/t/tests/sietima/role/subscriberonly/moderate.t @@ -0,0 +1,131 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Test::Sietima::MailStore; + +my @subscriber_addresses = ( + 'one@users.example.com', + 'two@users.example.com', +); +my $owner = 'owner@lists.example.com'; +my $ms = Test::Sietima::MailStore->new(); +my $s = make_sietima( + with_traits => ['SubscriberOnly::Moderate'], + subscribers => \@subscriber_addresses, + owner => $owner, + mail_store => $ms, +); + +subtest 'from subscriber' => sub { + $ms->clear; + test_sending( + sietima => $s, + mail => { from=>'one@users.example.com' }, + ); + is( + $ms->retrieve_by_tags('moderation'), + [], + 'no mails held for moderation', + ); +}; + +sub test_from_non_sub() { + my $from = $s->return_path->address; + test_sending( + sietima => $s, + mail => { from=>'someone@users.example.com' }, + mails => [{ + o => object { + call [header_str => 'subject'] => match qr{\bheld for moderation\b}; + call [header_str => 'from'] => match qr{\b\Q$from\E\b}; + call [header_str => 'to'] => match qr{\b\Q$owner\E\b}; + call_list parts => [ + object { + call body => match qr{Use id \S+ to refer to it}; + }, + object { + call sub {Email::MIME->new(shift->body)} => object { + call [header_str => 'subject'] => 'Test Message'; + }; + }, + ]; + }, + from => $from, + to => [$owner], + }], + ); +} + +subtest 'from non-subscriber' => sub { + $ms->clear; + test_from_non_sub; + + is( + my $to_moderate = $ms->retrieve_by_tags('moderation'), + [ + { + id => T(), + mail => object { + call [header_str => 'from'] => 'someone@users.example.com'; + call [header_str => 'to'] => $s->return_path->address, + }, + }, + ], + 'mails was held for moderation', + ); + + like( + run_cmdline_sub($s, 'list_mails_in_moderation_queue'), + hash { + field exit => 0; + field error => DNE; + field output => qr{\A + ^\N+\b1 \s+ message\N+$ \n + ^\* \s+ \w+ \s+ someone\@users\.example\.com + \s+ "Test[ ]Message" + \s+ \(\N+?\)$ + }smx; + }, + 'mails in queue should be listed from command line', + ); + + my $msg_id = $to_moderate->[0]->{id}; + + like( + run_cmdline_sub( + $s, 'show_mail_from_moderation_queue', + {}, { 'mail-id' => $msg_id }, + ), + hash { + field exit => 0; + field error => DNE; + field output => qr{\A + ^Message \s+ \w+:$ + .*? + ^From: \s+ someone\@users\.example\.com \s*$ + }smx; + }, + 'mail in queue should be shown from command line', + ); + + transport->clear_deliveries; + $s->resume($msg_id); + deliveries_are( + to => \@subscriber_addresses, + ); +}; + +subtest 'from non-subscriber, drop' => sub { + $ms->clear; + test_from_non_sub; + + my $msg_id = $ms->retrieve_by_tags('moderation')->[0]{id}; + $s->drop($msg_id); + is( + $ms->retrieve_by_tags('moderation'), + [], + 'message should be dropped', + ); +}; + +done_testing; diff --git a/t/tests/sietima/subscriber.t b/t/tests/sietima/subscriber.t new file mode 100644 index 0000000..6761410 --- /dev/null +++ b/t/tests/sietima/subscriber.t @@ -0,0 +1,41 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; +use Sietima::Subscriber; + +subtest 'simple' => sub { + my $s = Sietima::Subscriber->new( + primary => 'Gino (pino) <gino@pino.example.com>', + ); + + is( + $s, + object { + call address => 'gino@pino.example.com'; + call name => 'Gino'; + call original => 'Gino (pino) <gino@pino.example.com>'; + call prefs => {}; + }, + 'construction and delegation should work', + ); +}; + +subtest 'aliases' => sub { + my $s = Sietima::Subscriber->new( + primary => 'Gino (pino) <gino@pino.example.com>', + aliases => [qw(also-gino@pino.example.com maybe-gino@rino.example.com)], + ); + + is( + $s, + object { + for my $a (qw(gino@pino also-gino@pino maybe-gino@rino)) { + call [match => "${a}.example.com"] => T(); + } + }, + 'all addresses should ->match()', + ); + +}; + +done_testing; |