File Coverage

blib/lib/Mail/BIMI/VMC/Chain.pm
Criterion Covered Total %
statement 29 143 20.2
branch 0 60 0.0
condition 0 16 0.0
subroutine 10 14 71.4
pod 2 2 100.0
total 41 235 17.4


line stmt bran cond sub pod time code
1             package Mail::BIMI::VMC::Chain;
2             # ABSTRACT: Class to model a VMC Chain
3             our $VERSION = '3.20210512'; # VERSION
4 29     29   538 use 5.20.0;
  29         122  
5 29     29   201 use Moose;
  29         65  
  29         255  
6 29     29   201324 use Mail::BIMI::Prelude;
  29         80  
  29         305  
7 29     29   25552 use Mail::BIMI::VMC::Cert;
  29         144  
  29         1785  
8 29     29   300 use Crypt::OpenSSL::X509 1.812;
  29         780  
  29         1692  
9 29     29   203 use Crypt::OpenSSL::Verify 0.20;
  29         406  
  29         955  
10 29     29   178 use File::Slurp qw{ read_file write_file };
  29         68  
  29         1902  
11 29     29   183 use File::Temp;
  29         72  
  29         2336  
12 29     29   19105 use Mozilla::CA;
  29         9500  
  29         1095  
13 29     29   221 use Term::ANSIColor qw{ :constants };
  29         73  
  29         66273  
14              
15             extends 'Mail::BIMI::Base';
16             with(
17             'Mail::BIMI::Role::Data',
18             'Mail::BIMI::Role::HasError',
19             );
20             has cert_list => ( is => 'rw', isa => 'ArrayRef',
21             documentation => 'ArrayRef of individual Certificates in the chain' );
22             has cert_object_list => ( is => 'rw', isa => 'ArrayRef', lazy => 1, builder => '_build_cert_object_list',
23             documentation => 'ArrayRef of Crypt::OpenSSL::X509 objects for the Certificates in the chain' );
24             has is_valid => ( is => 'rw', lazy => 1, builder => '_build_is_valid',
25             documentation => 'Does the VMC of this chain validate back to root?' );
26              
27              
28 0     0     sub _build_is_valid($self) {
  0            
  0            
29             # Start with root cert validations
30 0 0         return 0 if !$self->vmc;
31              
32 0           my $ssl_root_cert = $self->bimi_object->options->ssl_root_cert;
33 0           my $unlink_root_cert_file = 0;
34 0 0         if ( !$ssl_root_cert ) {
35 0           my $mozilla_root = scalar read_file Mozilla::CA::SSL_ca_file;
36 0           my $bimi_root = $self->get_data_from_file('CA.pem');
37 0           my $temp_fh = File::Temp->new(UNLINK=>0);
38 0           $ssl_root_cert = $temp_fh->filename;
39 0           $unlink_root_cert_file = 1;
40 0           print $temp_fh join("\n",$mozilla_root,$bimi_root);
41 0           close $temp_fh;
42             }
43              
44 0           my $root_ca = Crypt::OpenSSL::Verify->new($ssl_root_cert,{noCApath=>0});
45 0           my $root_ca_ascii = scalar read_file $ssl_root_cert;
46 0           foreach my $cert ( $self->cert_object_list->@* ) {
47 0           my $i = $cert->index;
48 0 0         if ($cert->is_expired) {
49 0           $self->log_verbose("Certificate $i is expired");
50 0           next;
51             }
52 0 0         if ( !$cert->is_valid ) {
53 0           $self->log_verbose("Certificate $i is not valid");
54 0           next;
55             }
56 0 0         if ( !$cert->has_valid_usage ) {
57 0           $self->log_verbose("Certificate $i does not have valid usage flags for BIMI");
58 0           next;
59             }
60 0           my $is_valid = 0;
61 0           eval {
62 0           $root_ca->verify($cert->x509_object);
63 0           $is_valid = 1;
64             };
65 0 0         if ( !$is_valid ) {
66 0           $self->log_verbose("Certificate $i not directly validated to root");
67             # NOP
68             }
69             else {
70 0           $self->log_verbose("Certificate $i directly validated to root");
71 0           $cert->validated_by($root_ca_ascii);
72 0           $cert->validated_by_id(0);
73 0           $cert->is_valid_to_root(1);
74             }
75             }
76              
77 0           my $iteration_did_no_work;
78 0           do {
79 0           $iteration_did_no_work = 1;
80             VALIDATED_CERT:
81 0           foreach my $validated_cert ( $self->cert_object_list->@* ) {
82 0 0         next VALIDATED_CERT if ! $validated_cert->is_valid_to_root;
83 0           my $validated_i = $validated_cert->index;
84             VALIDATING_CERT:
85 0           foreach my $validating_cert ( $self->cert_object_list->@* ) {
86 0 0         next VALIDATING_CERT if $validating_cert->is_valid_to_root;
87 0           my $validating_i = $validating_cert->index;
88 0 0         if ($validating_cert->is_expired) {
89 0           $self->log_verbose("Certificate $validating_i is expired");
90 0           next;
91             }
92 0 0         if ( !$validating_cert->is_valid ) {
93 0           $self->log_verbose("Certificate $validating_i is not valid");
94 0           next VALIDATING_CERT;
95             }
96 0           eval{
97 0           $validated_cert->verifier->verify($validating_cert->x509_object);
98 0           $self->log_verbose("Certificate $validating_i validated to root via certificate $validated_i");
99 0           $validating_cert->validated_by($validated_cert->full_chain);
100 0           $validating_cert->validated_by_id($validated_i);
101 0           $validating_cert->is_valid_to_root(1);
102 0           $iteration_did_no_work = 0;
103             };
104             }
105             }
106             } until $iteration_did_no_work;
107 0 0         if ( !$self->vmc->is_valid_to_root ) {
108 0           $self->add_error('VMC_PARSE_ERROR','Could not verify VMC');
109             }
110              
111 0 0 0       if ( $unlink_root_cert_file && -f $ssl_root_cert ) {
112 0 0         unlink $ssl_root_cert or warn "Unable to unlink temporary chain file: $!";
113             }
114              
115 0 0         return 0 if $self->errors->@*;
116 0           return 1;
117             }
118              
119              
120 0     0 1   sub vmc($self) {
  0            
  0            
121 0           my $vmc;
122 0           foreach my $cert ( $self->cert_object_list->@* ) {
123 0           my $x509_object = $cert->x509_object;
124 0 0         next if !$x509_object;
125 0           my $exts = eval{ $x509_object->extensions_by_oid() };
  0            
126 0 0         next if !$exts;
127 0 0 0       if ( $cert->has_valid_usage && exists $exts->{&LOGOTYPE_OID}) {
128             # Has both extended usage and embedded Indicator
129 0 0         $self->add_error('VMC_VALIDATION_ERROR','Multiple VMCs found in chain') if $vmc;
130 0           $vmc = $cert;
131             }
132             }
133 0 0         if ( !$vmc ) {
134 0           $self->add_error('VMC_VALIDATION_ERROR','No valid VMC found in chain');
135             }
136 0           return $vmc;
137             }
138              
139 0     0     sub _build_cert_object_list($self) {
  0            
  0            
140 0           my @objects;
141 0           my $i = 1;
142 0           foreach my $cert ( $self->cert_list->@* ) {
143 0           push @objects, Mail::BIMI::VMC::Cert->new(
144             bimi_object => $self->bimi_object,
145             chain => $self,
146             ascii_lines => $cert,
147             index => $i++,
148             );
149             }
150 0           return \@objects;
151             }
152              
153              
154 0     0 1   sub app_validate($self) {
  0            
  0            
155 0 0         say 'Certificate Chain Returned: '.($self->is_valid ? GREEN."\x{2713}" : BRIGHT_RED."\x{26A0}").RESET;
156 0           foreach my $cert ( $self->cert_object_list->@* ) {
157 0           my $i = $cert->index;
158 0           my $obj = $cert->x509_object;
159 0           say '';
160 0 0         say YELLOW.' Certificate '.$i.WHITE.': '.($cert->is_valid ? GREEN."\x{2713}" : BRIGHT_RED."\x{26A0}").RESET;
161 0 0         if ( $obj ) {
162 0   0       say YELLOW.' Subject '.WHITE.': '.CYAN.($obj->subject//'-none-').RESET;
163 0   0       say YELLOW.' Not Before '.WHITE.': '.CYAN.($obj->notBefore//'-none-').RESET;
164 0   0       say YELLOW.' Not After '.WHITE.': '.CYAN.($obj->notAfter//'-none-').RESET;
165 0   0       say YELLOW.' Issuer '.WHITE.': '.CYAN.($obj->issuer//'-none-').RESET;
166 0 0         say YELLOW.' Expired '.WHITE.': '.($obj->checkend(0)?BRIGHT_RED.'Yes':GREEN.'No').RESET;
167 0           my $exts = eval{ $obj->extensions_by_oid() };
  0            
168 0 0         if ( $exts ) {
169 0 0         my $alt_name = exists $exts->{'2.5.29.17'} ? $exts->{'2.5.29.17'}->to_string : '-none-';
170 0   0       say YELLOW.' Alt Name '.WHITE.': '.CYAN.($alt_name//'-none-').RESET;
171 0 0         say YELLOW.' Has LogotypeExtn '.WHITE.': '.CYAN.(exists($exts->{&LOGOTYPE_OID})?GREEN.'Yes':BRIGHT_RED.'No').RESET;
172             }
173             else {
174 0           say YELLOW.' Extensions '.WHITE.': '.BRIGHT_RED.'NOT FOUND'.RESET;
175             }
176 0 0         say YELLOW.' Has Valid Usage '.WHITE.': '.CYAN.($cert->has_valid_usage?GREEN.'Yes':BRIGHT_RED.'No').RESET;
177             }
178 0 0         say YELLOW.' Valid to Root '.WHITE.': '.CYAN.($cert->is_valid_to_root?GREEN.($cert->validated_by_id == 0?'Direct':'Via cert '.$cert->validated_by_id):BRIGHT_RED.'No').RESET;
    0          
179 0 0         say YELLOW.' Is Valid '.WHITE.': '.CYAN.($cert->is_valid?GREEN.'Yes':BRIGHT_RED.'No').RESET;
180             }
181             }
182              
183             1;
184              
185             __END__
186              
187             =pod
188              
189             =encoding UTF-8
190              
191             =head1 NAME
192              
193             Mail::BIMI::VMC::Chain - Class to model a VMC Chain
194              
195             =head1 VERSION
196              
197             version 3.20210512
198              
199             =head1 DESCRIPTION
200              
201             Class for representing, retrieving, validating, and processing a VMC Certificate Chain
202              
203             =head1 ATTRIBUTES
204              
205             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
206              
207             =head2 cert_list
208              
209             is=rw
210              
211             ArrayRef of individual Certificates in the chain
212              
213             =head2 cert_object_list
214              
215             is=rw
216              
217             ArrayRef of Crypt::OpenSSL::X509 objects for the Certificates in the chain
218              
219             =head2 errors
220              
221             is=rw
222              
223             =head2 is_valid
224              
225             is=rw
226              
227             Does the VMC of this chain validate back to root?
228              
229             =head2 warnings
230              
231             is=rw
232              
233             =head1 CONSUMES
234              
235             =over 4
236              
237             =item * L<Mail::BIMI::Role::Data>
238              
239             =item * L<Mail::BIMI::Role::Data|Mail::BIMI::Role::HasError>
240              
241             =item * L<Mail::BIMI::Role::HasError>
242              
243             =back
244              
245             =head1 EXTENDS
246              
247             =over 4
248              
249             =item * L<Mail::BIMI::Base>
250              
251             =back
252              
253             =head1 METHODS
254              
255             =head2 I<vmc()>
256              
257             Locate and return the VMC object from this chain.
258              
259             =head2 I<app_validate()>
260              
261             Output human readable validation status of this object
262              
263             =head1 REQUIRES
264              
265             =over 4
266              
267             =item * L<Crypt::OpenSSL::Verify|Crypt::OpenSSL::Verify>
268              
269             =item * L<Crypt::OpenSSL::X509|Crypt::OpenSSL::X509>
270              
271             =item * L<File::Slurp|File::Slurp>
272              
273             =item * L<File::Temp|File::Temp>
274              
275             =item * L<Mail::BIMI::Prelude|Mail::BIMI::Prelude>
276              
277             =item * L<Mail::BIMI::VMC::Cert|Mail::BIMI::VMC::Cert>
278              
279             =item * L<Moose|Moose>
280              
281             =item * L<Mozilla::CA|Mozilla::CA>
282              
283             =item * L<Term::ANSIColor|Term::ANSIColor>
284              
285             =back
286              
287             =head1 AUTHOR
288              
289             Marc Bradshaw <marc@marcbradshaw.net>
290              
291             =head1 COPYRIGHT AND LICENSE
292              
293             This software is copyright (c) 2020 by Marc Bradshaw.
294              
295             This is free software; you can redistribute it and/or modify it under
296             the same terms as the Perl 5 programming language system itself.
297              
298             =cut