The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
our $VERSION = '1.20150123'; # VERSION
use strict;
use warnings;

#use Data::Dumper;
use Encode;
use Getopt::Long;
#use XML::LibXML;

my $send_delay = 5;

GetOptions (
    'verbose+'   => \my $verbose,
    'delay=i'    => \$send_delay,
);

$|++;
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 );

# 1. get reports, one at a time
while (defined(my $aggregate = $report->store->retrieve_todo ) ) {

    print "ID: " . $aggregate->metadata->report_id . "\n";
    print $aggregate->policy_published->domain . "\n";
    print "rua:\t" . $aggregate->policy_published->rua . "\n";

    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 = $report->uri->parse( $aggregate->policy_published->rua );

    if ( scalar @{ $uri_ref } == 0 ) {
        print "No valid ruas found, deleting report\n";
        $report->store->delete_report($aggregate->metadata->report_id);
        next;
    }

    my $sent    = 0;
    my $cc_sent = 0;
    my @too_big;
    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 ?
            print "skipping $method: report size ($bytes) larger than $max\n";
            push @too_big, $method;
            next;
        }

        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++;
        }
    }

    if ( $sent ) {
        $report->store->delete_report($aggregate->metadata->report_id);
    }
    else {
        send_too_big_email(\@too_big, $bytes, $aggregate);
    };

    if ( $send_delay > 0 ) {
        print "sleeping $send_delay";
        foreach ( 1 .. $send_delay ) { print '.'; sleep 1; };
        print "done.\n";
    }
};

exit;
# PODNAME: dmarc_send_reports
# ABSTRACT: send aggregate reports

sub send_too_big_email {
    my ($too_big, $bytes, $aggregate) = @_;

    foreach my $uri (@$too_big) {
        next 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 $smtp = $report->sendit->smtp->connect_smtp_tls( $to ) or do {
        warn "\tSSL connection failed\n";  ## no critic (Carp)
        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);
        };
    };

    my $rid;
    $rid = $$agg_ref->metadata->report_id if $agg_ref;
    if ( ! $smtp ) {
        $smtp = $report->sendit->smtp->connect_smtp( $to ) or do {
            warn "\tSMTP connection failed\n";  ## no critic (Carp)
            if ( $rid ) {
                my $errors = scalar $$agg_ref->metadata->error;
                if ( $errors >= 12 ) {
                    print "Report $rid deleted (too many errors)\n";
                    $report->store->delete_report($rid);
                }
                else {
                    $report->store->error($rid, "SSL connection for $to failed");
                    $report->store->error($rid, "SMTP connection for $to failed");
                };
            };
            return;
        };
    };

    if ( ! $smtp ) {
        warn "\t0 MX available\n";
        return;
    };

    return $smtp;
};

sub email {
    my ($to, $shrunk, $agg_ref) = @_;

    my $smtp = get_smtp_connection($to,$shrunk,$agg_ref) or return;
    print "delivering message to $to, via ".$smtp->host."\n";

    my $rid;
    $rid = $$agg_ref->metadata->report_id if $agg_ref;

    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";
        $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 ( $rid ) {
            if ( $smtp->code =~ /^5/ ) {  # SMTP 5XX error
                print "Report $rid deleted \n";
                $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);
    };

    $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";
        }
        else {
            print "DATA for report rejected\n\t$err\n";
        };
        $report->store->error($rid, $err) if $rid;
        return;
    };

    $smtp->quit;
    return 1;
}

__END__

=pod

=head1 NAME

dmarc_send_reports - send aggregate reports

=head1 VERSION

version 1.20150123

=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