File Coverage

blib/lib/Mail/Qmail/Filter.pm
Criterion Covered Total %
statement 34 82 41.4
branch 1 32 3.1
condition 0 18 0.0
subroutine 13 20 65.0
pod 7 7 100.0
total 55 159 34.5


line stmt bran cond sub pod time code
1 1     1   2358 use 5.014;
  1         3  
2 1     1   6 use warnings;
  1         1  
  1         99  
3              
4             package Mail::Qmail::Filter;
5              
6             our $VERSION = '1.31';
7              
8 1     1   7 use Carp qw(confess);
  1         2  
  1         79  
9 1     1   467 use FindBin ();
  1         1045  
  1         23  
10 1     1   568 use IO::Handle ();
  1         6355  
  1         26  
11 1     1   468 use Mail::Qmail::Filter::Util qw(addresses_to_hash match_address);
  1         2  
  1         64  
12 1     1   456 use MailX::Qmail::Queue::Message;
  1         4  
  1         40  
13 1     1   7 use Scalar::Util qw(blessed);
  1         2  
  1         61  
14              
15 1     1   526 use namespace::clean;
  1         16344  
  1         7  
16              
17             # Must be under namespace::clean for coercion to work:
18 1     1   781 use Mo qw(coerce default);
  1         553  
  1         7  
19              
20             my $feedback_fh; # Open ASAP before the handle gets reused:
21              
22             BEGIN {
23 1 50   1   1789 $feedback_fh = IO::Handle->new_from_fd( 4, 'w' )
24             or warn "Cannot open feedback handle: $!";
25             }
26              
27             has 'defer_only';
28             has 'feedback_fh' => $feedback_fh;
29             has 'filters' => [];
30             has 'reject_text' => 'Rejected.';
31             has 'skip_if';
32             has 'skip_for_from' => coerce => \&addresses_to_hash;
33             has 'skip_for_rcpt' => coerce => \&addresses_to_hash;
34             has 'skip_for_sender' => coerce => \&addresses_to_hash;
35             has 'skip_if_relayclient';
36              
37             my @debug;
38              
39             sub debug {
40 1     1 1 2 my $self = shift;
41 1         5 push @debug, join ': ', @_;
42             }
43              
44             $SIG{__DIE__} //= sub {
45             return if $^S || !defined $^S;
46             __PACKAGE__->debug( died => "@_" );
47             die @_;
48             };
49              
50             sub add_filters {
51 0     0 1   my $self = shift;
52 0           while ( defined( my $filter = shift ) ) {
53 0 0         unless ( blessed($filter) ) {
54 0 0 0       my $opt = shift if @_ && 'HASH' eq ref $_[0];
55 0 0         $filter = __PACKAGE__ . $filter if $filter =~ /^::/;
56 0           eval "use $filter";
57 0 0         confess $@ if length $@;
58 0           $filter = $filter->new(%$opt);
59             }
60 0           push @{ $self->{filters} }, $filter;
  0            
61             }
62 0           $self;
63             }
64              
65             sub defer {
66 0     0 1   my $self = shift;
67 0           $self->debug( action => 'defer' );
68 0           $self->_exit( Z => @_ );
69             }
70              
71             sub filter {
72 0     0 1   my $self = shift;
73              
74 0           $_->run for @{ $self->filters };
  0            
75             }
76              
77             sub message {
78 0 0   0 1   state $message = MailX::Qmail::Queue::Message->receive
79             or die "Invalid message\n";
80             }
81              
82             sub reject {
83 0     0 1   my $self = shift;
84 0           $self->debug( action => 'reject' );
85 0 0         $self->_exit( $self->defer_only ? 'Z' : 'D', @_ );
86             }
87              
88             sub run {
89 0     0 1   my $self = shift;
90              
91 0           my $package = ref $self;
92              
93 0 0 0       return if $self->skip_if && $self->skip_if->($self);
94              
95 0 0 0       if ( exists $ENV{RELAYCLIENT} && $self->skip_if_relayclient ) {
96 0           $self->debug("$package skipped");
97 0           return;
98             }
99              
100 0 0         if ( my $skip_for_sender = $self->skip_for_sender ) {
101 0 0         if (
102             match_address(
103             $skip_for_sender, my $sender = $self->message->from
104             )
105             )
106             {
107 0           $self->debug( "$package skipped because of sender", $sender );
108 0           return;
109             }
110             }
111              
112 0 0 0       if ( ( my $skip_for_from = $self->skip_for_from )
113             && ( my $from = $self->message->header_from ) )
114             {
115 0 0         if ( match_address( $skip_for_from, $from = $from->address ) ) {
116 0           $self->debug( "$package skipped because of RFC5322.From", $from );
117 0           return;
118             }
119             }
120              
121 0 0         if ( my $skip_for_rcpt = $self->skip_for_rcpt ) {
122 0           for ( $self->message->to ) {
123 0 0         next unless match_address( $skip_for_rcpt, $_ );
124 0           $self->debug( "$package skipped because of rcpt", $_ );
125 0           return;
126             }
127             }
128              
129 0           $self->debug("$package started");
130 0           $self->filter;
131             }
132              
133             sub _exit {
134 0     0     my $self = shift;
135 0           my $status = shift;
136 0   0       my $reject_text = shift // $self->reject_text;
137 0 0 0       $reject_text = $reject_text->(@_)
138             if ref $reject_text && 'CODE' eq ref $reject_text;
139 0           $self->feedback_fh->print( $status, $reject_text =~ y/\n/ /r );
140 0           exit 88;
141             }
142              
143             END {
144 1     1   997 __PACKAGE__->debug( 'exit code' => $? );
145 1         53 say STDERR "$FindBin::Script\[$$]: " . join '; ', @debug;
146             }
147              
148             __END__
149              
150             =head1 NAME
151              
152             Mail::Qmail::Filter - filter e-mails in qmail-queue context
153              
154             =head1 SYNOPSIS
155              
156             use Mail::Qmail::Filter;
157            
158             Mail::Qmail::Filter->new->add_filter(
159             '::LogEnvelope',
160             '::DMARC' => {
161             skip_if_relayclient => 1,
162             },
163             '::CheckDeliverability' => {
164             match => qr{/ezmlm-(?:checksub|reject)\b},
165             skip_if_relayclient => 1,
166             },
167             '::SpamAssassin' => {
168             skip_if_relayclient => 1,
169             reject_score => 5.2,
170             reject_text => 'I think your message is spam.',
171             },
172             '::Queue',
173             )->run;
174              
175             =head1 DESCRIPTION
176              
177             Mail::Qmail::Filter and its submodules are designed to help you filter
178             incoming e-mails when using L<qmail|http://netqmail.org/> as MTA.
179              
180             You should use it like so:
181              
182             =over 4
183              
184             =item 1.
185              
186             Write a frontend script to configure your filters,
187             like the one in the L</SYNOPSIS>.
188              
189             =item 2.
190              
191             In the run file for your C<qmail-smtpd> instance,
192             e.g. C</var/qmail/supervise/qmail-smtpd/run>,
193              
194             export QMAILQUEUE=path_to_your_frontend_script
195              
196             =back
197              
198             In each filter, you may do various things:
199              
200             =over 4
201              
202             =item *
203              
204             examine and change envelope data (RFC5321.MailFrom and recipients)
205              
206             =item *
207              
208             examine and modify the e-mail message (header and/or body)
209              
210             =item *
211              
212             L</reject> e-mails (or L<defer|/defer_only> them)
213              
214             =back
215              
216             =head1 FILTERS INCLUDED
217              
218             This distribution ships with the following predefined filters:
219              
220             =head2 Queueing the message
221              
222             Usually you want to use L<Mail::Qmail::Filter::Queue> as the last
223             filter in your chain to pass the message on to C<qmail-queue>,
224             because if you don't, the message will be discarded.
225              
226             =head2 Rejecting filters
227              
228             =over 4
229              
230             =item L<Mail::Qmail::Filter::CheckDeliverability>
231              
232             check deliverability according to .qmail files
233              
234             =item L<Mail::Qmail::Filter::DMARC>
235              
236             validate message against DMARC policy of the sender domain
237              
238             =item L<Mail::Qmail::Filter::RequireFrom>
239              
240             only allow certain RFC322.From addresses
241              
242             =item L<Mail::Qmail::Filter::SpamAssassin>
243              
244             spam-check message
245              
246             =item L<Mail::Qmail::Filter::ClamAV>
247              
248             scan message for viruses
249              
250             =item L<Mail::Qmail::Filter::ValidateFrom>
251              
252             validate RFC5322.From
253              
254             =item L<Mail::Qmail::Filter::ValidateSender>
255              
256             validate RFC5321.MailFrom
257              
258             =back
259              
260             =head2 Envelope modifying filters
261              
262             =over 4
263              
264             =item L<Mail::Qmail::Filter::RewriteSender>
265              
266             =back
267              
268             =head2 Header modifying filters
269              
270             =over 4
271              
272             =item L<Mail::Qmail::Filter::RewriteFrom>
273              
274             =back
275              
276             =head2 Logging-only filters
277              
278             =over 4
279              
280             =item L<Mail::Qmail::Filter::Dump>
281              
282             =item L<Mail::Qmail::Filter::LogEnvelope>
283              
284             =back
285              
286             =head2 Experimental filters
287              
288             =over 4
289              
290             =item L<Mail::Qmail::Filter::SkipQueue>
291              
292             =back
293              
294             =head1 COMMON PARAMETERS FOR ALL FILTERS
295              
296             =head2 skip_if
297              
298             When given a sub routine as an argument, executes this sub routine,
299             passing the filter as only parameter.
300             If the sub routine returns a true value, the rest of the filter is skipped.
301              
302             =head2 skip_if_relayclient
303              
304             When set to a true value, the L</run> method will skip the filter when
305             the environment variable C<RELAYCLIENT> exists.
306              
307             =head2 skip_for_sender
308              
309             Takes an e-mail address or a reference to a list of such.
310             The L</run> method will then skip the filter if the RFC5321.MailFrom address
311             of the L</message> is one of these.
312              
313             =head2 skip_for_from
314              
315             Takes an e-mail address or a reference to a list of such.
316             The L</run> method will then skip the filter if the RFC5322.From address
317             of the L</message> is one of these.
318              
319             =head2 skip_for_rcpt
320              
321             Takes an e-mail address or a reference to a list of such.
322             The L</run> method will then skip the filter if at least one of the recipients
323             in the envelope of the L</message> is one of these.
324              
325             =head2 defer_only
326              
327             When set to a true value, calls to the L</reject> method will
328             result in status code C<451>, that is, the message should only
329             be deferred on the sender side.
330              
331             =head1 METHODS
332              
333             =head2 add_filters
334              
335             Configure the filters you want to use.
336             Takes a list of filter packages to run in order.
337              
338             You may pass instances of filter objects here,
339             but usually it is more convenient to specify filters using their package name,
340             optionally followed by a hash of options.
341             C<add_filters> will then construct the filter object for you.
342             If your filter lives below the C<Mail::Qmail::Filter::> namespace,
343             you may abbreviate this prefix with C<::>.
344             Please see example in the L</SYNOPSIS> above.
345              
346             C<add_filters> may be called several times to add more and more filters,
347             but you can also just specify them all in one call.
348              
349             C<add_filters> will return the main L<Mail::Qmail::Filter> object,
350             so you may chain other methods, like L</run>.
351              
352             =head2 run
353              
354             checks if the filter should be skipped by evaluating the
355             L</OPTIONS COMMON TO ALL FILTERS>.
356             If not, runs it by calling its L</filter> method.
357              
358             =head2 filter
359              
360             Does the actual work:
361             Reads the message from C<qmail-smtpd>,
362             runs the filters which where L<added|/-E<gt>add_filters>
363             and if has not been L</reject>ed,
364             forwards the message to C<qmail-queue>.
365              
366             When L</WRITING YOUR OWN FILTERS>, overwrite this method
367             with what your filter is supposed to do.
368              
369             =head2 message
370              
371             returns the L<MailX::Qmail::Queue::Message> to be filtered
372              
373             =head2 reject
374              
375             rejects the message with status C<554> (default)
376             or with C<451> when L</defer_only> is set.
377             Stops the execution of the script; no further filters will be run,
378             and the message will I<not> be passed on to C<qmail-queue>.
379              
380             As first argument, expects the reply text the server should send to the client
381             or a L<sub|perlfunc/sub>routine which returns this reply text.
382             Additional arguments will be passed to this L<sub|perlfunc/sub>routine,
383             which is handy if you for example want to include an e-mail address which
384             caused the rejection.
385              
386             Please note that you should only use ASCII characters for the reply text and
387             that C<qmail-smtpd> usually limits its length to 254 characters.
388              
389             =head2 defer
390              
391             defers the message with status C<451>,
392             just like L</reject> would when L</defer_only> is set.
393             Everything else that is said above about L</reject> also applies to L</defer>.
394              
395             =head2 debug
396              
397             collects logging messages.
398             When the script finishes,
399             these will be automatically written to standard error, separated with C<; >s.
400             You should then find them in the log file of your C<qmail-smtpd>,
401             prefixed with the name of your frontend script.
402              
403             When passing several arguments, these will be L<joined|perlfunc/join> with
404             C<: >.
405              
406             =head1 WRITING YOUR OWN FILTERS
407              
408             For the L</COMMON OPTIONS FOR ALL FILTERS> to work properly,
409             your package has to:
410              
411             use Mo 'coerce';
412             extends 'Mail::Qmail::Filter';
413              
414             Apart from that, you only have to define a filter method
415             which does the actual work.
416              
417             For further insight, please have a look at the source code of the various
418             L</FILTERS INCLUDED> in this distribution.
419              
420             =head1 SEE ALSO
421              
422             L<MailX::Qmail::Queue::Message> and the L<FILTERS INCLUDED>.
423              
424             =head1 LICENSE AND COPYRIGHT
425              
426             Copyright 2019 Martin Sluka.
427              
428             This module is free software; you can redistribute it and/or modify it
429             under the terms of the the Artistic License (2.0). You may obtain a
430             copy of the full license at:
431              
432             L<http://www.perlfoundation.org/artistic_license_2_0>
433              
434             Any use, modification, and distribution of the Standard or Modified
435             Versions is governed by this Artistic License. By using, modifying or
436             distributing the Package, you accept this license. Do not use, modify,
437             or distribute the Package, if you do not accept this license.
438              
439             If your Modified Version has been derived from a Modified Version made
440             by someone other than you, you are nevertheless required to ensure that
441             your Modified Version complies with the requirements of this license.
442              
443             This license does not grant you the right to use any trademark, service
444             mark, tradename, or logo of the Copyright Holder.
445              
446             This license includes the non-exclusive, worldwide, free-of-charge
447             patent license to make, have made, use, offer to sell, sell, import and
448             otherwise transfer the Package with respect to any patent claims
449             licensable by the Copyright Holder that are necessarily infringed by the
450             Package. If you institute patent litigation (including a cross-claim or
451             counterclaim) against any party alleging that the Package constitutes
452             direct or contributory patent infringement, then this Artistic License
453             to you shall terminate on the date that such litigation is filed.
454              
455             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
456             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
457             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
458             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
459             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
460             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
461             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
462             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
463              
464             =cut