File Coverage

lib/Mail/DMARC/Report/Send/SMTP.pm
Criterion Covered Total %
statement 87 96 90.6
branch 18 40 45.0
condition 4 11 36.3
subroutine 16 17 94.1
pod 0 9 0.0
total 125 173 72.2


line stmt bran cond sub pod time code
1             package Mail::DMARC::Report::Send::SMTP;
2 11     11   948 use strict;
  11         33  
  11         372  
3 11     11   56 use warnings;
  11         22  
  11         468  
4              
5             our $VERSION = '1.20230215';
6              
7 11     11   60 use Carp;
  11         20  
  11         709  
8 11     11   5849 use English '-no_match_vars';
  11         14016  
  11         82  
9 11     11   10663 use Email::MIME;
  11         294129  
  11         391  
10             #use Mail::Sender; # something to consider
11 11     11   5140 use Sys::Hostname;
  11         11892  
  11         681  
12 11     11   150 use POSIX;
  11         31  
  11         233  
13              
14 11     11   28646 use parent 'Mail::DMARC::Base';
  11         32  
  11         118  
15              
16             sub get_domain_mx {
17 2     2 0 7 my ( $self, $domain ) = @_;
18 2         25 print "getting MX for $domain\n";
19 2         5 my $query;
20 2 50       4 eval {
21 2 50       14 $query = $self->get_resolver->send( $domain, 'MX' ) or return [];
22             } or print $@;
23              
24 2 50       21279 if ( ! $query ) {
25 0         0 print "\terror:\n\t$@";
26 0         0 return [];
27             };
28              
29 2         5 my @mx;
30 2         7 for my $rr ( $query->answer ) {
31 2 50       24 next if $rr->type ne 'MX';
32 2         30 push @mx, { pref => $rr->preference, addr => $rr->exchange };
33 2 50       133 print $rr->exchange if $self->verbose;
34             }
35 2 50       5 if ( $self->verbose ) {
36 0         0 print "found " . scalar @mx . "MX exchanges\n";
37             };
38 2         30 return \@mx;
39             }
40              
41             sub get_smtp_hosts {
42 1     1 0 11 my $self = shift;
43 1 50       4 my $email = shift or croak "missing email!";
44              
45 1         4 my ($domain) = ( split /@/, $email )[-1];
46 1         5 my @mx = map { $_->{addr} }
47 0         0 sort { $a->{pref} <=> $b->{pref} }
48 1         2 @{ $self->get_domain_mx($domain) };
  1         4  
49              
50 1         3 push @mx, $domain;
51 1 50       4 print "\tfound " . scalar @mx . " MX for $email\n" if $self->verbose;
52 1         4 return @mx;
53             }
54              
55             sub get_subject {
56 6     6 0 18 my ( $self, $agg_ref ) = @_;
57              
58              
59 6   33     25 my $rid = $$agg_ref->metadata->report_id || $self->time;
60 6         24 my $id = POSIX::strftime( "%Y.%m.%d.", localtime $self->time ) . $rid;
61 6         33 my $us = $self->config->{organization}{domain};
62 6 50       22 if ($us eq 'example.com') {
63 0         0 die "Please update mail-dmarc.ini";
64             }
65 6         23 my $pol_dom = $$agg_ref->policy_published->domain;
66 6         53 return "Report Domain: $pol_dom Submitter: $us Report-ID:$id";
67             }
68              
69             sub human_summary {
70 6     6 0 20 my ( $self, $agg_ref ) = @_;
71              
72 6         9 my $records = scalar @{ $$agg_ref->{record} };
  6         17  
73 6         19 my $OrgName = $self->config->{organization}{org_name};
74             my $pass = grep { 'pass' eq $_->{row}{policy_evaluated}{dkim}
75 10 50       74 || 'pass' eq $_->{row}{policy_evaluated}{spf} }
76 6         10 @{ $$agg_ref->{record} };
  6         31  
77             my $fail = grep { 'pass' ne $_->{row}{policy_evaluated}{dkim}
78 10 50       49 && 'pass' ne $_->{row}{policy_evaluated}{spf} }
79 6         15 @{ $$agg_ref->{record} };
  6         14  
80 6   50     21 my $ver = $Mail::DMARC::Base::VERSION || ''; # undef in author environ
81 6 50       24 my $from = $$agg_ref->{policy_published}{domain} or croak;
82              
83             return <<"EO_REPORT"
84              
85             This is a DMARC aggregate report for $from
86              
87             $records records.
88             $pass passed.
89             $fail failed.
90              
91             Submitted by $OrgName
92             Generated with Mail::DMARC $ver
93              
94             EO_REPORT
95 6         91 ;
96             }
97              
98             sub get_filename {
99 6     6 0 16 my ( $self, $agg_ref ) = @_;
100              
101             # 2013 DMARC Draft, 12.2.1 Email
102             #
103             # filename = receiver "!" policy-domain "!" begin-timestamp "!"
104             # end-timestamp [ "!" unique-id ] "." extension
105             # filename="mail.receiver.example!example.com!1013662812!1013749130.gz"
106             return join( '!',
107             $self->config->{organization}{domain},
108 6   33     77 $$agg_ref->policy_published->domain,
109             $$agg_ref->metadata->begin,
110             $$agg_ref->metadata->end,
111             $$agg_ref->metadata->report_id || $self->time,
112             ) . '.xml';
113             }
114              
115             sub assemble_too_big_message_object {
116 0     0 0 0 my ( $self, $to, $body ) = @_;
117              
118 0 0       0 my @parts = Email::MIME->create(
119             attributes => {
120             content_type => "text/plain",
121             disposition => "inline",
122             charset => "US-ASCII",
123             },
124             body => $body,
125             ) or croak "unable to add body!";
126              
127             my $email = Email::MIME->create(
128             header_str => [
129             From => $self->config->{organization}{email},
130 0 0       0 To => $to,
131             Date => $self->get_timestamp_rfc2822,
132             Subject => 'DMARC too big report',
133             ],
134             parts => [@parts],
135             ) or croak "unable to assemble message\n";
136              
137 0         0 return $email;
138             }
139              
140             sub assemble_message_object {
141 5     5 0 32 my ( $self, $agg_ref, $to, $shrunk ) = @_;
142              
143 5         20 my $filename = $self->get_filename($agg_ref);
144             # WARNING: changes made here MAY affect Send::compress. Check it!
145             # my $cf = ( time > 1372662000 ) ? 'gzip' : 'zip'; # gz after 7/1/13
146 5         16 my $cf = 'gzip';
147 5 50       21 $filename .= $cf eq 'gzip' ? '.gz' : '.zip';
148              
149 5 50       47 my @parts = Email::MIME->create(
150             attributes => {
151             content_type => "text/plain",
152             disposition => "inline",
153             charset => "US-ASCII",
154             },
155             body => $self->human_summary( $agg_ref ),
156             ) or croak "unable to add body!";
157              
158 5 50       17254 push @parts,
159             Email::MIME->create(
160             attributes => {
161             filename => $filename,
162             content_type => "application/$cf",
163             encoding => "base64",
164             name => $filename,
165             },
166             body => $shrunk,
167             ) or croak "unable to add report!";
168              
169             my $email = Email::MIME->create(
170             header_str => [
171             From => $self->config->{organization}{email},
172 5 50       9318 To => $to,
173             Date => $self->get_timestamp_rfc2822,
174             Subject => $self->get_subject( $agg_ref ),
175             ],
176             parts => [@parts],
177             ) or croak "unable to assemble message\n";
178              
179 5         29021 return $email;
180             }
181              
182             sub get_timestamp_rfc2822 {
183 7     7 0 25 my ($self, @args) = @_;
184 7 50       67 my @ts = scalar @args ? @args : localtime $self->time;
185 7         101 my $locale = setlocale(LC_CTYPE);
186 7         111 setlocale(LC_ALL, 'C');
187 7         273 my $timestamp = POSIX::strftime( '%a, %d %b %Y %H:%M:%S %z', @ts );
188 7         74 setlocale(LC_ALL, $locale);
189 7         47 return $timestamp;
190             }
191              
192             sub get_helo_hostname {
193 1     1 0 2 my $self = shift;
194 1         5 my $host = $self->config->{smtp}{hostname};
195 1 50 33     8 return $host if $host && $host ne 'mail.example.com';
196 1         6 return Sys::Hostname::hostname;
197             };
198              
199             1;
200              
201             __END__