File Coverage

blib/lib/Mail/BIMI.pm
Criterion Covered Total %
statement 129 142 90.8
branch 41 58 70.6
condition 10 24 41.6
subroutine 17 17 100.0
pod 2 2 100.0
total 199 243 81.8


line stmt bran cond sub pod time code
1             package Mail::BIMI;
2             # ABSTRACT: BIMI object
3             our $VERSION = '3.20210512'; # VERSION
4 29     29   3390945 use 5.20.0;
  29         121  
5 29     29   16306 use Moose;
  29         13730621  
  29         213  
6 29     29   215548 use Moose::Util::TypeConstraints;
  29         79  
  29         839  
7 29     29   65016 use Mail::BIMI::Prelude;
  29         64  
  29         256  
8 29     29   28958 use Mail::BIMI::Options;
  29         115  
  29         1756  
9 29     29   19970 use Mail::BIMI::Record;
  29         277  
  29         3526  
10 29     29   19490 use Mail::BIMI::Result;
  29         149  
  29         1596  
11 29     29   313 use Mail::DMARC::PurePerl;
  29         73  
  29         1036  
12 29     29   182 use Net::DNS::Resolver;
  29         68  
  29         63501  
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 1     1   3 sub _build_resolver($self) {
  1         3  
  1         1  
61 1 50       5 if (defined $Mail::BIMI::TestSuite::Resolver) {
62 0         0 return $Mail::BIMI::TestSuite::Resolver;
63             }
64 1         18 my $resolver = Net::DNS::Resolver->new(dnsrch => 0);
65 1         153 $resolver->tcp_timeout( $self->options->dns_client_timeout );
66 1         60 $resolver->udp_timeout( $self->options->dns_client_timeout );
67 1         53 return $resolver;
68             }
69              
70 16     16   42 sub _build_dmarc_result_object($self) {
  16         37  
  16         158  
71 16 100       467 return $self->dmarc_object->result if ref $self->dmarc_object eq 'Mail::DMARC::PurePerl';
72 15 100       419 return $self->dmarc_object if ref $self->dmarc_object eq 'Mail::DMARC::Result';
73 1         25 return;
74             }
75              
76 14     14   31 sub _build_dmarc_pp_object($self) {
  14         34  
  14         29  
77 14 100       412 return $self->dmarc_object if ref $self->dmarc_object eq 'Mail::DMARC::PurePerl';
78 13         74 $self->log_verbose('Building our own Mail::DMARC::PurePerl object');
79 13         147 my $dmarc = Mail::DMARC::PurePerl->new;
80 13         639 $dmarc->set_resolver($self->resolver);
81 13         421 $dmarc->header_from($self->domain);
82 13         435635 $dmarc->validate;
83 13         148267 return $dmarc;
84             }
85              
86 32     32   86 sub _build_record($self) {
  32         86  
  32         73  
87 32 100       825 croak 'Domain required' if ! $self->domain;
88 31         696 return Mail::BIMI::Record->new( domain => $self->domain, selector => $self->selector, bimi_object => $self );
89             }
90              
91 14     14   44 sub _check_dmarc_enforcement_status($self,$dmarc,$result) {
  14         41  
  14         31  
  14         33  
  14         30  
92             # Set result and return true if there are any DMARC enforcement issues, Return false if there are none
93 14 50       61 if (exists $dmarc->result->{published}){
94 14   50     143 my $published_policy = $dmarc->result->published->p // '';
95 14   50     963 my $published_subdomain_policy = $dmarc->result->published->sp // '';
96 14   50     318 my $published_policy_pct = $dmarc->result->published->pct // 100;
97 14 100 66     271 my $effective_published_policy = ( $dmarc->is_subdomain && $published_subdomain_policy ) ? lc $published_subdomain_policy : lc $published_policy;
98 14 50 33     868 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 14 50 33     122 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 14 50 33     175 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 14         166 return 0;
116             }
117              
118 15     15   40 sub _build_result($self) {
  15         334  
  15         34  
119 15 100       437 croak 'Domain required' if ! $self->domain;
120              
121 14         262 my $result = Mail::BIMI::Result->new(
122             bimi_object => $self,
123             headers => {},
124             );
125              
126             # does DMARC pass
127 14 100       23102 if ( ! $self->dmarc_result_object ) {
128 1         12 $result->set_result( Mail::BIMI::Error->new(code=>'NO_DMARC'));
129 1         7 return $result;
130             }
131 13 100       489 if ( $self->dmarc_result_object->result ne 'pass' ) {
132 1         31 $result->set_result( Mail::BIMI::Error->new(code=>'DMARC_NOT_PASS',detail=>$self->dmarc_result_object->result));
133 1         8 return $result;
134             }
135              
136             # Is DMARC enforcing?
137 12         435 my $dmarc = $self->dmarc_pp_object;
138 12 50       79 return $result if $self->_check_dmarc_enforcement_status($dmarc,$result);
139              
140             # Is Org DMARC Enforcing?
141 12         92 my $org_domain = Mail::DMARC::PurePerl->new->get_organizational_domain($self->domain);
142 12 100       1422 if ( lc $org_domain ne lc $self->domain ) {
143 2         12 my $org_dmarc = Mail::DMARC::PurePerl->new;
144 2         83 $org_dmarc->set_resolver($self->resolver);
145 2         26 $org_dmarc->header_from($org_domain);
146 2         788 $org_dmarc->validate;
147 2 50       20842 return $result if $self->_check_dmarc_enforcement_status($org_dmarc,$result);
148             }
149              
150             # Optionally check Author Domain SPF
151 12 100       394 if ( $self->options->strict_spf ) {
152 1 50       28 if ( $self->spf_object ) {
153 1         30 my $spf_request = $self->spf_object->request;
154 1 50       164 if ( $spf_request ) {
155 1         7 my $spf_record = $spf_request->record;
156 1 50       86 if ( $spf_record ) {
157 1         649 my @spf_terms = $spf_record->terms;
158 1 50       10 if ( @spf_terms ) {
159 1         3 my $last_term = pop @spf_terms;
160 1 50 33     11 if ( $last_term->name eq 'all' && $last_term->qualifier eq '+') {
161 1         26 $result->set_result( Mail::BIMI::Error->new(code=>'SPF_PLUS_ALL'));
162 1         7 return $result;
163             }
164             }
165             }
166             }
167             }
168             }
169              
170 11 100       312 if ( ! $self->record->is_valid ) {
171 7         25 my $has_error;
172             # Known errors, in order of importance
173 7         83 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 7         21 my $found_error = 0;
203              
204 7         25 foreach my $known_error (@known_errors) {
205 22 100       509 if ( my ($error) = $self->record->filter_errors( $known_error ) ) {
206 7         22 $found_error = 1;
207 7         61 $result->set_result( $error );
208 7         20 last;
209             }
210             }
211 7 50       55 if ( !$found_error ) {
212 0         0 $result->set_result( Mail::BIMI::Error->new(code=>'BIMI_INVALID'));
213             }
214 7         199 return $result;
215             }
216              
217 4         37 $result->set_result( 'pass' );
218              
219 4         13 my @bimi_location;
220 4 50 33     111 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 4         100 push @bimi_location, ' l='.$self->record->location->uri;
227 4         102 $result->headers->{'BIMI-Indicator'} = $self->record->location->indicator->header;
228             }
229              
230 4         115 $result->headers->{'BIMI-Location'} = join( "\n",
231             'v=BIMI1;',
232             @bimi_location,
233             );
234              
235 4         102 return $result;
236             }
237              
238              
239 5     5 1 18 sub finish($self) {
  5         30  
  5         13  
240 5 50       157 $self->record->finish if $self->record;
241             }
242              
243              
244 237     237 1 3502 sub log_verbose($self,$text) {
  237         676  
  237         429  
  237         398  
245 237 100       5584 return unless $self->options->verbose;
246 1         91 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.20210512
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