File Coverage

blib/lib/Mail/BIMI.pm
Criterion Covered Total %
statement 130 142 91.5
branch 42 58 72.4
condition 12 24 50.0
subroutine 17 17 100.0
pod 2 2 100.0
total 203 243 83.5


line stmt bran cond sub pod time code
1             package Mail::BIMI;
2             # ABSTRACT: BIMI object
3             our $VERSION = '3.20210301'; # VERSION
4 30     30   3145676 use 5.20.0;
  30         116  
5 30     30   15544 use Moose;
  30         13054664  
  30         203  
6 30     30   202883 use Moose::Util::TypeConstraints;
  30         70  
  30         730  
7 30     30   61317 use Mail::BIMI::Prelude;
  30         63  
  30         238  
8 30     30   26548 use Mail::BIMI::Options;
  30         99  
  30         1547  
9 30     30   17961 use Mail::BIMI::Record;
  30         280  
  30         2969  
10 30     30   17390 use Mail::BIMI::Result;
  30         123  
  30         1248  
11 30     30   242 use Mail::DMARC::PurePerl;
  30         70  
  30         803  
12 30     30   164 use Net::DNS::Resolver;
  30         65  
  30         59239  
13              
14             with 'Mail::BIMI::Role::HasError';
15              
16             subtype 'MaybeDMARC'
17             => as 'Any'
18             => where {
19             !defined $_
20             || ref $_ eq 'Mail::DMARC::PurePerl'
21             || ref $_ eq 'Mail::DMARC::Result'
22             }
23             => message {"dmarc_object Must be a Mail::DMARC::PurePerl, Mail::DMARC::Result, or Undefined"};
24              
25             coerce 'Mail::BIMI::Options'
26             => from 'HashRef'
27             => via {
28             my $args = $_;
29             my $options = Mail::BIMI::Options->new;
30             foreach my $option ( sort keys $args->%* ) {
31             $options->$option($args->{$option});
32             }
33             return $options;
34             };
35              
36             has domain => ( is => 'rw', isa => 'Str', required => 0,
37             documentation => 'inputs: Domain to lookup/domain record was retrieved from', );
38             has selector => ( is => 'rw', isa => 'Str', lazy => 1, default => sub{ return 'default' },
39             documentation => 'inputs: Selector to lookup/selector record was retrieved from', );
40             has dmarc_object => ( is => 'rw', isa => 'MaybeDMARC',
41             documentation => 'inputs: Validated Mail::DMARC::PurePerl object from parsed message', );
42             has spf_object => ( is => 'rw', isa => 'Mail::SPF::Result',
43             documentation => 'inputs: Mail::SPF::Result object from parsed message', );
44             has dmarc_result_object => ( is => 'rw', isa => 'Maybe[Mail::DMARC::Result]', lazy => 1, builder => '_build_dmarc_result_object',
45             documentation => 'Relevant Mail::DMARC::Result object' );
46             has dmarc_pp_object => ( is => 'rw', isa => 'Maybe[Mail::DMARC::PurePerl]', lazy => 1, builder => '_build_dmarc_pp_object',
47             documentation => 'Relevant Mail::DMARC::PurePerl object' );
48             has record => ( is => 'rw', lazy => 1, builder => '_build_record',
49             documentation => 'Mail::BIMI::Record object' );
50             has resolver => ( is => 'rw', lazy => 1, builder => '_build_resolver',
51             documentation => 'inputs: Net::DNS::Resolver object to use for DNS lookups; default used if not set', );
52             has result => ( is => 'rw', lazy => 1, builder => '_build_result',
53             documentation => 'Mail::BIMI::Result object' );
54             has time => ( is => 'ro', lazy => 1, default => sub{return time},
55             documentation => 'time of retrieval - useful in testing' );
56             has options => ( is => 'rw', isa => 'Mail::BIMI::Options', default => sub{Mail::BIMI::Options->new}, coerce => 1,
57             documentation => 'Options class' );
58              
59              
60 7     7   14 sub _build_resolver($self) {
  7         12  
  7         11  
61 7 100       22 if (defined $Mail::BIMI::TestSuite::Resolver) {
62 6         119 return $Mail::BIMI::TestSuite::Resolver;
63             }
64 1         19 my $resolver = Net::DNS::Resolver->new(dnsrch => 0);
65 1         158 $resolver->tcp_timeout( $self->options->dns_client_timeout );
66 1         55 $resolver->udp_timeout( $self->options->dns_client_timeout );
67 1         52 return $resolver;
68             }
69              
70 22     22   47 sub _build_dmarc_result_object($self) {
  22         43  
  22         162  
71 22 100       614 return $self->dmarc_object->result if ref $self->dmarc_object eq 'Mail::DMARC::PurePerl';
72 15 100       338 return $self->dmarc_object if ref $self->dmarc_object eq 'Mail::DMARC::Result';
73 1         21 return;
74             }
75              
76 20     20   35 sub _build_dmarc_pp_object($self) {
  20         40  
  20         29  
77 20 100       535 return $self->dmarc_object if ref $self->dmarc_object eq 'Mail::DMARC::PurePerl';
78 13         57 $self->log_verbose('Building our own Mail::DMARC::PurePerl object');
79 13         124 my $dmarc = Mail::DMARC::PurePerl->new;
80 13         545 $dmarc->set_resolver($self->resolver);
81 13         376 $dmarc->header_from($self->domain);
82 13         367503 $dmarc->validate;
83 13         130869 return $dmarc;
84             }
85              
86 41     41   103 sub _build_record($self) {
  41         95  
  41         83  
87 41 100       996 croak 'Domain required' if ! $self->domain;
88 40         819 return Mail::BIMI::Record->new( domain => $self->domain, selector => $self->selector, bimi_object => $self );
89             }
90              
91 20     20   48 sub _check_dmarc_enforcement_status($self,$dmarc,$result) {
  20         41  
  20         39  
  20         38  
  20         34  
92             # Set result and return true if there are any DMARC enforcement issues, Return false if there are none
93 20 50       64 if (exists $dmarc->result->{published}){
94 20   50     160 my $published_policy = $dmarc->result->published->p // '';
95 20   100     497 my $published_subdomain_policy = $dmarc->result->published->sp // '';
96 20   50     308 my $published_policy_pct = $dmarc->result->published->pct // 100;
97 20 100 66     329 my $effective_published_policy = ( $dmarc->is_subdomain && $published_subdomain_policy ) ? lc $published_subdomain_policy : lc $published_policy;
98 20 50 33     197 if ( $effective_published_policy eq 'quarantine' && $published_policy_pct ne '100' ) {
99 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'DMARC_NOT_ENFORCING'));
100 0         0 return 1;
101             }
102 20 50 33     136 if ( $effective_published_policy ne 'quarantine' && $effective_published_policy ne 'reject' ) {
103 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'DMARC_NOT_ENFORCING'));
104 0         0 return 1;
105             }
106 20 50 66     107 if ( $published_subdomain_policy && $published_subdomain_policy eq 'none' ) {
107 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'DMARC_NOT_ENFORCING'));
108 0         0 return 1;
109             }
110             }
111             else {
112 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'NO_DMARC'));
113 0         0 return 1;
114             }
115 20         150 return 0;
116             }
117              
118 21     21   48 sub _build_result($self) {
  21         245  
  21         37  
119 21 100       514 croak 'Domain required' if ! $self->domain;
120              
121 20         314 my $result = Mail::BIMI::Result->new(
122             bimi_object => $self,
123             headers => {},
124             );
125              
126             # does DMARC pass
127 20 100       28238 if ( ! $self->dmarc_result_object ) {
128 1         12 $result->set_result( Mail::BIMI::Error->new(code=>'NO_DMARC'));
129 1         8 return $result;
130             }
131 19 100       472 if ( $self->dmarc_result_object->result ne 'pass' ) {
132 1         34 $result->set_result( Mail::BIMI::Error->new(code=>'DMARC_NOT_PASS',detail=>$self->dmarc_result_object->result));
133 1         9 return $result;
134             }
135              
136             # Is DMARC enforcing?
137 18         559 my $dmarc = $self->dmarc_pp_object;
138 18 50       82 return $result if $self->_check_dmarc_enforcement_status($dmarc,$result);
139              
140             # Is Org DMARC Enforcing?
141 18         102 my $org_domain = Mail::DMARC::PurePerl->new->get_organizational_domain($self->domain);
142 18 100       1753 if ( lc $org_domain ne lc $self->domain ) {
143 2         9 my $org_dmarc = Mail::DMARC::PurePerl->new;
144 2         72 $org_dmarc->set_resolver($self->resolver);
145 2         19 $org_dmarc->header_from($org_domain);
146 2         566 $org_dmarc->validate;
147 2 50       16586 return $result if $self->_check_dmarc_enforcement_status($org_dmarc,$result);
148             }
149              
150             # Optionally check Author Domain SPF
151 18 100       446 if ( $self->options->strict_spf ) {
152 1 50       22 if ( $self->spf_object ) {
153 1         25 my $spf_request = $self->spf_object->request;
154 1 50       166 if ( $spf_request ) {
155 1         6 my $spf_record = $spf_request->record;
156 1 50       75 if ( $spf_record ) {
157 1         514 my @spf_terms = $spf_record->terms;
158 1 50       9 if ( @spf_terms ) {
159 1         3 my $last_term = pop @spf_terms;
160 1 50 33     9 if ( $last_term->name eq 'all' && $last_term->qualifier eq '+') {
161 1         21 $result->set_result( Mail::BIMI::Error->new(code=>'SPF_PLUS_ALL'));
162 1         8 return $result;
163             }
164             }
165             }
166             }
167             }
168             }
169              
170 17 100       416 if ( ! $self->record->is_valid ) {
171 10         27 my $has_error;
172             # Known errors, in order of importance
173 10         125 my @known_errors = qw{
174             NO_BIMI_RECORD
175             DNS_ERROR
176             NO_DMARC
177             MULTI_BIMI_RECORD
178             DUPLICATE_KEY
179             EMPTY_L_TAG
180             EMPTY_V_TAG
181             INVALID_V_TAG
182             MISSING_L_TAG
183             MISSING_V_TAG
184             MULTIPLE_AUTHORITIES
185             MULTIPLE_LOCATIONS
186             INVALID_TRANSPORT_A
187             INVALID_TRANSPORT_L
188             SPF_PLUS_ALL
189             SVG_FETCH_ERROR
190             VMC_FETCH_ERROR
191             VMC_EXPIRED
192             VMC_PARSE_ERROR
193             VMC_VALIDATION_ERROR
194             SVG_GET_ERROR
195             SVG_SIZE
196             SVG_UNZIP_ERROR
197             SVG_INVALID_XML
198             SVG_VALIDATION_ERROR
199             SVG_MISMATCH
200             VMC_REQUIRED
201             };
202 10         29 my $found_error = 0;
203              
204 10         33 foreach my $known_error (@known_errors) {
205 48 100       971 if ( my ($error) = $self->record->filter_errors( $known_error ) ) {
206 10         27 $found_error = 1;
207 10         69 $result->set_result( $error );
208 10         25 last;
209             }
210             }
211 10 50       48 if ( !$found_error ) {
212 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'BIMI_INVALID'));
213             }
214 10         257 return $result;
215             }
216              
217 7         69 $result->set_result( 'pass' );
218              
219 7         16 my @bimi_location;
220 7 50 33     157 if ( $self->record->authority && $self->record->authority->is_relevant ) {
221 0 0       0 push @bimi_location, ' l='.$self->record->location->uri if $self->record->location_is_relevant;
222 0         0 push @bimi_location, ' a='.$self->record->authority->uri;
223 0         0 $result->headers->{'BIMI-Indicator'} = $self->record->authority->vmc->indicator->header;
224             }
225             else {
226 7         153 push @bimi_location, ' l='.$self->record->location->uri;
227 7         150 $result->headers->{'BIMI-Indicator'} = $self->record->location->indicator->header;
228             }
229              
230 7         173 $result->headers->{'BIMI-Location'} = join( "\n",
231             'v=BIMI1;',
232             @bimi_location,
233             );
234              
235 7         152 return $result;
236             }
237              
238              
239 14     14 1 35 sub finish($self) {
  14         42  
  14         24  
240 14 50       335 $self->record->finish if $self->record;
241             }
242              
243              
244 283     283 1 3175 sub log_verbose($self,$text) {
  283         689  
  283         505  
  283         386  
245 283 100       6223 return unless $self->options->verbose;
246 1         63 warn "$text\n";
247             }
248              
249             1;
250              
251             __END__
252              
253             =pod
254              
255             =encoding UTF-8
256              
257             =head1 NAME
258              
259             Mail::BIMI - BIMI object
260              
261             =head1 VERSION
262              
263             version 3.20210301
264              
265             =head1 DESCRIPTION
266              
267             Brand Indicators for Message Identification (BIMI) retrieval, validation, and processing
268              
269             =head1 SYNOPSIS
270              
271             # Assuming we have a message, and have verified it has exactly one From Header domain, and passes
272             # any other BIMI and local site requirements not related to BIMI record validation...
273             # For example, relevant DKIM coverage of any BIMI-Selector header
274             my $message = ...Specifics of adding headers and Authentication-Results is left to the reader...
275              
276             my $domain = "example.com"; # domain from From header
277             my $selector = "default"; # selector from From header
278             my $spf = Mail::SPF->new( ...See Mail::SPF POD for options... );
279             my $dmarc = Mail::DMARC::PurePerl->new( ...See Mail::DMARC POD for options... );
280             $dmarc->validate;
281              
282             my $bimi = Mail::BIMI->new(
283             dmarc_object => $dmarc,
284             spf_object => $spf,
285             domain => $domain,
286             selector => $selector,
287             );
288              
289             my $auth_results = $bimi->get_authentication_results_object;
290             my $bimi_result = $bimi->result;
291              
292             $message->add_auth_results($auth_results); # See Mail::AuthenticationResults POD for usage
293              
294             if ( $bimi_result->result eq 'pass' ) {
295             my $headers = $result->headers;
296             if ($headers) {
297             $message->add_header( 'BIMI-Location', $headers->{'BIMI-Location'} if exists $headers->{'BIMI-Location'};
298             $message->add_header( 'BIMI-Indicator', $headers->{'BIMI-Indicator'} if exists $headers->{'BIMI-Indicator'};
299             }
300             }
301              
302             =head1 INPUTS
303              
304             These values are used as inputs for lookups and verifications, they are typically set by the caller based on values found in the message being processed
305              
306             =head2 dmarc_object
307              
308             is=rw
309              
310             Validated Mail::DMARC::PurePerl object from parsed message
311              
312             =head2 domain
313              
314             is=rw
315              
316             Domain to lookup/domain record was retrieved from
317              
318             =head2 resolver
319              
320             is=rw
321              
322             Net::DNS::Resolver object to use for DNS lookups; default used if not set
323              
324             =head2 selector
325              
326             is=rw
327              
328             Selector to lookup/selector record was retrieved from
329              
330             =head2 spf_object
331              
332             is=rw
333              
334             Mail::SPF::Result object from parsed message
335              
336             =head1 ATTRIBUTES
337              
338             These values are derived from lookups and verifications made based upon the input values, it is however possible to override these with other values should you wish to, for example, validate a record before it is published in DNS, or validate an Indicator which is only available locally
339              
340             =head2 dmarc_pp_object
341              
342             is=rw
343              
344             Relevant Mail::DMARC::PurePerl object
345              
346             =head2 dmarc_result_object
347              
348             is=rw
349              
350             Relevant Mail::DMARC::Result object
351              
352             =head2 errors
353              
354             is=rw
355              
356             =head2 options
357              
358             is=rw
359              
360             Options class
361              
362             =head2 record
363              
364             is=rw
365              
366             Mail::BIMI::Record object
367              
368             =head2 result
369              
370             is=rw
371              
372             Mail::BIMI::Result object
373              
374             =head2 time
375              
376             is=ro
377              
378             time of retrieval - useful in testing
379              
380             =head2 warnings
381              
382             is=rw
383              
384             =head1 CONSUMES
385              
386             =over 4
387              
388             =item * L<Mail::BIMI::Role::HasError>
389              
390             =back
391              
392             =head1 EXTENDS
393              
394             =over 4
395              
396             =item * L<Moose::Object>
397              
398             =back
399              
400             =head1 METHODS
401              
402             =head2 I<finish()>
403              
404             Finish and clean up, write cache if enabled.
405              
406             =head2 I<log_verbose()>
407              
408             Output given text if in verbose mode.
409              
410             =head1 REQUIRES
411              
412             =over 4
413              
414             =item * L<Mail::BIMI::Options|Mail::BIMI::Options>
415              
416             =item * L<Mail::BIMI::Prelude|Mail::BIMI::Prelude>
417              
418             =item * L<Mail::BIMI::Record|Mail::BIMI::Record>
419              
420             =item * L<Mail::BIMI::Result|Mail::BIMI::Result>
421              
422             =item * L<Mail::DMARC::PurePerl|Mail::DMARC::PurePerl>
423              
424             =item * L<Moose|Moose>
425              
426             =item * L<Moose::Util::TypeConstraints|Moose::Util::TypeConstraints>
427              
428             =item * L<Net::DNS::Resolver|Net::DNS::Resolver>
429              
430             =back
431              
432             =head1 AUTHOR
433              
434             Marc Bradshaw <marc@marcbradshaw.net>
435              
436             =head1 COPYRIGHT AND LICENSE
437              
438             This software is copyright (c) 2020 by Marc Bradshaw.
439              
440             This is free software; you can redistribute it and/or modify it under
441             the same terms as the Perl 5 programming language system itself.
442              
443             =cut