—

              
#!/usr/bin/perl
our $VERSION = '1.20160612'; # 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";
    print 'Domain: ' . $aggregate->policy_published->domain . "\n";
    print 'rua:    ' . $aggregate->policy_published->rua . "\n";
    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";
       log_to_syslog({
            'id'    =>  $aggregate->metadata->report_id,
            'error' => 'No valid ruas found - deleting reporti - ' . $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";
       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 ) {
# TODO: try compressing the report with gzip -9 ?
           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";
            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);
}
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";
                    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";
        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";
    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";
        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";
        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";
                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";
            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";
            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";
            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";
    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__
HideShow 33 lines of Pod
=pod
=head1 NAME
dmarc_send_reports - send aggregate reports
=head1 VERSION
version 1.20160612
=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