File Coverage

lib/Mail/DMARC.pm
Criterion Covered Total %
statement 139 144 96.5
branch 66 74 89.1
condition 10 12 83.3
subroutine 22 23 95.6
pod 9 17 52.9
total 246 270 91.1


line stmt bran cond sub pod time code
1             package Mail::DMARC;
2 7     7   255660 use strict;
  7         15  
  7         197  
3 7     7   34 use warnings;
  7         10  
  7         281  
4              
5             our $VERSION = '1.20210927';
6              
7 7     7   36 use Carp;
  7         11  
  7         490  
8             our $psl_loads = 0;
9              
10 7     7   42 use parent 'Mail::DMARC::Base';
  7         23  
  7         76  
11             require Mail::DMARC::Policy;
12             require Mail::DMARC::Report;
13             require Mail::DMARC::Result;
14             require Mail::DMARC::Report::Aggregate::Record::Auth_Results::SPF;
15             require Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM;
16              
17             sub new {
18 14     14 1 39346 my ( $class, @args ) = @_;
19 14 50       81 croak "invalid args" if scalar @args % 2;
20 14         47 my %args = @args;
21 14         54 my $self = bless {
22             config_file => 'mail-dmarc.ini',
23             }, $class;
24              
25 14 100       79 my @keys = sort { $a eq 'config_file' ? -1
  27 100       79  
26             : $b eq 'config_file' ? 1
27             : ($a cmp $b) } keys %args;
28              
29 14         37 foreach my $key ( @keys ) {
30 16 100       108 if ($self->can($key)) {
31 13         50 $self->$key( $args{$key} );
32             }
33             else {
34 3         15 $self->{$key} = $args{$key};
35             }
36             }
37 14         1806 return $self;
38             }
39              
40             sub source_ip {
41 26 100   26 1 2370 return $_[0]->{source_ip} if 1 == scalar @_;
42 14 100       81 croak "invalid source_ip" if !$_[0]->is_valid_ip( $_[1] );
43 12         12628 return $_[0]->{source_ip} = $_[1];
44             }
45              
46             sub envelope_to {
47 16 100   16 1 1035 return $_[0]->{envelope_to} if 1 == scalar @_;
48 11 100       61 croak "invalid envelope_to" if !$_[0]->is_valid_domain( $_[1] );
49 10         52 return $_[0]->{envelope_to} = $_[1];
50             }
51              
52             sub envelope_from {
53 14 100   14 1 426 return $_[0]->{envelope_from} if 1 == scalar @_;
54 9 50       77 croak "invalid envelope_from" if !$_[0]->is_valid_domain( $_[1] );
55 9         39 return $_[0]->{envelope_from} = $_[1];
56             }
57              
58             sub header_from {
59 167 100   167 1 4303 return $_[0]->{header_from} if 1 == scalar @_;
60 41 100       163 croak "invalid header_from" if !$_[0]->is_valid_domain( $_[1] );
61 37         208 return $_[0]->{header_from} = lc $_[1];
62             }
63              
64             sub header_from_raw {
65 20 100   20 1 75 return $_[0]->{header_from_raw} if 1 == scalar @_;
66             #croak "invalid header_from_raw: $_[1]" if 'from:' ne lc substr($_[1], 0, 5);
67 10         31 return $_[0]->{header_from_raw} = lc $_[1];
68             }
69              
70             sub local_policy {
71 0 0   0 0 0 return $_[0]->{local_policy} if 1 == scalar @_;
72              
73             # TODO: document this, when and why it would be used
74 0         0 return $_[0]->{local_policy} = $_[1];
75             }
76              
77             sub dkim {
78 84     84 1 1253 my ($self, @args) = @_;
79              
80 84 100       254 if (0 == scalar @args) {
81 54         175 $self->_unwrap('dkim');
82 54         236 return $self->{dkim};
83             }
84              
85             # one shot
86 30 100       92 if (1 == scalar @args) {
87             # warn "one argument\n";
88 26 100       92 if (ref $args[0] eq 'CODE') {
89 1         14 return $self->{dkim} = $args[0];
90             }
91              
92 25 100       76 if ( ref $args[0] eq 'ARRAY') {
93 22         34 foreach my $d ( @{ $args[0] }) {
  22         64  
94 23         38 push @{ $self->{dkim}},
  23         834  
95             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new($d);
96             }
97 22         96 return $self->{dkim};
98             }
99              
100 3 100       11 if ( ref $args[0] eq 'Mail::DKIM::Verifier' ) {
101 1         5 $self->_from_mail_dkim($args[0]);
102 1         3 return $self->{dkim};
103             }
104             };
105              
106             #warn "iterative\n";
107 6         8 push @{ $self->{dkim}},
  6         24  
108             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new(@args);
109              
110 4         18 return $self->{dkim};
111             }
112              
113             sub _from_mail_dkim {
114 1     1   2 my ( $self, $dkim ) = @_;
115              
116 1         3 my $signatures = 0;
117              
118             # A DKIM verifier will have result and signature methods.
119 1         4 foreach my $s ( $dkim->signatures ) {
120 1 50       9 next if ref $s eq 'Mail::DKIM::DkSignature';
121 1         3 $signatures++;
122              
123 1         4 my $result = $s->result;
124              
125 1 50       8 if ($result eq 'invalid') { # See GH Issue #21
126 0         0 $result = 'temperror';
127             }
128              
129 1         3 push @{ $self->{dkim}},
  1         4  
130             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new(
131             domain => $s->domain,
132             selector => $s->selector,
133             result => $result,
134             human_result => $s->result_detail,
135             );
136             }
137              
138 1 50       9 if ($signatures < 1) {
139 0         0 push @{ $self->{dkim}},
  0         0  
140             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new(
141             domain => '',
142             result => 'none',
143             );
144             }
145              
146 1         3 return;
147             }
148              
149             sub _unwrap {
150 107     107   189 my ( $self, $key ) = @_;
151 107 100 66     541 if ($self->{$key} and ref $self->{$key} eq 'CODE') {
152 2         6 my $code = delete $self->{$key};
153 2         8 $self->$key( $self->$code );
154             }
155 107         164 return;
156             }
157              
158             sub spf {
159 79     79 1 614 my ($self, @args) = @_;
160 79 100       233 if (0 == scalar @args) {
161 53         132 $self->_unwrap('spf');
162 53         243 return $self->{spf};
163             }
164              
165 26 100 100     641 if (1 == scalar @args && ref $args[0] eq 'CODE') {
166 1         6 return $self->{spf} = $args[0];
167             }
168              
169 25 100 100     131 if (1 == scalar @args && ref $args[0] eq 'ARRAY') {
170             # warn "SPF one shot";
171 12         22 foreach my $d ( @{ $args[0] }) {
  12         34  
172 18         21 push @{ $self->{spf} },
  18         111  
173             Mail::DMARC::Report::Aggregate::Record::Auth_Results::SPF->new($d);
174             }
175 12         48 return $self->{spf};
176             }
177              
178             #warn "SPF iterative";
179 13         19 push @{ $self->{spf} },
  13         119  
180             Mail::DMARC::Report::Aggregate::Record::Auth_Results::SPF->new(@args);
181              
182 12         73 return $self->{spf};
183             }
184              
185             sub policy {
186 70     70 0 1163 my ( $self, @args ) = @_;
187 70 100 66     584 return $self->{policy} if ref $self->{policy} && 0 == scalar @args;
188 15         152 return $self->{policy} = Mail::DMARC::Policy->new(@args);
189             }
190              
191             sub report {
192 38     38 0 1361 my $self = shift;
193 38 100       251 return $self->{report} if ref $self->{report};
194 9         113 return $self->{report} = Mail::DMARC::Report->new();
195             }
196              
197             sub result {
198 342     342 1 4498 my $self = shift;
199 342 100       1977 return $self->{result} if ref $self->{result};
200 18         164 return $self->{result} = Mail::DMARC::Result->new();
201             }
202              
203             sub is_subdomain {
204 60 100   60 0 275 return $_[0]->{is_subdomain} if 1 == scalar @_;
205 52 50       109 croak "invalid boolean" if 0 == grep {/^$_[1]$/ix} qw/ 0 1/;
  104         1070  
206 52         199 return $_[0]->{is_subdomain} = $_[1];
207             }
208              
209             sub get_report_window {
210 20     20 0 5661 my ( $self, $interval, $now ) = @_;
211              
212 20         56 my $min_interval = $self->config->{'report_sending'}{'min_interval'};
213 20         1106 my $max_interval = $self->config->{'report_sending'}{'max_interval'};
214              
215 20 100       48 $interval = 86400 if ! $interval; # Default to 1 day
216 20 100       44 if ( $min_interval ) {
217 5 100       13 $interval = $min_interval if $interval < $min_interval;
218             }
219 20 100       38 if ( $max_interval ) {
220 5 100       11 $interval = $max_interval if $interval > $max_interval;
221             }
222              
223 20 100       66 if ( ( 86400 % $interval ) != 0 ) {
224             # Interval does not fit into a day nicely,
225             # So don't work out a window, just run with it.
226 2         7 return ( $now, $now + $interval - 1);
227             }
228              
229 18         48 my $begin = $self->get_start_of_zulu_day( $now );
230 18         36 my $end = $begin + $interval - 1;
231              
232 18         51 while ( $end < $now ) {
233 5         13 $begin = $begin + $interval;
234 5         9 $end = $begin + $interval - 1;
235             }
236              
237 18         42 return ( $begin, $end );
238             }
239              
240              
241             sub get_start_of_zulu_day {
242 22     22 0 2367 my ( $self, $t ) = @_;
243 22         39 my $start_of_zulu_day = $t - ( $t % 86400 );
244 22         120 return $start_of_zulu_day;
245             }
246              
247             sub save_aggregate {
248 5     5 0 16 my ($self) = @_;
249              
250 5         20 my $agg = $self->report->aggregate;
251              
252             # put config information in report metadata
253 5         18 foreach my $f ( qw/ org_name email extra_contact_info report_id / ) {
254 20         57 $agg->metadata->$f( $self->config->{organization}{$f} );
255             };
256              
257 5         20 my ( $begin, $end ) = $self->get_report_window( $self->result->published->ri, $self->time );
258              
259 5         76 $agg->metadata->begin( $begin );
260 5         15 $agg->metadata->end( $end );
261              
262 5         15 $agg->policy_published( $self->result->published );
263              
264 5         50 my $rec = Mail::DMARC::Report::Aggregate::Record->new();
265 5         21 $rec->row->source_ip( $self->source_ip );
266              
267 5         24 $rec->identifiers(
268             envelope_to => $self->envelope_to,
269             envelope_from => $self->envelope_from,
270             header_from => $self->header_from,
271             );
272              
273 5         20 $rec->auth_results->dkim($self->dkim);
274 5         19 $rec->auth_results->spf($self->spf);
275              
276 5         38 $rec->row->policy_evaluated(
277             disposition => $self->result->disposition,
278             dkim => $self->result->dkim,
279             spf => $self->result->spf,
280             reason => $self->result->reason,
281             );
282              
283 5         27 $agg->record($rec);
284 5         16 return $self->report->save_aggregate;
285             }
286              
287             sub init {
288             # used for testing
289 5     5 0 372 my $self = shift;
290 5         8 map { delete $self->{$_} } qw/ spf spf_ar dkim dkim_ar /;
  20         40  
291 5         8 return;
292             }
293              
294             1;
295              
296             __END__