package Mail::Abuse::Processor::Mailer;
require 5.005_62;
use Carp;
use strict;
use warnings;
use IO::File;
use Mail::Mailer;
use base 'Mail::Abuse::Processor';
use constant ANTILOOP => 'X-Mail-Abuse-Loop';
# The code below should be in a single line
our $VERSION = do { my @r = (q$Revision: 1.9 $ =~ /\d+/g); sprintf " %d."."%03d" x $#r, @r };
=pod
=head1 NAME
Mail::Abuse::Processor::Mailer - Handle the email response to a Mail::Abuse::Report
=head1 SYNOPSIS
use Mail::Abuse::Processor::Mailer;
use Mail::Abuse::Report;
my $p = new Mail::Abuse::Processor::Mailer;
my $report = new Mail::Abuse::Report (processors => [ $p ]);
# ... other pieces of code that configure the report ...
=head1 DESCRIPTION
This class handles automatic email responses sent to the originator of
the Mail::Abuse::Report. Mail loops are avoided and detected by
inserting a special header, B<X-Mail-Abuse-Loop>. If this header is
present, no messages will be sent.
The following configuration keys control the behavior of this module.
=over
=item B<debug mailer>
If set to a true value, causes this module to emit debugging info
using C<warn()>.
=cut
use constant DEBUG => 'debug mailer';
=pod
=item B<mailer type>
The type of mailer to use, as described in C<Mail::Mailer>. Defaults
to B<mail>.
=cut
use constant TYPE => 'mailer type';
=pod
=item B<mailer smtp server>
Some types of mailers require the specification of an SMTP
server. This option allows for it.
=cut
use constant SMTP => 'mailer smtp server';
=pod
=item B<mailer from>
The complete RFC-2822 address to be used in the B<From:> header placed
in the message header. It B<must> be specified.
=cut
use constant FROM => 'mailer from';
=pod
=item B<mailer reply to>
The B<Reply-To:> header to use in the message header of the reply. The
header will not be included if left unspecified.
=cut
use constant REPLYTO => 'mailer reply to';
=pod
=item B<mailer errors to>
The B<Errors-To:> header to use in the message header of the reply. The
header will not be included if left unspecified.
=cut
use constant ERRORSTO => 'mailer errors to';
=pod
=item B<mailer forced to>
If this value is set, the response message is directed to the given
address.
=cut
use constant FORCED => 'mailer forced to';
=pod
=item B<mailer subject>
The subject to use in the responses.
=cut
use constant SUBJECT => 'mailer subject';
=pod
=item B<mailer precedence>
The precedence to use. Defaults to 'bulk'.
=cut
use constant PRECEDENCE => 'mailer precedence';
=pod
=item B<mailer fail message>
The name of the file containing the message template that will be used
to compose a message whenever no incidents can be parsed or pass the
filters from the abuse report. This distribution includes an example
message in the C<etc/> subdirectory.
=cut
use constant FAIL => 'mailer fail message';
=pod
=item B<mailer success message>
The name of the file containing the message template that will be used
to compose a message when one or more incidents are parsed and
filtered from the abuse report.. This distribution includes an example
message in the C<etc/> subdirectory.
=cut
use constant SUCCESS => 'mailer success message';
=pod
=item B<mailer charset>
The charset used to encode the response. Defaults to 'US-ASCII'. This
is placed in the B<charset=> part of the MIME headers.
=cut
use constant CHARSET => 'mailer charset';
=pod
=back
The following functions are implemented.
=over
=item C<process($report)>
Takes a C<Mail::Abuse::Report> object as an argument and performs the
processing action required. MIME headers inserted by this module,
force encoding to 8bit.
=cut
sub process
{
my $self = shift;
my $rep = shift;
unless ($rep->config or ref $rep->config ne 'HASH')
{
warn "Invalid or no config";
return;
}
my $fail = $rep->config->{&FAIL};
my $from = $rep->config->{&FROM};
my $smtp = $rep->config->{&SMTP};
my $debug = $rep->config->{&DEBUG};
my $forced = $rep->config->{&FORCED};
my $success = $rep->config->{&SUCCESS};
my $replyto = $rep->config->{&REPLYTO};
my $subject = $rep->config->{&SUBJECT};
my $errors = $rep->config->{&ERRORSTO};
my $preced = $rep->config->{&PRECEDENCE} || 'bulk';
my $type = $rep->config->{&TYPE} || 'mail';
my $charset = $rep->config->{&CHARSET} || 'US-ASCII';
unless ($fail and $success and -f $fail and -f $success)
{
warn "M::A::P::Mailer: Failure and success templates must be defined\n";
return;
}
unless ($from)
{
warn "M::A::P::Mailer: No ", &FROM, " entry found in the config file";
return;
}
if (($rep->normalized && $rep->header->get(&ANTILOOP))
or (!$rep->normalized && $rep->text =~ m/^\s*&{ANTILOOP}:\s/m))
{
warn "M::A::P::Mailer: Loop detected and avoided\n" if $debug;
return;
}
# Detect and avoid loops
my $mailer;
if (defined $smtp)
{
$mailer = new Mail::Mailer $type, Server => $smtp;
}
else
{
$mailer = new Mail::Mailer $type;
}
my %Headers = (
'X-Mailer' => __PACKAGE__ . " v$VERSION",
&ANTILOOP => scalar localtime,
'MIME-Version' => '1.0',
'Content-Type' => qq{text/plain; charset="$charset"},
'Content-Transfer-Encoding' => '8bit',
'From' => $from,
);
$Headers{'Reply-To'} = $replyto if $replyto;
$Headers{'Errors-To'} = $errors if $errors;
$Headers{'Subject'} = $subject if $subject;
$Headers{'Precedence'} = $preced;
if ($rep->normalized)
{
$Headers{To} = $rep->header->get('Reply-To')
|| $rep->header->get('From');
}
else
{
if ($ {$rep->text} =~ m/Reply-To: (.*)$/m)
{
$Headers{To} = $1;
}
elsif ($ {$rep->text} =~ m/From: (.*)$/m)
{
$Headers{To} = $1;
}
}
unless ($Headers{To})
{
warn "M::A::P::Mailer: Cannot determine destination address\n";
return;
}
chomp $Headers{To};
if ($forced)
{
warn "M::A::P::Mailer: Changing recipient from $Headers{To} ",
"to $forced\n";
$Headers{'X-Mail-Abuse-Original-To'} = $Headers{To};
$Headers{To} = $forced;
}
my $fh = new IO::File;
if ($rep->incidents and @ {$rep->incidents} > 0)
{
# Found an incident, so
# declare it a success
unless ($fh->open($success, "r"))
{
warn "M::A::P::Mailer: Cannot open success template $success\n";
return;
}
}
else
{
# No incidents are applicable
unless ($fh->open($fail, "r"))
{
warn "M::A::P::Mailer: Cannot open fail template $fail\n";
return;
}
}
$mailer->open(\%Headers);
{
local $/ = undef;
print $mailer (<$fh>);
};
$fh->close;
return $mailer->close;
}
__END__
=pod
=back
=head2 EXPORT
None by default.
=head1 HISTORY
=over 8
=item 0.01
Original version; created by h2xs 1.2 with options
-ACOXcfkn
Mail::Abuse
-v
0.01
=back
=head1 LICENSE AND WARRANTY
This code and all accompanying software comes with NO WARRANTY. You
use it at your own risk.
This code and all accompanying software can be used freely under the
same terms as Perl itself.
=head1 AUTHOR
Luis E. Muñoz <luismunoz@cpan.org>
=head1 SEE ALSO
perl(1).
=cut