File Coverage

blib/lib/Sietima/Role/SubscriberOnly/Moderate.pm
Criterion Covered Total %
statement 59 59 100.0
branch 10 20 50.0
condition 3 6 50.0
subroutine 11 11 100.0
pod 5 5 100.0
total 88 101 87.1


line stmt bran cond sub pod time code
1             package Sietima::Role::SubscriberOnly::Moderate;
2 2     2   1010 use Moo::Role;
  2         6  
  2         13  
3 2     2   639 use Sietima::Policy;
  2         4  
  2         27  
4 2     2   12 use Email::Stuffer;
  2         4  
  2         46  
5 2     2   10 use Email::MIME;
  2         37  
  2         46  
6 2     2   10 use namespace::clean;
  2         4  
  2         15  
7              
8             our $VERSION = '1.0.3'; # VERSION
9             # ABSTRACT: moderate messages from non-subscribers
10              
11              
12             with 'Sietima::Role::SubscriberOnly',
13             'Sietima::Role::WithMailStore',
14             'Sietima::Role::WithOwner';
15              
16              
17 4 50   4 1 22 sub munge_mail_from_non_subscriber ($self,$mail) {
  4 50       18  
  4         10  
  4         9  
  4         11  
18 4         47 my $id = $self->mail_store->store($mail,'moderation');
19 4         939 my $notice = Email::Stuffer
20             ->from($self->return_path->address)
21             ->to($self->owner->address)
22             ->subject("Message held for moderation - ".$mail->header_str('subject'))
23             ->text_body("Use id $id to refer to it")
24             ->attach(
25             $mail->as_string,
26             content_type => 'message/rfc822',
27             # some clients, most notably Claws-Mail, seem to have
28             # problems with encodings other than this
29             encoding => '7bit',
30             );
31 4         15461 $self->transport->send($notice->email,{
32             from => $self->return_path,
33             to => [ $self->owner ],
34             });
35 4         13310 return;
36             }
37              
38              
39 3 50   3 1 31317 sub resume ($self,$mail_id) {
  3 50       14  
  3         7  
  3         7  
  3         7  
40 3         23 my $mail = $self->mail_store->retrieve_by_id($mail_id);
41 3         7 $self->ignoring_subscriberonly(
42 3 50   3   15 sub($s) { $s->handle_mail($mail) },
  3 50       12  
  3         8  
  3         17  
43 3         1550 );
44 3         35 $self->mail_store->remove($mail_id);
45             }
46              
47              
48 1 50   1 1 19112 sub drop ($self,$mail_id) {
  1 50       5  
  1         3  
  1         2  
  1         3  
49 1         10 $self->mail_store->remove($mail_id);
50             }
51              
52              
53 1 50   1 1 4767 sub list_mails_in_moderation_queue ($self,$runner,@) {
  1         5  
  1         5  
  1         4  
54 1         15 my $mails = $self->mail_store->retrieve_by_tags('moderation');
55 1         720 $runner->out(sprintf 'There are %d messages held for moderation:',scalar($mails->@*));
56 1         1114 for my $mail ($mails->@*) {
57             $runner->out(sprintf '* %s %s "%s" (%s)',
58             $mail->{id},
59             $mail->{mail}->header_str('From')//'<no from>',
60             $mail->{mail}->header_str('Subject')//'<no subject>',
61 1   50     8 $mail->{mail}->header_str('Date')//'<no date>',
      50        
      50        
62             );
63             }
64             }
65              
66              
67 1 50   1 1 1962 sub show_mail_from_moderation_queue ($self,$runner,@) {
  1         3  
  1         3  
  1         2  
68 1         7 my $id = $runner->parameters->{'mail-id'};
69 1         10 my $mail = $self->mail_store->retrieve_by_id($id);
70 1         718 $runner->out("Message $id:");
71 1         105 $runner->out($mail->as_string =~ s{\r\n}{\n}gr);
72             }
73              
74              
75             around command_line_spec => sub ($orig,$self) {
76             my $spec = $self->$orig();
77              
78             # this allows us to tab-complete identifiers from the shell!
79             my $list_mail_ids = sub ($self,$runner,$args) {
80             $self->mail_store->retrieve_ids_by_tags('moderation');
81             };
82             # a little factoring: $etc->($command_name) generates the spec for
83             # sub-commands that require a mail id
84             my $etc = sub($cmd) {
85             return (
86             summary => "$cmd the given mail, currently held for moderation",
87             parameters => [
88             {
89             name => 'mail-id',
90             required => 1,
91             summary => "id of the mail to $cmd",
92             completion => { op => $list_mail_ids },
93             },
94             ],
95             );
96             };
97              
98             $spec->{subcommands}{'list-held'} = {
99             op => 'list_mails_in_moderation_queue',
100             summary => 'list all mails currently held for moderation',
101             };
102             $spec->{subcommands}{'show-held'} = {
103             op => 'show_mail_from_moderation_queue',
104             $etc->('show'),
105             };
106             $spec->{subcommands}{'resume-held'} = {
107             op => sub ($self,$runner,$args) {
108             $self->resume($runner->parameters->{'mail-id'});
109             },
110             $etc->('resume'),
111             };
112             $spec->{subcommands}{'drop-held'} = {
113             op => sub ($self,$runner,$args) {
114             $self->drop($runner->parameters->{'mail-id'});
115             },
116             $etc->('drop'),
117             };
118              
119             return $spec;
120             };
121              
122             1;
123              
124             __END__
125              
126             =pod
127              
128             =encoding UTF-8
129              
130             =head1 NAME
131              
132             Sietima::Role::SubscriberOnly::Moderate - moderate messages from non-subscribers
133              
134             =head1 VERSION
135              
136             version 1.0.3
137              
138             =head1 SYNOPSIS
139              
140             my $sietima = Sietima->with_traits('SubscribersOnly::Moderate')->new({
141             %args,
142             owner => 'listmaster@example.com',
143             mail_store => {
144             class => 'Sietima::MailStore::FS',
145             root => '/tmp',
146             },
147             });
148              
149             =head1 DESCRIPTION
150              
151             A L<< C<Sietima> >> list with this role applied will accept incoming
152             emails coming from non-subscribers, and store it for moderation. Each
153             such email will be forwarded (as an attachment) to the list's owner.
154              
155             The owner will the be able to delete the message, or allow it.
156              
157             This is a "sub-role" of L<<
158             C<SubscribersOnly>|Sietima::Role::SubscriberOnly >>, L<<
159             C<WithMailStore>|Sietima::Role::WithMailStore >>, and L<<
160             C<WithOwner>|Sietima::Role::WithOwner >>.
161              
162             =head1 METHODS
163              
164             =head2 C<munge_mail_from_non_subscriber>
165              
166             L<Stores|Sietima::MailStore/store> the email with the C<moderation>
167             tag, and forwards it to the L<list
168             owner|Sietima::Role::WithOwner/owner>.
169              
170             =head2 C<resume>
171              
172             $sietima->resume($mail_id);
173              
174             Given an identifier returned when L<storing|Sietima::MailStore/store>
175             an email, this method retrieves the email and re-processes it via L<<
176             C<ignoring_subscriberonly>|Sietima::Role::SubscriberOnly/ignoring_subscriberonly
177             >>. This will make sure that the email is not caught again by the
178             subscriber-only filter.
179              
180             =head2 C<drop>
181              
182             $sietima->drop($mail_id);
183              
184             Given an identifier returned when L<storing|Sietima::MailStore/store>
185             an email, this method deletes the email from the store.
186              
187             =head2 C<list_mails_in_moderation_queue>
188              
189             $sietima->list_mails_in_moderation_queue($sietima_runner);
190              
191             This method L<retrieves all the
192             identifiers|Sietima::MailStore/retrieve_by_tags> of messages tagged
193             C<moderation>, and L<prints them out|App::Spec::Runner/out> via the
194             L<< C<Sietima::Runner> >> object.
195              
196             This method is usually invoked from the command line, see L<<
197             /C<command_line_spec> >>.
198              
199             =head2 C<show_mail_from_moderation_queue>
200              
201             $sietima->show_mail_from_moderation_queue($sietima_runner);
202              
203             This method L<retrieves the email|Sietima::MailStore/retrieve_by_id>
204             of the message requested from the command line, and L<prints it
205             out|App::Spec::Runner/out> via the L<< C<Sietima::Runner> >> object.
206              
207             This method is usually invoked from the command line, see L<<
208             /C<command_line_spec> >>.
209              
210             =head1 MODIFIED METHODS
211              
212             =head2 C<command_line_spec>
213              
214             This method adds the following sub-commands for the command line:
215              
216             =over
217              
218             =item C<list-held>
219              
220             $ sietima list-held
221              
222             Invokes the L<< /C<list_mails_in_moderation_queue> >> method, printing
223             the identifiers of all messages held for moderation.
224              
225             =item C<show-held>
226              
227             $ sietima show-held 32946p6eu7867
228              
229             Invokes the L<< /C<show_mail_from_moderation_queue> >> method,
230             printing one message held for moderation; the identifier is expected
231             as a positional parameter.
232              
233             =item C<resume-held>
234              
235             $ sietima resume-held 32946p6eu7867
236              
237             Invokes the L<< /C<resume> >> method, causing the held message to be
238             processed normally; the identifier is expected as a positional
239             parameter.
240              
241             =item C<drop-held>
242              
243             $ sietima drop-held 32946p6eu7867
244              
245             Invokes the L<< /C<drop> >> method, removing the held message; the
246             identifier is expected as a positional parameter.
247              
248             =back
249              
250             =head1 AUTHOR
251              
252             Gianni Ceccarelli <dakkar@thenautilus.net>
253              
254             =head1 COPYRIGHT AND LICENSE
255              
256             This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>.
257              
258             This is free software; you can redistribute it and/or modify it under
259             the same terms as the Perl 5 programming language system itself.
260              
261             =cut