File Coverage

lib/Mail/DMARC/Report/Receive.pm
Criterion Covered Total %
statement 53 239 22.1
branch 7 104 6.7
condition 4 25 16.0
subroutine 14 26 53.8
pod 5 14 35.7
total 83 408 20.3


line stmt bran cond sub pod time code
1             package Mail::DMARC::Report::Receive;
2 9     9   774 use strict;
  9         29  
  9         255  
3 9     9   45 use warnings;
  9         13  
  9         371  
4              
5             our $VERSION = '1.20230215';
6              
7 9     9   49 use Carp;
  9         28  
  9         479  
8 9     9   82 use Data::Dumper;
  9         17  
  9         474  
9 9     9   640 use Email::MIME;
  9         58152  
  9         235  
10 9     9   66 use Email::Simple;
  9         17  
  9         195  
11 9     9   59 use Encode;
  9         18  
  9         784  
12 9     9   6147 use IO::Uncompress::Unzip;
  9         192676  
  9         697  
13 9     9   4595 use IO::Uncompress::Gunzip;
  9         16689  
  9         481  
14 9     9   718 use XML::LibXML;
  9         31739  
  9         124  
15              
16 9     9   1543 use parent 'Mail::DMARC::Base';
  9         22  
  9         61  
17             require Mail::DMARC::Policy;
18             require Mail::DMARC::Report;
19             require Mail::DMARC::Report::Aggregate::Record;
20              
21             sub from_imap {
22 0     0 1 0 my $self = shift;
23 0         0 eval "require Net::IMAP::Simple"; ## no critic (Eval)
24 0 0       0 croak "Net::IMAP::Simple seems to not work, is it installed?" if $@;
25              
26 0 0       0 my $server = $self->config->{imap}{server} or croak "no imap server conf";
27 0 0       0 my $folder = $self->config->{imap}{folder} or croak "no imap folder conf";
28 0         0 my $a_done = $self->config->{imap}{a_done};
29 0         0 my $f_done = $self->config->{imap}{f_done};
30 0         0 my $port = $self->get_imap_port();
31              
32 9     9   1710 no warnings qw(once); ## no critic (Warn)
  9         25  
  9         26631  
33             my $imap = Net::IMAP::Simple->new( $server, Port => $port,
34             ($port==993 ? (use_ssl => 1) : ()),
35             )
36 0 0       0 or do {
    0          
37             ## no critic (PackageVar)
38 0 0       0 my $err = $port == 143 ? $Net::IMAP::Simple::errstr : $Net::IMAP::Simple::SSL::errstr;
39 0         0 croak "Unable to connect to IMAP: $err\n";
40             };
41              
42 0 0       0 print "connected to IMAP server $server:$port\n" if $self->verbose;
43              
44             $imap->login( $self->config->{imap}{user}, $self->config->{imap}{pass} )
45 0 0       0 or croak "Login failed: " . $imap->errstr . "\n";
46              
47 0 0       0 print "\tlogged in\n" if $self->verbose;
48              
49 0         0 my $nm = $imap->select( $self->config->{imap}{folder} );
50 0         0 $imap->expunge_mailbox( $self->config->{imap}{folder} );
51 0         0 my @mess = $imap->search( 'UNSEEN', 'DATE' );
52 0 0       0 if (! scalar @mess) {
53             # imap server might not support SORT extension *Gmail*
54 0         0 @mess = $imap->search( 'UNSEEN' );
55             }
56              
57 0 0       0 print "\tfound " . scalar @mess . " messages\n" if $self->verbose;
58              
59 0         0 foreach my $i (@mess) {
60 0 0       0 print $imap->seen($i) ? '*' : ' ';
61 0         0 printf "[%03d] ", $i;
62 0 0       0 my $message = $imap->get($i) or do {
63 0         0 carp "unable to get message $i\n";
64 0         0 next;
65             };
66 0         0 my $type = $self->from_email_simple( Email::Simple->new("$message") );
67 0 0       0 next if !$type;
68 0 0       0 my $done_box
    0          
69             = $type eq 'aggregate' ? $a_done
70             : $type eq 'forensic' ? $f_done
71             : croak "unknown type!";
72              
73 0         0 $imap->add_flags( $i, '\Seen' );
74 0 0       0 if ( $done_box ) {
75 0 0       0 $imap->copy( $i, $done_box ) or do {
76 0         0 carp $imap->errstr;
77 0         0 next;
78             };
79 0         0 $imap->add_flags( $i, '\Deleted' );
80             };
81             }
82              
83 0         0 $imap->quit;
84 0         0 return 1;
85             }
86              
87             sub from_file {
88 0     0 1 0 my ( $self, $file ) = @_;
89 0 0       0 croak "missing message" if !$file;
90 0 0       0 croak "No such file $file: $!" if !-f $file;
91 0         0 return $self->from_email_simple(
92             Email::Simple->new( $self->slurp($file) ) );
93             }
94              
95             sub from_mbox {
96 0     0 1 0 my ( $self, $file_name ) = @_;
97 0 0       0 croak "missing mbox file" if !$file_name;
98              
99             # TODO: replace this module
100             # commented out due to build test failures
101             # eval "require Mail::Mbox::MessageParser"; ## no critic (Eval)
102             # croak "is Mail::Mbox::MessageParser installed?" if $@;
103              
104             # my $file_handle = FileHandle->new($file_name);
105              
106 0         0 my $folder_reader; # = Mail::Mbox::MessageParser->new(
107             # { 'file_name' => $file_name,
108             # 'file_handle' => $file_handle,
109             # 'enable_cache' => 1,
110             # 'enable_grep' => 1,
111             # }
112             # );
113              
114 0 0       0 croak $folder_reader unless ref $folder_reader;
115              
116 0         0 my $prologue = $folder_reader->prologue;
117 0         0 print $prologue;
118              
119 0         0 while ( !$folder_reader->end_of_file() ) {
120 0         0 $self->from_email_simple(
121             Email::Simple->new( $folder_reader->read_next_email() ) );
122             }
123 0         0 return 1;
124             }
125              
126             sub from_email_simple {
127 0     0 1 0 my ( $self, $email ) = @_;
128              
129 0         0 $self->report->init();
130 0         0 $self->{_envelope_to} = undef;
131 0         0 $self->{_header_from} = undef;
132 0         0 $self->get_submitter_from_subject( $email->header('Subject') );
133              
134 0         0 my $unzipper = {
135             gz => \&IO::Uncompress::Gunzip::gunzip, # 2013 draft
136             zip => \&IO::Uncompress::Unzip::unzip, # legacy format
137             };
138              
139 0         0 my $rep_type;
140 0         0 foreach my $part ( Email::MIME->new( $email->as_string )->parts ) {
141 0   0     0 my ($c_type) = split /;/, $part->content_type || '';
142 0 0       0 next if $c_type eq 'text/plain';
143 0 0       0 if ( $c_type eq 'text/rfc822-headers' ) {
144 0         0 warn "TODO: handle forensic reports\n"; ## no critic (Carp)
145 0         0 $rep_type = 'forensic';
146 0         0 next;
147             }
148 0 0       0 if ( $c_type eq 'message/feedback-report' ) {
149 0         0 warn "TODO: handle forensic reports\n"; ## no critic (Carp)
150 0         0 $rep_type = 'forensic';
151 0         0 next;
152             }
153 0         0 my $bigger;
154 0   0     0 my $filename = $part->{ct}{attributes}{name} || '';
155              
156 0 0 0     0 if ( $c_type eq 'application/zip' || $c_type eq 'application/x-zip-compressed' ) {
157 0         0 $self->get_submitter_from_filename( $filename );
158 0         0 $unzipper->{zip}->( \$part->body, \$bigger );
159 0         0 $self->handle_body($bigger);
160 0         0 $rep_type = 'aggregate';
161 0         0 next;
162             }
163 0 0       0 if ( $c_type eq 'application/gzip' ) {
164 0         0 $self->get_submitter_from_filename( $filename );
165 0         0 $unzipper->{gz}->( \$part->body, \$bigger );
166 0         0 $self->handle_body($bigger);
167 0         0 $rep_type = 'aggregate';
168 0         0 next;
169             }
170 0 0       0 if ( $filename =~ /xml\.gz$/ ) {
171 0 0 0     0 if ( $c_type eq 'application/octet-stream' ||
172             $c_type eq 'multipart/alternative' ) {
173              
174 0         0 $self->get_submitter_from_filename( $filename );
175 0         0 $unzipper->{gz}->( \$part->body, \$bigger );
176 0         0 $self->handle_body($bigger);
177 0         0 $rep_type = 'aggregate';
178 0         0 next;
179             }
180             }
181 0         0 warn "Unknown message part $c_type\n"; ## no critic (Carp)
182             }
183 0         0 return $rep_type;
184             }
185              
186             sub get_imap_port {
187 0     0 0 0 my $self = shift;
188              
189 0         0 eval "use IO::Socket::SSL"; ## no critic (Eval)
190 0 0       0 if ( $@ ) {
191 0         0 carp "no SSL, using insecure connection: $!\n";
192 0         0 return 143;
193             };
194              
195 0         0 eval "use Mozilla::CA"; ## no critic (Eval)
196 0 0       0 if ( ! $@ ) {
197 0         0 IO::Socket::SSL::set_ctx_defaults(
198             SSL_verifycn_scheme => 'imap',
199             SSL_verify_mode => 0x02,
200             SSL_ca_file => Mozilla::CA::SSL_ca_file(),
201             );
202 0         0 return 993;
203             };
204              
205             # no CA, disable verification
206 0         0 IO::Socket::SSL::set_ctx_defaults(
207             SSL_verifycn_scheme => 'imap',
208             SSL_verify_mode => 0,
209             );
210 0         0 return 993;
211             }
212              
213             sub get_submitter_from_filename {
214 0     0 0 0 my ( $self, $filename ) = @_;
215 0 0       0 return if $self->{_envelope_to}; # already parsed from Subject:
216 0         0 my ( $submitter_dom, $report_dom, $begin, $end ) = split /!/, $filename;
217 0   0     0 $self->{_header_from} ||= $report_dom;
218 0         0 return $self->{_envelope_to} = $submitter_dom;
219             }
220              
221             sub get_submitter_from_subject {
222 5     5 0 3424 my ( $self, $subject ) = @_;
223              
224             # The 2013 DMARC spec section 12.2.1 suggests that the header SHOULD conform
225             # to a supplied ABNF. Rather than "require" such conformance, this method is
226             # more concerned with reliably extracting the submitter domain. Quickly.
227 5         22 $subject = lc Encode::decode( 'MIME-Header', $subject );
228 5         8500 print $subject . "\n";
229 5 50       36 $subject = substr( $subject, 8 ) if 'subject:' eq substr( $subject, 0, 8 );
230 5         57 $subject =~ s/(?:report\sdomain|submitter|report-id)//gx; # strip keywords
231 5         27 $subject =~ s/\s+//g; # remove white space
232 5         21 my ( undef, $report_dom, $sub_dom, $report_id ) = split /:/, $subject;
233 5         18 my $meta = $self->report->aggregate->metadata;
234 5 100 66     23 if ( $report_id && !$meta->uuid ) {
235             # remove if present
236 1 50       5 $report_id = substr($report_id,1) if '<' eq substr($report_id,0,1);
237 1 50       5 chop $report_id if '>' eq substr($report_id,-1,1);
238 1         20 $meta->uuid($report_id);
239             };
240 5   66     20 $self->{_header_from} ||= $report_dom;
241 5         31 return $self->{_envelope_to} = $sub_dom;
242             }
243              
244             sub handle_body {
245 0     0 1 0 my ( $self, $body ) = @_;
246              
247 0 0       0 print "handling decompressed body\n" if $self->{verbose};
248              
249 0         0 my $dom = XML::LibXML->load_xml( string => $body );
250 0         0 $self->do_node_report_metadata( $dom->findnodes("/feedback/report_metadata") );
251 0         0 $self->do_node_policy_published( $dom->findnodes("/feedback/policy_published") );
252              
253 0         0 foreach my $record ( $dom->findnodes("/feedback/record") ) {
254 0         0 $self->do_node_record($record);
255             }
256              
257 0         0 return $self->report->save_aggregate();
258             }
259              
260             sub report {
261 5     5 0 8 my $self = shift;
262 5 100       26 return $self->{report} if ref $self->{report};
263 1         12 return $self->{report} = Mail::DMARC::Report->new();
264             }
265              
266             sub do_node_report_metadata {
267 0     0 0   my ( $self, $node ) = @_;
268              
269 0           foreach my $n (qw/ org_name email extra_contact_info /) {
270 0           $self->report->aggregate->metadata->$n(
271             $node->findnodes("./$n")->string_value );
272             }
273              
274 0           my $rid = $node->findnodes("./report_id")->string_value;
275 0 0         $rid = substr($rid,1) if '<' eq substr($rid,0,1); # remove <
276 0 0         chop $rid if '>' eq substr($rid,-1,1); # remove >
277 0           $self->report->aggregate->metadata->report_id( $rid );
278              
279 0 0         if ( ! $self->report->aggregate->metadata->uuid ) {
280 0           $self->report->aggregate->metadata->uuid( $rid );
281             };
282              
283 0           foreach my $n (qw/ begin end /) {
284 0           $self->report->aggregate->metadata->$n(
285             $node->findnodes("./date_range/$n")->string_value );
286             }
287              
288 0           foreach my $n ( $node->findnodes("./error") ) {
289 0           $self->report->aggregate->metadata->error( $n->string_value );
290             }
291 0           return $self->report->aggregate->metadata;
292             }
293              
294             sub do_node_policy_published {
295 0     0 0   my ( $self, $node ) = @_;
296              
297 0           my $pol = Mail::DMARC::Policy->new();
298              
299 0           foreach my $n (qw/ domain adkim aspf p sp pct /) {
300 0 0         my $val = $node->findnodes("./$n")->string_value or next;
301 0           $val =~ s/\s*//g; # remove whitespace
302 0           $pol->$n($val);
303             }
304              
305 0           $self->report->aggregate->policy_published($pol);
306 0           return $pol;
307             }
308              
309             sub do_node_record {
310 0     0 0   my ( $self, $node ) = @_;
311              
312 0           my $rec = Mail::DMARC::Report::Aggregate::Record->new;
313 0           $self->do_node_record_auth(\$rec, $node);
314              
315 0           foreach my $r (qw/ source_ip count /) {
316 0           $rec->row->$r(
317             $node->findnodes("./row/$r")->string_value
318             );
319             };
320              
321             # policy_evaluated
322 0           foreach my $pe (qw/ disposition dkim spf /) {
323 0           my $ResultType = $node->findnodes("./row/policy_evaluated/$pe")->string_value;
324 0 0         if ($pe eq 'disposition') {
325 0 0         if ($ResultType !~ /^(none|quarantine|reject)$/) {
326 0           $ResultType = 'none'; # invalid DispositionType (Facebook)
327             }
328             }
329             else {
330 0 0         if ($ResultType !~ /^(pass|fail)$/) {
331 0           $ResultType = 'pass'; # invalid ResultType (also FaceBook)
332             }
333             }
334 0           $rec->row->policy_evaluated->$pe($ResultType);
335             }
336              
337             # reason
338 0           $self->do_node_record_reason( \$rec, $node );
339              
340             # identifiers
341 0           foreach my $i (qw/ envelope_to envelope_from header_from /) {
342 0           $rec->identifiers->$i(
343             $node->findnodes("./identifiers/$i")->string_value
344             );
345             }
346              
347             # for reports from junc.org with mis-labeled identifiers
348 0 0         if ( !$rec->identifiers->header_from ) {
349 0           $rec->identifiers->header_from(
350             $node->findnodes("./identities/header_from")->string_value
351             );
352             };
353              
354             # last resort...
355 0 0         if (!$rec->identifiers->envelope_to) {
356 0           $rec->identifiers->envelope_to($self->{_envelope_to});
357             }
358 0 0         if (!$rec->identifiers->header_from) {
359 0           $rec->identifiers->header_from($self->{_header_from});
360             }
361              
362 0 0         print Data::Dumper::Dumper($rec) if $self->verbose;
363 0           $self->report->aggregate->record($rec);
364 0           return $rec;
365             }
366              
367             sub do_node_record_auth {
368 0     0 0   my ($self, $row, $node) = @_;
369              
370 0           my @spf = qw/ domain scope result /;
371              
372 0           foreach ( $node->findnodes("./auth_results/spf") ) {
373 0           my %spf = map { $_ => $node->findnodes("./auth_results/spf/$_")->string_value } @spf;
  0            
374              
375 0 0 0       if ( $spf{scope} && ! $self->is_valid_spf_scope( $spf{scope} ) ) {
376 0           carp "invalid scope: $spf{scope}, ignoring";
377 0           delete $spf{scope};
378             };
379             # this is for reports from ivenue.com with result=unknown
380 0 0 0       if ( $spf{result} && ! $self->is_valid_spf_result( $spf{result} ) ) {
381 0           carp "invalid SPF result: $spf{result}, setting to temperror";
382 0           $spf{result} = 'temperror';
383             };
384 0           $$row->auth_results->spf(\%spf);
385             };
386              
387 0           my @dkim = qw/ domain selector result human_result /;
388 0           foreach ( $node->findnodes("./auth_results/dkim") ) {
389 0           my %dkim = map { $_ => $node->findnodes("./auth_results/dkim/$_")->string_value } @dkim;
  0            
390 0           $$row->auth_results->dkim(\%dkim);
391             };
392              
393 0           return;
394             }
395              
396             sub do_node_record_reason {
397 0     0 0   my ($self, $row, $node) = @_;
398              
399             # my @types = qw/ forwarded sampled_out trusted_forwarder mailing_list
400             # local_policy other /;
401              
402 0           foreach my $r ( $node->findnodes("./row/policy_evaluated/reason") ) {
403 0 0         my $type = $r->findnodes('./type')->string_value or next;
404 0           my $comment = $r->findnodes('./comment')->string_value;
405 0           $$row->row->policy_evaluated->reason(
406             { type => $type, comment => $comment }
407             );
408             }
409 0           return;
410             }
411              
412             1;
413              
414             __END__