Perl x Open Food Facts Hackathon: Paris, France - May 24-25 Learn more

MSIMERSON / Mail-DMARC-1.20130612 / bin / dmarc_send_reports 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
—
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155

              
#!/usr/bin/perl
our $VERSION = '1.20130612'; # VERSION
use strict;
use warnings;
#use Data::Dumper;
use Encode;
#use XML::LibXML;
$|++;
use lib 'lib';
use Mail::DMARC::Report;
my $report = Mail::DMARC::Report->new();
#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 );
    my $sent    = 0;
    foreach my $u_ref (@$uri_ref) {
        my $method = $u_ref->{uri};
        my $max    = $u_ref->{max_bytes};
        if ( $max && $bytes > $max ) {
            print "skipping $method: report size ($bytes) larger than $max\n";
            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' ) {
                email( $cc, $shrunk, \$aggregate );
            };
            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);
    };
    print "sleeping 5";
    foreach ( 1 .. 5 ) { print '.'; sleep 1; };
    print "done.\n";
};
exit;
# PODNAME: dmarc_send_reports
# ABSTRACT: send aggregate reports to requestors
sub email {
    my ($to, $shrunk, $agg_ref) = @_;
    my $smtp = $report->sendit->smtp->connect_smtp_tls( $to ) or do {
        warn "\tSSL connection failed\n";  ## no critic (Carp)
        $$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)
            return;
        };
    };
    if ( ! $smtp ) {
        warn "\t0 MX available\n";
        return;
    };
    print "delivering message to $to, via ".$smtp->host."\n";
    my $from = $report->config->{organization}{email};
    $smtp->mail($from) or do {
        print "MAIL FROM $from rejected\n";
        $smtp->quit;
        return;
    };
    $smtp->recipient( $to ) or do {
        print "RCPT TO $to rejected\n";
        $smtp->quit;
        return;
    };
    my $body = $report->sendit->smtp->assemble_message($agg_ref, $to, $shrunk);
    my $to_domain = $$agg_ref->policy_published->domain;
    $smtp->data($body) or do {
        print "DATA for domain $to_domain report rejected\n";
        return;
    };
    $smtp->quit;
    return 1;
}
__END__
=pod
=head1 NAME
dmarc_send_reports - send aggregate reports to requestors
=head1 VERSION
version 1.20130612
=head1 AUTHORS
=over 4
=item *
Matt Simerson <msimerson@cpan.org>
=item *
Davide Migliavacca <shari@cpan.org>
=back
=head1 CONTRIBUTOR
ColocateUSA.net <company@colocateusa.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by ColocateUSA.com.
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