#!/usr/bin/perl
our $VERSION = '1.20170911'; # VERSION
use strict;
use warnings;
#use Data::Dumper;
use Encode;
use Getopt::Long;
use Sys::Syslog qw(:standard :macros);
#use XML::LibXML;
my $send_delay = 5;
my $batch_size = 1;
my $alarm_at = 120;
my $syslog = 0;
GetOptions (
'verbose+' => \my $verbose,
'delay=i' => \$send_delay,
'batch=i' => \$batch_size,
'timeout=i' => \$alarm_at,
'syslog+' => \$syslog,
);
openlog( 'dmarc_send_reports', 'pid', LOG_MAIL ) if $syslog;
syslog( LOG_INFO, 'dmarc_send_reports starting up' ) if $syslog;
$|++;
use lib 'lib';
use Mail::DMARC::Report;
my $report = Mail::DMARC::Report->new();
$report->verbose($verbose) if defined $verbose;
#my $schema = 'http://dmarc.org/dmarc-xml/0.1/rua.xsd';
#my $xmlschema = XML::LibXML::Schema->new( location => $schema );
my $dkim_key;
if ( $report->config->{report_sign}->{keyfile} ) {
eval {
require Mail::DKIM::PrivateKey;
require Mail::DKIM::Signer;
require Mail::DKIM::TextWrap;
};
if ( UNIVERSAL::can( 'Mail::DKIM::Signer', "new" ) ) {
my $file = $report->config->{report_sign}->{keyfile};
$dkim_key = Mail::DKIM::PrivateKey->load(
'File' => $file,
);
if ( ! $dkim_key ) {
die "Could not load DKIM key $file";
}
}
else {
die 'DKIM signing requested but Mail::DKIM could not be loaded. Please check that Mail::DKIM is installed.';
}
syslog( LOG_INFO, 'DKIM signing key loaded' ) if $syslog;
}
local $SIG{'ALRM'} = sub{ die "timeout\n" };
my $todo_reports = $report->store->retrieve_todo();
my $batch_do = 1;
# 1. get reports, one at a time
REPORT:
foreach my $aggregate ( @{ $todo_reports } ) {
eval {
send_single_report( $aggregate, $report );
};
if ( my $error = $@ ) {
print "Sending error $error\n" if $verbose;
syslog( LOG_INFO, 'error sending report: ' . $error ) if $syslog;
}
if ( $batch_do++ > $batch_size ) {
$batch_do = 1;
if ( $send_delay > 0 ) {
print "sleeping $send_delay" if $verbose;
foreach ( 1 .. $send_delay ) { print '.' if $verbose; sleep 1; };
print "done.\n" if $verbose;
}
}
}
alarm(0);
syslog( LOG_INFO, 'dmarc_send_reports done' ) if $syslog;
closelog() if $syslog;
exit;
# PODNAME: dmarc_send_reports
# ABSTRACT: send aggregate reports
sub send_single_report {
my ( $aggregate, $report ) = @_;
alarm($alarm_at);
print 'ID: ' . $aggregate->metadata->report_id . "\n" if $verbose;
print 'Domain: ' . $aggregate->policy_published->domain . "\n" if $verbose;
print 'rua: ' . $aggregate->policy_published->rua . "\n" if $verbose;
log_to_syslog({
'id' => $aggregate->metadata->report_id,
'domain' => $aggregate->policy_published->domain,
'rua' => $aggregate->policy_published->rua,
});
my $xml = $aggregate->as_xml();
# warn $xml; ## no critic (Carp)
# my $dom = XML::LibXML->load_xml( string => (\$xml) );
# eval { $xmlschema->validate( $dom ); };
# die "$@" if $@;
my $shrunk = $report->compress(\$xml);
my $bytes = length Encode::encode_utf8($shrunk);
my $uri_ref;
eval {
$uri_ref = $report->uri->parse( $aggregate->policy_published->rua );
};
if ( my $error = $@ ) {
print "No valid ruas found, deleting report\n" if $verbose;
log_to_syslog({
'id' => $aggregate->metadata->report_id,
'error' => 'No valid ruas found - deleting report - ' . $error,
});
$report->store->delete_report($aggregate->metadata->report_id);
alarm(0);
return;
}
if ( scalar @{ $uri_ref } == 0 ) {
print "No valid ruas found, deleting report\n" if $verbose;
log_to_syslog({
'id' => $aggregate->metadata->report_id,
'error' => 'No valid ruas found - deleting report',
});
$report->store->delete_report($aggregate->metadata->report_id);
alarm(0);
return;
}
my $sent = 0;
my $cc_sent = 0;
my @too_big;
URI:
foreach my $u_ref (@$uri_ref) {
my $method = $u_ref->{uri};
my $max = $u_ref->{max_bytes};
if ( $max && $bytes > $max ) {
log_to_syslog({
'id' => $aggregate->metadata->report_id,
"info' => 'skipping $method: report size ($bytes) larger than $max",
});
print "skipping $method: report size ($bytes) larger than $max\n" if $verbose;
push @too_big, $method;
next URI;
}
if ( 'mailto:' eq substr( $method, 0, 7 ) ) {
my ($to) = ( split /:/, $method )[-1];
my $cc = $report->config->{smtp}{cc};
if ( $cc && $cc ne 'set.this@for.a.while.example.com' && ! $cc_sent ) {
email( $cc, $shrunk, \$aggregate );
$cc_sent = 1;
};
email( $to, $shrunk, \$aggregate ) and $sent++;
}
if ( 'http:' eq substr( $method, 0, 5 ) ) {
#$report->sendit->http->post( $method, \$aggregate, $shrunk ) and $sent++;
$report->sendit->http->post( $method, \$aggregate, $shrunk );
# http sending not yet enabled in module, skip this send and
# increment sent to avoid looping
$sent++;
}
}
if ( $sent ) {
$report->store->delete_report($aggregate->metadata->report_id);
}
else {
send_too_big_email(\@too_big, $bytes, $aggregate);
};
alarm(0);
return;
}
sub send_too_big_email {
my ($too_big, $bytes, $aggregate) = @_;
BIGURI:
foreach my $uri (@$too_big) {
next BIGURI if 'mailto:' ne substr( $uri, 0, 7 );
my ($to) = ( split /:/, $uri )[-1];
my $body = $report->sendit->too_big_report(
{ uri => $uri,
report_bytes => $bytes,
report_id => $aggregate->metadata->report_id,
report_domain=> $aggregate->policy_published->domain,
}
);
email( $to, $body );
};
return;
};
sub get_smtp_connection {
my ($to, $shrunk, $agg_ref) = @_;
my $rid;
$rid = $$agg_ref->metadata->report_id if $agg_ref;
my $smtp = $report->sendit->smtp->connect_smtp_tls( $to ) or do {
warn "\tSSL connection failed\n"; ## no critic (Carp)
log_to_syslog({
'id' => $rid,
'error' => 'SSL connection failed',
});
if ( $agg_ref ) {
$$agg_ref->metadata->error("SSL connection failed");
my $xml = $$agg_ref->as_xml(); # re-export XML, with error
$shrunk = $report->compress(\$xml);
};
};
if ( ! $smtp ) {
$smtp = $report->sendit->smtp->connect_smtp( $to ) or do {
warn "\tSMTP connection failed\n"; ## no critic (Carp)
log_to_syslog({
'id' => $rid,
'error' => 'SMTP connection failed',
});
if ( $rid ) {
my $errors = scalar $$agg_ref->metadata->error;
if ( $errors >= 12 ) {
print "Report $rid deleted (too many errors)\n" if $verbose;
log_to_syslog({
'id' => $rid,
'error' => 'Report deleted, too many errors',
});
$report->store->delete_report($rid);
}
else {
$report->store->error($rid, "SSL connection for $to failed");
$report->store->error($rid, "SMTP connection for $to failed");
log_to_syslog({
'id' => $rid,
'errorcount' => $errors,
});
};
};
return;
};
};
if ( ! $smtp ) {
warn "\t0 MX available\n";
log_to_syslog({
'id' => $rid,
'info' => '0 MX available',
});
return;
};
return $smtp;
};
sub email {
my ($to, $shrunk, $agg_ref) = @_;
my $rid;
$rid = $$agg_ref->metadata->report_id if $agg_ref;
my $smtp;
eval {
$smtp = get_smtp_connection($to,$shrunk,$agg_ref) or return;
};
if ( my $error = $@ ) {
print "error ".$error."\n" if $verbose;
log_to_syslog({
'id' => $rid,
'deliver_to' => $to,
'error' => $error,
});
$report->store->error($rid, $error);
return;
}
return if ! $smtp;
print "delivering message to $to, via ".$smtp->host."\n" if $verbose;
log_to_syslog({
'id' => $rid,
'deliver_to' => $to,
'smtp_via' => $smtp->host,
});
my $from = $report->config->{organization}{email};
$smtp->mail($from) or do {
my $err = $smtp->code ." ". $smtp->message;
print "MAIL FROM $from rejected\n\t$err\n" if $verbose;
log_to_syslog({
'id' => $rid,
'mail_from' => $from,
'smtp_error' => $err,
});
$report->store->error($rid, $err) if $rid;
$smtp->quit;
return;
};
$smtp->recipient( $to ) or do {
my $err = $smtp->code ." ". $smtp->message;
print "RCPT TO $to rejected\n\t$err\n" if $verbose;
log_to_syslog({
'id' => $rid,
'rcpt_to' => $to,
'smtp_error' => $err,
});
if ( $rid ) {
if ( $smtp->code =~ /^5/ ) { # SMTP 5XX error
print "Report $rid deleted \n" if $verbose;
log_to_syslog({
'id' => $rid,
'error' => 'Report deleted',
'smtp_code' => $smtp->code,
});
$report->store->delete_report($rid);
}
else {
$report->store->error($rid, $err);
};
};
$smtp->quit;
return;
};
my $body = $shrunk;
if ( $rid ) {
$body = $report->sendit->smtp->assemble_message($agg_ref, $to, $shrunk);
};
if ( $dkim_key ) {
my $dkim_algorithm = $report->config->{report_sign}{algorithm};
my $dkim_method = $report->config->{report_sign}{method};
my $dkim_domain = $report->config->{report_sign}{domain};
my $dkim_selector = $report->config->{report_sign}{selector};
eval {
my $dkim = Mail::DKIM::Signer->new(
Algorithm => $dkim_algorithm,
Method => $dkim_method,
Domain => $dkim_domain,
Selector => $dkim_selector,
Key => $dkim_key,
);
$body =~ s/\015?\012/\015\012/g;
$dkim->PRINT( $body );
$dkim->CLOSE;
my $signature = $dkim->signature;
$body = $signature->as_string . "\015\012" . $body;
};
if ( my $error = $@ ) {
print "DKIM Signing error\n\t$error\n" if $verbose;
log_to_syslog({
'id' => $rid,
'error' => 'DKIM Signing error',
'error_detail' => $error,
});
$smtp->quit;
return;
}
}
$smtp->data($body) or do {
my $err = $smtp->code ." ". $smtp->message;
if ( $agg_ref ) {
my $to_domain = $$agg_ref->policy_published->domain;
print "DATA for domain $to_domain report rejected\n\t$err\n" if $verbose;
log_to_syslog({
'id' => $rid,
'error' => 'DATA rejected',
'to_domain' => $to_domain,
'error_detail' => $err,
});
}
else {
print "DATA for report rejected\n\t$err\n" if $verbose;
log_to_syslog({
'id' => $rid,
'error' => 'DATA rejected',
'error_detail' => $err,
});
};
$report->store->error($rid, $err) if $rid;
return;
};
my @accepts = $smtp->message;
my $accept = $smtp->code . ' ' . pop @accepts;
$accept =~ s/\r$//;
print "SMTP accepted\n\t$accept\n" if $verbose;
log_to_syslog({
'id' => $rid,
'smtp_accept' => $accept,
});
$smtp->quit;
return 1;
}
sub log_to_syslog {
my ( $args ) = @_;
return if ! $syslog;
my $log_level = LOG_INFO;
if ( $args->{'log_level'} ) {
$log_level = $args->{'log_level'};
delete $args->{'log_level'};
}
my @parts;
foreach my $key ( sort keys %$args ) {
my $value = $args->{ $key };
$value =~ s/,/#044/g; # Encode commas
push @parts, join( '=', $key, $value );
}
syslog( $log_level, join( ', ', @parts ) );
return;
}
__END__
=pod
=head1 NAME
dmarc_send_reports - send aggregate reports
=head1 VERSION
version 1.20170911
=head1 AUTHORS
=over 4
=item *
Matt Simerson <msimerson@cpan.org>
=item *
Davide Migliavacca <shari@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2015 by Matt Simerson.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut