/[pdpsoft]/nl.nikhef.pdp.fetchcrl/trunk/TrustAnchor.pm
ViewVC logotype

Annotation of /nl.nikhef.pdp.fetchcrl/trunk/TrustAnchor.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3275 - (hide annotations) (download) (as text)
Thu Jan 16 20:33:09 2020 UTC (21 months ago) by davidg
File MIME type: application/x-perl
File size: 28912 byte(s)
Allow overriding of UserAgent strings of the perl LWP libwww-perl. This mitigates hyperactive Fortigates that block libwww-perl clients

1 davidg 1758 #
2     # @(#)$Id$
3     #
4     # ###########################################################################
5     #
6     #
7     package TrustAnchor;
8     use strict;
9     use File::Basename;
10     use LWP;
11     require ConfigTiny and import ConfigTiny unless defined &ConfigTiny::new;
12     require CRL and import CRL unless defined &CRL::new;
13     require base64 and import base64 unless defined &base64::b64encode;
14     use vars qw/ $log $cnf /;
15    
16     sub new {
17     my $obref = {}; bless $obref;
18     my $self = shift;
19     $self = $obref;
20     my $name = shift;
21    
22     $self->{"infodir"} = $cnf->{_}->{infodir};
23     $self->{"suffix"} = "info";
24    
25     $self->loadAnchor($name) if defined $name;
26    
27     return $self;
28     }
29    
30     sub saveLogMode($) {
31     my $self = shift;
32     return 0 unless defined $self;
33     $self->{"preserve_warnings"} = $::log->getwarnings;
34     $self->{"preserve_errors"} = $::log->geterrors;
35     return 1;
36     }
37    
38     sub setLogMode($) {
39     my $self = shift;
40     return 0 unless defined $self;
41     $self->{"nowarnings"} and $::log->setwarnings(0);
42     $self->{"noerrors"} and $::log->seterrors(0);
43     return 1;
44     }
45    
46     sub restoreLogMode($) {
47     my $self = shift;
48     return 0 unless defined $self;
49 davidg 2188 (defined $self->{"preserve_warnings"} and defined $self->{"preserve_errors"})
50     or die "Internal error: restoreLogMode called without previous save\n";
51 davidg 1758 $::log->setwarnings($self->{"preserve_warnings"});
52     $::log->seterrors($self->{"preserve_errors"});
53     return 1;
54     }
55    
56     sub getInfodir($$) {
57     my $self = shift;
58     my ($path) = shift;
59     return 0 unless defined $self;
60    
61     return $self->{"infodir"};
62     }
63    
64     sub setInfodir($$) {
65     my $self = shift;
66     my ($path) = shift;
67     return 0 unless defined $path and defined $self;
68    
69     -e $path or
70     $::log->err("setInfodir: path $path does not exist") and return 0;
71     -d $path or
72     $::log->err("setInfodir: path $path is not a directory") and return 0;
73    
74     $self->{"infodir"} = $path;
75    
76     return 1;
77     }
78    
79    
80     sub loadAnchor($$) {
81     my $self = shift;
82     my ($name) = @_;
83     return 0 unless defined $name;
84    
85     $::log->verb(1,"Initializing trust anchor $name");
86    
87     my ( $basename, $path, $suffix) = fileparse($name,('.info','.crl_url'));
88    
89     $path = "" if $path eq "./" and substr($name,0,length($path)) ne $path ;
90    
91     $::log->err("Invalid name of trust anchor $name") and return 0
92     unless $basename;
93    
94     $self->{"infodir"} = $path if $path ne "";
95     $path = $self->{"infodir"} || "";
96     $path and $path .= "/" unless $path =~ /\/$/;
97    
98     if ( $suffix ) {
99     -e $name or
100     $::log->err("Trust anchor data $name not found") and return 0;
101     } else { # try and guess which suffix should be used
102     ($suffix eq "" and -e $path.$basename.".info" ) and $suffix = ".info";
103     ($suffix eq "" and -e $path.$basename.".crl_url" ) and $suffix = ".crl_url";
104     $suffix or
105     $::log->err("No trust anchor metadata for $basename in '$path'")
106     and return 0;
107     }
108    
109     if ( $suffix eq ".crl_url" ) {
110    
111     $self->{"alias"} = $basename;
112     @{$self->{"crlurls"}} = ();
113     open CRLURL,"$path$basename$suffix" or
114     $::log->err("Error reading crl_url $path$basename$suffix: $!") and return 0;
115 davidg 3107 $self->{"filename"} = "$path$basename$suffix";
116 davidg 1758 my $urllist;
117     while (<CRLURL>) {
118     /^\s*([^#\n]+).*$/ and my $url = $1 or next;
119     $url =~ s/\s*$//; # trailing whitespace is ignored
120    
121     $url =~ /^\w+:\/\/.*$/ or
122     $::log->err("File $path$basename$suffix contains a non-URL entry")
123     and close CRLURL and return 0;
124    
125 davidg 2305 $urllist and $urllist .= "\001";
126 davidg 1758 $urllist .= $url;
127     }
128     close CRLURL;
129     push @{$self->{"crlurls"}}, $urllist;
130     $self->{"status"} ||= "unknown";
131    
132     } else {
133    
134     my $info = ConfigTiny->new();
135     $info->read( $path . $basename . $suffix ) or
136     $::log->err("Error reading info $path$basename$suffix", $info->errstr)
137     and return 0;
138 davidg 3107 $self->{"filename"} = "$path$basename$suffix";
139 davidg 1758
140     $info->{_}->{"crl_url"} and $info->{_}->{"crl_url.0"} and
141     $::log->err("Invalid info for $basename: crl_url and .0 duplicate") and
142     return 0;
143     $info->{_}->{"crl_url"} and
144     $info->{_}->{"crl_url.0"} = $info->{_}->{"crl_url"};
145    
146     # only do something when there is actually a CRL to process
147     $info->{_}->{"crl_url.0"} or
148     $::log->verb(1,"Trust anchor $basename does not have a CRL") and return 0;
149    
150     $info->{_}->{"alias"} or
151     $::log->err("Invalid info for $basename: no alias") and
152     return 0;
153     $self->{"alias"} = $info->{_}->{"alias"};
154    
155     @{$self->{"crlurls"}} = ();
156     for ( my $i=0 ; defined $info->{_}{"crl_url.".$i} ; $i++ ) {
157 davidg 2305 $info->{_}{"crl_url.".$i} =~ s/[;\s]+/\001/g;
158 davidg 1758 $info->{_}{"crl_url.".$i} =~ s/^\s*([^\s]*)\s*$/$1/;
159    
160     $info->{_}{"crl_url.".$i} =~ /^\w+:\/\// or
161     $::log->err("File $path$basename$suffix contains a non-URL entry",
162     $info->{_}{"crl_url.".$i})
163     and close CRLURL and return 0;
164    
165     push @{$self->{"crlurls"}} , $info->{_}{"crl_url.".$i};
166     }
167    
168     foreach my $field ( qw/email ca_url status/ ) {
169     $self->{$field} = $info->{_}->{$field} if $info->{_}->{$field};
170     }
171    
172     # status of CA is only knwon for info-file based CAs
173     $self->{"status"} ||= "local";
174    
175     }
176    
177     # preserve basename of file for config and diagnostics
178     $self->{"anchorname"} = $basename;
179    
180     #
181     # set defaults for common values
182     foreach my $key ( qw /
183     prepend_url postpend_url agingtolerance
184     httptimeout proctimeout
185     nowarnings noerrors nocache http_proxy
186     nametemplate_der nametemplate_pem
187     cadir catemplate statedir
188     / ) {
189 davidg 1767 $self->{$key} = $self->{$key} ||
190 davidg 1758 $::cnf->{$self->{"alias"}}->{$key} ||
191     $::cnf->{$self->{"anchorname"}}->{$key} ||
192     $::cnf->{_}->{$key} or delete $self->{$key};
193     defined $self->{$key} and do {
194     $self->{$key} =~ s/\@ANCHORNAME\@/$self->{"anchorname"}/g;
195     $self->{$key} =~ s/\@STATUS\@/$self->{"status"}/g;
196     $self->{$key} =~ s/\@ALIAS\@/$self->{"alias"}/g;
197     };
198     }
199     # reversible toggle options
200     foreach my $key ( qw / warnings errors cache / ) {
201     delete $self->{"no$key"} if $::cnf->{$self->{"alias"}}->{$key} or
202     $::cnf->{$self->{"anchorname"}}->{$key} or
203     $::cnf->{_}->{$key};
204     }
205     foreach my $key ( qw / nohttp_proxy noprepend_url nopostpend_url
206     nostatedir / ) {
207     (my $nokey = $key) =~ s/^no//;
208     delete $self->{"$nokey"} if $::cnf->{$self->{"alias"}}->{$key} or
209     $::cnf->{$self->{"anchorname"}}->{$key} or
210     $::cnf->{_}->{$key};
211     }
212    
213     # overriding of the URLs (alias takes precedence over anchorname
214     foreach my $section ( qw / anchorname alias / ) {
215     my $i = 0;
216     while ( defined ($::cnf->{$self->{$section}}->{"crl_url.".$i}) ) {
217     my $urls;
218 davidg 2305 ($urls=$::cnf->{$self->{$section}}->{"crl_url.".$i} )=~s/[;\s]+/\001/g;
219 davidg 1758 ${$self->{"crlurls"}}[$i] = $urls;
220     $i++;
221     }
222     }
223    
224     # templates to construct a CA name may still have other separators
225 davidg 2305 $self->{"catemplate"} =~ s/[;\s]+/\001/g;
226 davidg 1758
227     # select only http/https/ftp/file URLs
228     # also transform the URLs using the base patterns and prepend any
229     # local URL patterns (@ANCHORNAME@, @ALIAS@, and @R@)
230     for ( my $i=0; $i <= $#{$self->{"crlurls"}} ; $i++ ) {
231     my $urlstring = @{$self->{"crlurls"}}[$i];
232 davidg 2305 my @urls = split(/\001/,$urlstring);
233 davidg 1758 $urlstring="";
234     foreach my $url ( @urls ) {
235     if ( $url =~ /^(http:|https:|ftp:|file:)/ ) {
236 davidg 2305 $urlstring.="\001" if $urlstring; $urlstring.=$url;
237 davidg 1758 } else {
238     $::log->verb(0,"URL $url in $basename$suffix unsupported, ignored");
239     }
240     }
241     if ( my $purl = $self->{"prepend_url"} ) {
242     $purl =~ s/\@R\@/$i/g;
243 davidg 2305 $urlstring = join "\001" , $purl , $urlstring;
244 davidg 1758 }
245     if ( my $purl = $self->{"postpend_url"} ) {
246     $purl =~ s/\@R\@/$i/g;
247 davidg 2305 $urlstring = join "\001" , $urlstring, $purl;
248 davidg 1758 }
249     if ( ! $urlstring ) {
250     $::log->err("No usable CRL URLs for",$self->getAnchorName);
251     $self->{"crlurls"}[$i] = "";
252     } else {
253     $self->{"crlurls"}[$i] = $urlstring;
254     }
255     }
256    
257     return 1;
258     }
259    
260     sub getAnchorName($) {
261     my $self = shift;
262     return ($self->{"anchorname"} || undef);
263     }
264    
265     sub printAnchorName($) {
266     my $self = shift;
267     print "" . ($self->{"anchorname"} || "undefined") ."\n";
268     }
269    
270 davidg 2420 sub displayAnchorName($) {
271     my $self = shift;
272     return ($self->{"anchorname"} || "undefined");
273     }
274    
275 davidg 1758 sub loadCAfiles($) {
276     my $self = shift;
277     my $idx = 0;
278    
279 davidg 1767 # try to find a CA dir, whatever it takes, almost
280     my $cadir = $self->{"cadir"} || $self->{"infodir"};
281    
282     -d $cadir or
283     $::log->err("CA directory",$cadir,"does not exist") and
284 davidg 1758 return 0;
285    
286 davidg 2420 # add @HASH@ support, inducing a file read and fork, only if really needed
287     my $crlhash;
288     if ( $self->{"catemplate"} =~ /\@HASH\@/ ) {
289     $self->{"crl"}[0]{"data"} ne "" or
290     $::log->err("CA name template contains HASH, but no CRL ".
291     "could be loaded in time for ".$self->displayAnchorName) and
292     return 0;
293     my $probecrl = CRL->new(undef,$self->{"crl"}[0]{"data"});
294     $crlhash = $probecrl->getAttribute("hash");
295     $::log->verb(3,"Inferred CA template HASH ".($crlhash?$crlhash:"failed").
296     " for ".$self->displayAnchorName);
297     }
298    
299 davidg 1758 @{$self->{"cafile"}} = ();
300     do {
301     my $cafile;
302 davidg 2420
303 davidg 2305 foreach my $catpl ( split /\001/, $self->{"catemplate"} ) {
304 davidg 1758 $catpl =~ s/\@R\@/$idx/g;
305 davidg 2420 $catpl =~ s/\@HASH\@/$crlhash/g;
306 davidg 1767 -e $cadir.'/'.$catpl and
307     $cafile = $cadir.'/'.$catpl and last;
308 davidg 1758 }
309     defined $cafile or do {
310     $idx or do $::log->err("Cannot find any CA for",
311 davidg 1767 $self->{"alias"},"in",$cadir);
312 davidg 1758 return $idx?1:0;
313     };
314 davidg 1878 # is the new one any different from the previous (i.e. is the CA indexed?)
315     $#{$self->{"cafile"}} >= 0 and
316     $cafile eq $self->{"cafile"}[$#{$self->{"cafile"}}] and return 1;
317 davidg 1758 push @{$self->{"cafile"}}, $cafile;
318     $::log->verb(3,"Added CA file $idx: $cafile");
319     } while(++$idx);
320     return 0; # you never should come here
321     }
322    
323    
324     sub loadState($$) {
325     my $self = shift;
326     my $fallbackmode = shift;
327    
328     $self->{"crlurls"} or
329     $::log->err("loading state for uninitialised list of CRLs") and return 0;
330     $self->{"alias"} or
331     $::log->err("loading state for uninitialised trust anchor") and return 0;
332    
333     for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices
334     if ( $self->{"statedir"} and
335     -e $self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state'
336     ) {
337     my $state = ConfigTiny->new();
338     $state->read($self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state')
339     or $::log->err("Cannot read existing state file",
340     $self->{"statedir"}.'/'.$self->{"alias"}.'.$i.state',
341     " - ",$state->errstr) and return 0;
342     foreach my $key ( keys %{$state->{$self->{"alias"}}} ) {
343     $self->{"crl"}[$i]{"state"}{$key} = $state->{$self->{"alias"}}->{$key};
344     }
345     }
346    
347     # fine, but we should find at least an mtime if at all possible
348     # make sure it is there:
349     # try to retrieve state from installed files in @output_
350     # where the first look-alike CRL will win. NSS databases
351     # are NOT supported for this heuristic
352     if ( ! defined $self->{"crl"}[$i]{"state"}{"mtime"} ) {
353     my $mtime;
354 davidg 1901 STATEHUNT: foreach my $output ( ( $::cnf->{_}->{"output"},
355     $::cnf->{_}->{"output_der"}, $::cnf->{_}->{"output_pem"},
356     $::cnf->{_}->{"output_nss"}, $::cnf->{_}->{"output_openssl"}) ) {
357     defined $output and $output or next;
358 davidg 2305 foreach my $ref (
359 davidg 1758 $self->{"nametemplate_der"},
360     $self->{"nametemplate_pem"},
361     $self->{"alias"}.".r\@R\@",
362     $self->{"anchorname"}.".r\@R\@",
363     ) {
364 davidg 2305 next unless $ref;
365     my $file = $ref; # copy, not to change original
366 davidg 1758 $file =~ s/\@R\@/$i/g;
367     $file = join "/", $output, $file;
368     next if ! -e $file;
369     $mtime = (stat(_))[9];
370     last STATEHUNT;
371     }
372     }
373     $::log->verb(3,"Inferred mtime for",$self->{"alias"},"is",$mtime) if $mtime;
374     $self->{"crl"}[$i]{"state"}{"mtime"} = $mtime if $mtime;
375     }
376 davidg 1901
377     # as a last resort, set mtime to curren time
378     $self->{"crl"}[$i]{"state"}{"mtime"} ||= time;
379    
380 davidg 1758 }
381     return 1;
382     }
383    
384     sub saveState($$) {
385     my $self = shift;
386     my $fallbackmode = shift;
387    
388     $self->{"statedir"} and -d $self->{"statedir"} and -w $self->{"statedir"} or
389     return 0;
390    
391     $self->{"crlurls"} or
392     $::log->err("loading state for uninitialised list of CRLs") and return 0;
393     $self->{"alias"} or
394     $::log->err("loading state for uninitialised trust anchor") and return 0;
395    
396     # of state, mtime is set based on CRL write in $output and filled there
397     for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices
398     if ( defined $self->{"statedir"} and
399     -d $self->{"statedir"}
400     ) {
401     my $state = ConfigTiny->new;
402     foreach my $key ( keys %{$self->{"crl"}[$i]{"state"}} ) {
403     $state->{$self->{"alias"}}->{$key} = $self->{"crl"}[$i]{"state"}{$key};
404     }
405     $state->write(
406     $self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state' );
407     $::log->verb(5,"State saved in",
408     $self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state');
409     }
410    
411     }
412     return 1;
413     }
414    
415     sub retrieveHTTP($$) {
416     my $self = shift;
417     my $idx = shift;
418     my $url = shift;
419     my %metadata;
420     my $data;
421    
422     $url =~ /^(http:|https:|ftp:)/ or die "retrieveHTTP: non-http URL $url\n";
423    
424     $::log->verb(3,"Downloading data from $url");
425     my $ua = LWP::UserAgent->new;
426 davidg 3275
427 davidg 1758 $ua->agent('fetch-crl/'.$::cnf->{_}->{version} . ' ('.
428     $ua->agent . '; '.$::cnf->{_}->{packager} . ')'
429     );
430 davidg 3275 # allow overriding of userAgent string to bypass Fortigates and like filters
431     if ( defined $::cnf->{$self->{"alias"}}->{user_agent} ) {
432     $ua->agent($::cnf->{$self->{"alias"}}->{user_agent});
433     $::log->verb(5,"Setting user agent for " .
434     $self->{"alias"} . " to \"" .
435     $::cnf->{$self->{"alias"}}->{user_agent} . "\"" );
436     } elsif ( defined $::cnf->{_}->{user_agent} ) {
437     $ua->agent($::cnf->{_}->{user_agent});
438     $::log->verb(5,"Setting user agent to global value \"" .
439     $::cnf->{_}->{user_agent} . "\"" );
440     }
441    
442 davidg 1758 $ua->timeout($self->{"httptimeout"});
443     $ua->use_eval(0);
444     if ( $self->{"http_proxy"} ) {
445     if ( $self->{"http_proxy"} =~ /^ENV/i ) {
446     $ua->env_proxy();
447     } else {
448     $ua->proxy("http", $self->{"http_proxy"});
449     }
450     }
451 davidg 2803 # set request cache control if specified as valid in config
452 davidg 2805 if ( defined $::cnf->{_}->{cache_control_request} ) {
453     $::log->verb(5,"Setting request cache-control to ".
454     $::cnf->{_}->{cache_control_request});
455     if ( $::cnf->{_}->{cache_control_request} =~ /^\d+$/ ) {
456 davidg 2803 $ua->default_header('Cache-control' =>
457 davidg 2805 "max-age=".$::cnf->{_}->{cache_control_request} );
458 davidg 2803 } else {
459     die "Request cache control is invalid (not a number)\n";
460     }
461     }
462 davidg 1758
463     # see with a HEAD request if we can get by with old data
464     # but to assess that we need Last-Modified from the previous request
465     # (so if the CA did not send that: too bad)
466     if ( $self->{"crl"}[$idx]{"state"}{"lastmod"} and
467     $self->{"crl"}[$idx]{"state"}{"b64data"}
468     ) {
469     $::log->verb(4,"Lastmod set to",$self->{"crl"}[$idx]{"state"}{"lastmod"});
470     $::log->verb(4,"Attemping HEAD retrieval of $url");
471    
472     my $response;
473     eval {
474     local $SIG{ALRM}=sub{die "timed out after ".$self->{"httptimeout"}."s\n";};
475     alarm $self->{"httptimeout"};
476     $response = $ua->head($url);
477     alarm 0;
478     };
479     alarm 0; # make sure the alarm stops ticking, regardless of the eval
480    
481 davidg 2650 if ( $@ ) { # died, alarm hit: server bad, so try next URL
482 davidg 3178 chomp($@);
483     my $shorterror = $@; $shorterror =~ s/\n.*$//gs;
484     $::log->verb(2,"HEAD error $url:", $shorterror);
485     # underlying socket library may be verybose - filter and qualify messages
486     if ( $shorterror ne $@ ) {
487     foreach my $errorline ( split(/\n/,$@) ) {
488     chomp($errorline); $errorline eq $shorterror and next; # nodups
489     $errorline and $::log->verb(4,"HEAD error detail:", $errorline);
490     }
491     }
492 davidg 1758 return undef;
493     }
494    
495 davidg 2650 # try using cached data if it is fresh
496 davidg 1758 if ( ( ! $@ ) and
497     $response->is_success and
498     $response->header("Last-Modified") ) {
499    
500     my $lastmod = HTTP::Date::str2time($response->header("Last-Modified"));
501     if ( $lastmod == $self->{"crl"}[$idx]{"state"}{"lastmod"}) {
502     $::log->verb(4,"HEAD lastmod unchanged, using cache");
503     $data = base64::b64decode($self->{"crl"}[$idx]{"state"}{"b64data"});
504     %metadata = (
505     "freshuntil" => $response->fresh_until(heuristic_expiry=>0)||time,
506     "lastmod" => $self->{"crl"}[$idx]{"state"}{"lastmod"} || time,
507     "sourceurl" => $self->{"crl"}[$idx]{"state"}{"sourceurl"} || $url
508     );
509     return ($data,%metadata) if wantarray;
510     return $data;
511    
512     } elsif ( $lastmod < $self->{"crl"}[$idx]{"state"}{"lastmod"} ) {
513     # retrieve again, but print warning abount this wierd behaviour
514     $::log->warn("Retrieved HEAD Last-Modified is older than cache: ".
515     "cache invalidated, GET issued");
516     }
517     }
518     }
519    
520 davidg 2650 # try get if head fails, there was no cache, cache disabled or invalidated
521 davidg 1758
522     my $response;
523     eval {
524     local $SIG{ALRM}=sub{die "timed out after ".$self->{"httptimeout"}."s\n";};
525     alarm $self->{"httptimeout"};
526 davidg 2232 $ua->parse_head(0);
527 davidg 1758 $response = $ua->get($url);
528     alarm 0;
529     };
530     alarm 0; # make sure the alarm stops ticking, regardless of the eval
531    
532     if ( $@ ) {
533     chomp($@);
534 davidg 3178 my $shorterror = $@; $shorterror =~ s/\n.*$//gs;
535     $::log->verb(0,"Download error $url:", $shorterror);
536     # underlying socket library may be verybose - filter and qualify messages
537     if ( $shorterror ne $@ ) {
538     foreach my $errorline ( split(/\n/,$@) ) {
539     chomp($errorline); $errorline eq $shorterror and next; # nodups
540     $errorline and $::log->verb(4,"Download error detail:", $errorline);
541     }
542     }
543 davidg 1758 return undef;
544     }
545    
546     if ( ! $response->is_success ) {
547     $::log->verb(0,"Download error $url:",$response->status_line);
548     return undef;
549     }
550    
551     $data = $response->content;
552    
553     $metadata{"freshuntil"}=$response->fresh_until(heuristic_expiry=>0)||time;
554     if ( my $lastmod = $response->header("Last-Modified") ) {
555     $metadata{"lastmod"} = HTTP::Date::str2time($lastmod);
556     }
557     $metadata{"sourceurl"} = $url;
558    
559     return ($data,%metadata) if wantarray;
560     return $data;
561     }
562    
563     sub retrieveFile($$) {
564     my $self = shift;
565     my $idx = shift;
566     my $url = shift;
567     $url =~ /^file:\/*(\/.*)$/ or die "retrieveFile: non-file URL $url\n";
568     $::log->verb(4,"Retrieving data from $url");
569    
570     # for files the previous state does not matter, we retrieve it
571     # anyway
572    
573     my $data;
574     {
575     open CRLFILE,$1 or do {
576     $! = "Cannot open $1: $!";
577     return undef;
578     };
579     binmode CRLFILE;
580     local $/;
581     $data = <CRLFILE>;
582     close CRLFILE;
583     }
584    
585     my %metadata;
586     $metadata{"lastmod"} = (stat($1))[9];
587     $metadata{"freshuntil"} = time;
588     $metadata{"sourceurl"} = $url;
589    
590     return ($data,%metadata) if wantarray;
591     return $data;
592     }
593    
594     sub retrieve($) {
595     my $self = shift;
596    
597     $self->{"crlurls"} or
598     $::log->err("Retrieving uninitialised list of CRL URLs") and return 0;
599    
600     $::log->verb(2,"Retrieving CRLs for",$self->{"alias"});
601    
602     for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices
603     my ($result,%response);
604    
605     $::log->verb(3,"Retrieving CRL for",$self->{"alias"},"index $i");
606    
607     # within the list of CRL URLs for a specific index, all entries
608     # are considered equivalent. I.e., if we get one, the metadata will
609     # be used for all (like Last-Modified, and cache control data)
610    
611     # if we have a cached piece of fresh data, return that one
612 davidg 2783 # and make sure the nextupdate in the CRL itself outlives claimed freshness
613 davidg 1763 if ( !$self->{"nocache"} and
614     ($self->{"crl"}[$i]{"state"}{"freshuntil"} || 0) > time and
615 davidg 2085 ($self->{"crl"}[$i]{"state"}{"nextupdate"} || time) >= time and
616 davidg 2783 ($self->{"crl"}[$i]{"state"}{"nextupdate"} || 0) >=
617     ($self->{"crl"}[$i]{"state"}{"freshuntil"} || 0) and
618 davidg 1758 $self->{"crl"}[$i]{"state"}{"b64data"} ) {
619     $::log->verb(3,"Using cached content for",$self->{"alias"},"index",$i);
620     $::log->verb(4,"Content dated",
621     scalar gmtime($self->{"crl"}[$i]{"state"}{"lastmod"}),
622     "valid until",
623     scalar gmtime($self->{"crl"}[$i]{"state"}{"freshuntil"}),
624     "UTC");
625     $result = base64::b64decode($self->{"crl"}[$i]{"state"}{"b64data"});
626     %response = (
627     "freshuntil" => $self->{"crl"}[$i]{"state"}{"freshuntil"} || time,
628     "lastmod" => $self->{"crl"}[$i]{"state"}{"lastmod"} || time,
629     "sourceurl" => $self->{"crl"}[$i]{"state"}{"sourceurl"} || "null:"
630     );
631     } else {
632 davidg 2305 foreach my $url ( split(/\001/,$self->{"crlurls"}[$i]) ) {
633 davidg 1758 # of these, the first one wins
634     $url =~ /^(http:|https:|ftp:)/ and
635     ($result,%response) = $self->retrieveHTTP($i,$url);
636     $url =~ /^(file:)/ and
637     ($result,%response) = $self->retrieveFile($i,$url);
638     last if $result;
639     }
640     }
641    
642     # check if result is there, otherwise invoke agingtolerance clause
643     # before actually raising this as an error
644     # note that agingtolerance stats counting only AFTER the freshness
645     # of the cache control directives has passed ...
646    
647     if ( ! $result ) {
648    
649     $::log->verb(1,"CRL retrieval for",
650     $self->{"alias"},($i?"[$i] ":"")."failed from all URLs");
651    
652     if ( $self->{"agingtolerance"} && $self->{"crl"}[$i]{"state"}{"mtime"} ) {
653     if ( ( time - $self->{"crl"}[$i]{"state"}{"mtime"} ) <
654     3600*$self->{"agingtolerance"}) {
655     $::log->warn("CRL retrieval for",
656     $self->{"alias"},($i?"[$i] ":"")."failed,",
657     int((3600*$self->{"agingtolerance"}+
658     $self->{"crl"}[$i]{"state"}{"mtime"}-
659     time )/3600).
660     " left of ".$self->{"agingtolerance"}."h, retry later.");
661     } else {
662 davidg 2690 $::log->retr_err("CRL retrieval for",
663 davidg 1758 $self->{"alias"},($i?"[$i] ":"")."failed.",
664     $self->{"agingtolerance"}."h grace expired.",
665     "CRL not updated");
666     }
667     } else { # direct errors, no tolerance anymore
668 davidg 2690 $::log->retr_err("CRL retrieval for",
669 davidg 1758 $self->{"alias"},($i?"[$i] ":"")."failed,",
670     "CRL not updated");
671     }
672     next; # next subindex CRL for same CA, no further action on this one
673     }
674    
675     # now data for $i is loaded in $result;
676     # for freshness checks, take a sum (SysV style)
677     my $sum = unpack("%32C*",$result) % 65535;
678    
679     $::log->verb(4,"Got",length($result),"bytes of data (sum=$sum)");
680    
681     $self->{"crl"}[$i]{"data"} = $result;
682     $self->{"crl"}[$i]{"state"}{"alias"} = $self->{"alias"};
683     $self->{"crl"}[$i]{"state"}{"index"} = $i;
684     $self->{"crl"}[$i]{"state"}{"sum"} = $sum;
685     ($self->{"crl"}[$i]{"state"}{"b64data"} =
686     base64::b64encode($result)) =~ s/\s+//gm;
687    
688     $self->{"crl"}[$i]{"state"}{"retrievaltime"} = time;
689     $self->{"crl"}[$i]{"state"}{"sourceurl"} = $response{"sourceurl"}||"null:";
690 davidg 1763 $self->{"crl"}[$i]{"state"}{"freshuntil"} = $response{"freshuntil"}||time;
691 davidg 1758 $self->{"crl"}[$i]{"state"}{"lastmod"} = $response{"lastmod"}||time;
692    
693     }
694     return 1;
695     }
696    
697     sub verifyAndConvertCRLs($) {
698     my $self = shift;
699     $self->{"crlurls"} or
700     $::log->err("Verifying uninitialised list of CRLs impossible") and return 0;
701    
702     # all CRLs must be valid in order to proceed
703     # or we would end up shifting the relative ordering around and
704     # possibly creatiing holes (or overwriting good local copies of
705     # CRLs that have gone bad on the remote end
706    
707     for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices
708     $self->{"crlurls"}[$i] or
709     $::log->verb(3,"CRL",$self->getAnchorName."/".$i,"ignored (no valid URL)")
710     and next;
711     $self->{"crl"}[$i]{"data"} or
712     $::log->verb(3,"CRL",$self->getAnchorName."/".$i,"ignored (no new data)")
713     and next;
714     $::log->verb(4,"Verifying CRL $i for",$self->getAnchorName);
715    
716     my $crl = CRL->new($self->getAnchorName."/$i",$self->{"crl"}[$i]{"data"});
717     my @verifyMessages= $crl->verify(@{$self->{"cafile"}});
718    
719     # do additional checks on correlation between download and current
720     # lastUpdate of current file? have to guess the current file
721     # unless we are stateful!
722     my $oldlastupdate = $self->{"crl"}[$i]{"state"}{"lastupdate"} || undef;
723     $oldlastupdate or do {
724     $::log->verb(6,"Attempting to extract lastUpdate of previous D/L");
725     CRLSTATEHUNT: foreach my $output ( @{$::cnf->{_}->{"output_"}} ,
726     $self->{"infodir"}
727     ) {
728     foreach my $file (
729     $self->{"nametemplate_der"},
730     $self->{"nametemplate_pem"},
731     $self->{"alias"}.".r\@R\@",
732     $self->{"anchorname"}.".r\@R\@",
733     ) {
734     next unless $file;
735     (my $thisfile = $file ) =~ s/\@R\@/$i/g;
736     $thisfile = join "/", $output, $thisfile;
737     $::log->verb(6,"Trying guess $file for old CRL");
738     next if ! -e $thisfile;
739     my $oldcrldata; {
740     open OCF,$thisfile and do {
741     binmode OCF;
742     local $/;
743     $oldcrldata = <OCF>;
744     close OCF;
745     }
746     }
747     my $oldcrl = CRL->new($thisfile,$oldcrldata);
748     $oldlastupdate = $oldcrl->getLastUpdate;
749     last CRLSTATEHUNT;
750     }
751     }
752     $::log->verb(3,"Inferred lastupdate for",$self->{"alias"},"is",
753     $oldlastupdate) if $oldlastupdate;
754     };
755    
756     if ( ! $crl->getLastUpdate ) {
757     push @verifyMessages,"downloaded CRL lastUpdate could not be derived";
758     } elsif ( $oldlastupdate and ($crl->getLastUpdate < $oldlastupdate) and
759 davidg 1901 ($self->{"crl"}[$i]{"state"}{"mtime"} <= time)
760 davidg 1758 ) {
761     push @verifyMessages,"downloaded CRL lastUpdate predates installed CRL,",
762     "and current version has sane timestamp";
763     } elsif ( defined $oldlastupdate and $oldlastupdate > time ) {
764     $::log->warn($self->{"anchorname"}."/$i:","replaced with downloaded CRL",
765     "since current one has lastUpdate in the future");
766     }
767    
768     $#verifyMessages >= 0 and do {
769 davidg 2690 $::log->retr_err("CRL verification failed for",$self->{"anchorname"}."/$i",
770 davidg 1758 "(".$self->{"alias"}.")");
771     foreach my $m ( @verifyMessages ) {
772     $::log->verb(0,$self->{"anchorname"}."/$i:",$m);
773     }
774     return 0;
775     };
776    
777     $self->{"crl"}[$i]{"pemdata"} = $crl->getPEMdata();
778     foreach my $key ( qw/ lastupdate nextupdate sha1fp issuer / ) {
779     $self->{"crl"}[$i]{"state"}{$key} = $crl->getAttribute($key) || "";
780     }
781 davidg 2783
782    
783     # issue a low-level warning in case the cache control headers from
784     # the CA (or its CDN) are bugus, i.e. the CRL wille expire before the
785     # cache does. Don't log at warning, since the site cannot fix this
786     if ( defined ($self->{"crl"}[$i]{"state"}{"freshuntil"}) and
787     ( $self->{"crl"}[$i]{"state"}{"freshuntil"} >
788     ( $self->{"crl"}[$i]{"state"}{"nextupdate"} +
789     $::cnf->{_}->{expirestolerance} )
790     )
791     ) {
792     $::log->verb(1,"Cache control headers for CA ".$self->{"alias"}." at ".
793     "URL ".$self->{"crl"}[$i]{"state"}{"sourceurl"}." have apparent ".
794     "freshness ".sprintf("%.1f",($self->{"crl"}[$i]{"state"}{"freshuntil"}-
795     $self->{"crl"}[$i]{"state"}{"nextupdate"})/3600).
796     "hrs beyond CRL expiration nextUpdate. Reset freshness from ".
797     gmtime($self->{"crl"}[$i]{"state"}{"freshuntil"})." UTC to ".
798     $::cnf->{_}->{expirestolerance}." second before nextUpdate at ".
799     gmtime($self->{"crl"}[$i]{"state"}{"nextupdate"})." UTC.");
800     $self->{"crl"}[$i]{"state"}{"freshuntil"} =
801     $self->{"crl"}[$i]{"state"}{"nextupdate"} -
802     $::cnf->{_}->{expirestolerance};
803     }
804    
805     # limit maximum freshness period to compensate for CAs that overdo it
806     if ( defined ($self->{"crl"}[$i]{"state"}{"freshuntil"}) and
807     $self->{"crl"}[$i]{"state"}{"freshuntil"} >
808     (time + $::cnf->{_}->{maxcachetime}) ) {
809     $self->{"crl"}[$i]{"state"}{"freshuntil"} =
810     time+$::cnf->{_}->{maxcachetime};
811     $::log->verb(1,"Cache state freshness expiry for CA ".$self->{"alias"}.
812     " reset to at most ".
813     sprintf("%.1f",$::cnf->{_}->{maxcachetime}/3600.).
814     "hrs beyond current time (".
815     gmtime($self->{"crl"}[$i]{"state"}{"freshuntil"})." UTC)");
816     }
817    
818 davidg 1758 }
819     return 1;
820     }
821    
822    
823     1;
824    

Properties

Name Value
svn:keywords Id

grid.support@nikhef.nl
ViewVC Help
Powered by ViewVC 1.1.28