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   298106 use strict;
  7         20  
  7         218  
3 7     7   36 use warnings;
  7         13  
  7         299  
4              
5             our $VERSION = '1.20211209';
6              
7 7     7   40 use Carp;
  7         33  
  7         530  
8             our $psl_loads = 0;
9              
10 7     7   45 use parent 'Mail::DMARC::Base';
  7         27  
  7         80  
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 51425 my ( $class, @args ) = @_;
19 14 50       82 croak "invalid args" if scalar @args % 2;
20 14         40 my %args = @args;
21 14         67 my $self = bless {
22             config_file => 'mail-dmarc.ini',
23             }, $class;
24              
25 14 100       91 my @keys = sort { $a eq 'config_file' ? -1
  26 100       65  
26             : $b eq 'config_file' ? 1
27             : ($a cmp $b) } keys %args;
28              
29 14         42 foreach my $key ( @keys ) {
30 16 100       112 if ($self->can($key)) {
31 13         67 $self->$key( $args{$key} );
32             }
33             else {
34 3         13 $self->{$key} = $args{$key};
35             }
36             }
37 14         2763 return $self;
38             }
39              
40             sub source_ip {
41 26 100   26 1 2057 return $_[0]->{source_ip} if 1 == scalar @_;
42 14 100       74 croak "invalid source_ip" if !$_[0]->is_valid_ip( $_[1] );
43 12         12488 return $_[0]->{source_ip} = $_[1];
44             }
45              
46             sub envelope_to {
47 16 100   16 1 1011 return $_[0]->{envelope_to} if 1 == scalar @_;
48 11 100       64 croak "invalid envelope_to" if !$_[0]->is_valid_domain( $_[1] );
49 10         46 return $_[0]->{envelope_to} = $_[1];
50             }
51              
52             sub envelope_from {
53 14 100   14 1 490 return $_[0]->{envelope_from} if 1 == scalar @_;
54 9 50       86 croak "invalid envelope_from" if !$_[0]->is_valid_domain( $_[1] );
55 9         43 return $_[0]->{envelope_from} = $_[1];
56             }
57              
58             sub header_from {
59 167 100   167 1 4111 return $_[0]->{header_from} if 1 == scalar @_;
60 41 100       199 croak "invalid header_from" if !$_[0]->is_valid_domain( $_[1] );
61 37         232 return $_[0]->{header_from} = lc $_[1];
62             }
63              
64             sub header_from_raw {
65 20 100   20 1 81 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         24 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 1796 my ($self, @args) = @_;
79              
80 84 100       328 if (0 == scalar @args) {
81 54         214 $self->_unwrap('dkim');
82 54         278 return $self->{dkim};
83             }
84              
85             # one shot
86 30 100       102 if (1 == scalar @args) {
87             # warn "one argument\n";
88 26 100       589 if (ref $args[0] eq 'CODE') {
89 1         6 return $self->{dkim} = $args[0];
90             }
91              
92 25 100       101 if ( ref $args[0] eq 'ARRAY') {
93 22         44 foreach my $d ( @{ $args[0] }) {
  22         80  
94 23         42 push @{ $self->{dkim}},
  23         333  
95             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new($d);
96             }
97 22         128 return $self->{dkim};
98             }
99              
100 3 100       11 if ( ref $args[0] eq 'Mail::DKIM::Verifier' ) {
101 1         9 $self->_from_mail_dkim($args[0]);
102 1         2 return $self->{dkim};
103             }
104             };
105              
106             #warn "iterative\n";
107 6         21 push @{ $self->{dkim}},
  6         29  
108             Mail::DMARC::Report::Aggregate::Record::Auth_Results::DKIM->new(@args);
109              
110 4         24 return $self->{dkim};
111             }
112              
113             sub _from_mail_dkim {
114 1     1   2 my ( $self, $dkim ) = @_;
115              
116 1         2 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       10 next if ref $s eq 'Mail::DKIM::DkSignature';
121 1         2 $signatures++;
122              
123 1         4 my $result = $s->result;
124              
125 1 50       10 if ($result eq 'invalid') { # See GH Issue #21
126 0         0 $result = 'temperror';
127             }
128              
129 1         1 push @{ $self->{dkim}},
  1         6  
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   238 my ( $self, $key ) = @_;
151 107 100 66     691 if ($self->{$key} and ref $self->{$key} eq 'CODE') {
152 2         5 my $code = delete $self->{$key};
153 2         8 $self->$key( $self->$code );
154             }
155 107         207 return;
156             }
157              
158             sub spf {
159 79     79 1 679 my ($self, @args) = @_;
160 79 100       253 if (0 == scalar @args) {
161 53         159 $self->_unwrap('spf');
162 53         284 return $self->{spf};
163             }
164              
165 26 100 100     181 if (1 == scalar @args && ref $args[0] eq 'CODE') {
166 1         7 return $self->{spf} = $args[0];
167             }
168              
169 25 100 100     153 if (1 == scalar @args && ref $args[0] eq 'ARRAY') {
170             # warn "SPF one shot";
171 12         19 foreach my $d ( @{ $args[0] }) {
  12         35  
172 18         25 push @{ $self->{spf} },
  18         138  
173             Mail::DMARC::Report::Aggregate::Record::Auth_Results::SPF->new($d);
174             }
175 12         47 return $self->{spf};
176             }
177              
178             #warn "SPF iterative";
179 13         39 push @{ $self->{spf} },
  13         139  
180             Mail::DMARC::Report::Aggregate::Record::Auth_Results::SPF->new(@args);
181              
182 12         66 return $self->{spf};
183             }
184              
185             sub policy {
186 70     70 0 1183 my ( $self, @args ) = @_;
187 70 100 66     644 return $self->{policy} if ref $self->{policy} && 0 == scalar @args;
188 15         190 return $self->{policy} = Mail::DMARC::Policy->new(@args);
189             }
190              
191             sub report {
192 38     38 0 1087 my $self = shift;
193 38 100       238 return $self->{report} if ref $self->{report};
194 9         109 return $self->{report} = Mail::DMARC::Report->new();
195             }
196              
197             sub result {
198 342     342 1 4384 my $self = shift;
199 342 100       2243 return $self->{result} if ref $self->{result};
200 18         140 return $self->{result} = Mail::DMARC::Result->new();
201             }
202              
203             sub is_subdomain {
204 60 100   60 0 309 return $_[0]->{is_subdomain} if 1 == scalar @_;
205 52 50       128 croak "invalid boolean" if 0 == grep {/^$_[1]$/ix} qw/ 0 1/;
  104         1173  
206 52         196 return $_[0]->{is_subdomain} = $_[1];
207             }
208              
209             sub get_report_window {
210 20     20 0 6057 my ( $self, $interval, $now ) = @_;
211              
212 20         74 my $min_interval = $self->config->{'report_sending'}{'min_interval'};
213 20         1176 my $max_interval = $self->config->{'report_sending'}{'max_interval'};
214              
215 20 100       49 $interval = 86400 if ! $interval; # Default to 1 day
216 20 100       67 if ( $min_interval ) {
217 5 100       15 $interval = $min_interval if $interval < $min_interval;
218             }
219 20 100       40 if ( $max_interval ) {
220 5 100       12 $interval = $max_interval if $interval > $max_interval;
221             }
222              
223 20 100       52 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         51 my $begin = $self->get_start_of_zulu_day( $now );
230 18         33 my $end = $begin + $interval - 1;
231              
232 18         54 while ( $end < $now ) {
233 5         8 $begin = $begin + $interval;
234 5         12 $end = $begin + $interval - 1;
235             }
236              
237 18         49 return ( $begin, $end );
238             }
239              
240              
241             sub get_start_of_zulu_day {
242 22     22 0 2509 my ( $self, $t ) = @_;
243 22         46 my $start_of_zulu_day = $t - ( $t % 86400 );
244 22         114 return $start_of_zulu_day;
245             }
246              
247             sub save_aggregate {
248 5     5 0 19 my ($self) = @_;
249              
250 5         19 my $agg = $self->report->aggregate;
251              
252             # put config information in report metadata
253 5         21 foreach my $f ( qw/ org_name email extra_contact_info report_id / ) {
254 20         64 $agg->metadata->$f( $self->config->{organization}{$f} );
255             };
256              
257 5         19 my ( $begin, $end ) = $self->get_report_window( $self->result->published->ri, $self->time );
258              
259 5         69 $agg->metadata->begin( $begin );
260 5         18 $agg->metadata->end( $end );
261              
262 5         26 $agg->policy_published( $self->result->published );
263              
264 5         54 my $rec = Mail::DMARC::Report::Aggregate::Record->new();
265 5         23 $rec->row->source_ip( $self->source_ip );
266              
267 5         30 $rec->identifiers(
268             envelope_to => $self->envelope_to,
269             envelope_from => $self->envelope_from,
270             header_from => $self->header_from,
271             );
272              
273 5         25 $rec->auth_results->dkim($self->dkim);
274 5         20 $rec->auth_results->spf($self->spf);
275              
276 5         21 $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         32 $agg->record($rec);
284 5         16 return $self->report->save_aggregate;
285             }
286              
287             sub init {
288             # used for testing
289 5     5 0 414 my $self = shift;
290 5         12 map { delete $self->{$_} } qw/ spf spf_ar dkim dkim_ar /;
  20         43  
291 5         9 return;
292             }
293              
294             1;
295              
296             __END__