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 |
|
|
my $urllist; |
116 |
|
|
while (<CRLURL>) { |
117 |
|
|
/^\s*([^#\n]+).*$/ and my $url = $1 or next; |
118 |
|
|
$url =~ s/\s*$//; # trailing whitespace is ignored |
119 |
|
|
|
120 |
|
|
$url =~ /^\w+:\/\/.*$/ or |
121 |
|
|
$::log->err("File $path$basename$suffix contains a non-URL entry") |
122 |
|
|
and close CRLURL and return 0; |
123 |
|
|
|
124 |
|
|
$urllist and $urllist .= ""; |
125 |
|
|
$urllist .= $url; |
126 |
|
|
} |
127 |
|
|
close CRLURL; |
128 |
|
|
push @{$self->{"crlurls"}}, $urllist; |
129 |
|
|
$self->{"status"} ||= "unknown"; |
130 |
|
|
|
131 |
|
|
} else { |
132 |
|
|
|
133 |
|
|
my $info = ConfigTiny->new(); |
134 |
|
|
$info->read( $path . $basename . $suffix ) or |
135 |
|
|
$::log->err("Error reading info $path$basename$suffix", $info->errstr) |
136 |
|
|
and return 0; |
137 |
|
|
|
138 |
|
|
$info->{_}->{"crl_url"} and $info->{_}->{"crl_url.0"} and |
139 |
|
|
$::log->err("Invalid info for $basename: crl_url and .0 duplicate") and |
140 |
|
|
return 0; |
141 |
|
|
$info->{_}->{"crl_url"} and |
142 |
|
|
$info->{_}->{"crl_url.0"} = $info->{_}->{"crl_url"}; |
143 |
|
|
|
144 |
|
|
# only do something when there is actually a CRL to process |
145 |
|
|
$info->{_}->{"crl_url.0"} or |
146 |
|
|
$::log->verb(1,"Trust anchor $basename does not have a CRL") and return 0; |
147 |
|
|
|
148 |
|
|
$info->{_}->{"alias"} or |
149 |
|
|
$::log->err("Invalid info for $basename: no alias") and |
150 |
|
|
return 0; |
151 |
|
|
$self->{"alias"} = $info->{_}->{"alias"}; |
152 |
|
|
|
153 |
|
|
@{$self->{"crlurls"}} = (); |
154 |
|
|
for ( my $i=0 ; defined $info->{_}{"crl_url.".$i} ; $i++ ) { |
155 |
|
|
$info->{_}{"crl_url.".$i} =~ s/[;\s]+//g; |
156 |
|
|
$info->{_}{"crl_url.".$i} =~ s/^\s*([^\s]*)\s*$/$1/; |
157 |
|
|
|
158 |
|
|
$info->{_}{"crl_url.".$i} =~ /^\w+:\/\// or |
159 |
|
|
$::log->err("File $path$basename$suffix contains a non-URL entry", |
160 |
|
|
$info->{_}{"crl_url.".$i}) |
161 |
|
|
and close CRLURL and return 0; |
162 |
|
|
|
163 |
|
|
push @{$self->{"crlurls"}} , $info->{_}{"crl_url.".$i}; |
164 |
|
|
} |
165 |
|
|
|
166 |
|
|
foreach my $field ( qw/email ca_url status/ ) { |
167 |
|
|
$self->{$field} = $info->{_}->{$field} if $info->{_}->{$field}; |
168 |
|
|
} |
169 |
|
|
|
170 |
|
|
# status of CA is only knwon for info-file based CAs |
171 |
|
|
$self->{"status"} ||= "local"; |
172 |
|
|
|
173 |
|
|
} |
174 |
|
|
|
175 |
|
|
# preserve basename of file for config and diagnostics |
176 |
|
|
$self->{"anchorname"} = $basename; |
177 |
|
|
|
178 |
|
|
# |
179 |
|
|
# set defaults for common values |
180 |
|
|
foreach my $key ( qw / |
181 |
|
|
prepend_url postpend_url agingtolerance |
182 |
|
|
httptimeout proctimeout |
183 |
|
|
nowarnings noerrors nocache http_proxy |
184 |
|
|
nametemplate_der nametemplate_pem |
185 |
|
|
cadir catemplate statedir |
186 |
|
|
/ ) { |
187 |
davidg |
1767 |
$self->{$key} = $self->{$key} || |
188 |
davidg |
1758 |
$::cnf->{$self->{"alias"}}->{$key} || |
189 |
|
|
$::cnf->{$self->{"anchorname"}}->{$key} || |
190 |
|
|
$::cnf->{_}->{$key} or delete $self->{$key}; |
191 |
|
|
defined $self->{$key} and do { |
192 |
|
|
$self->{$key} =~ s/\@ANCHORNAME\@/$self->{"anchorname"}/g; |
193 |
|
|
$self->{$key} =~ s/\@STATUS\@/$self->{"status"}/g; |
194 |
|
|
$self->{$key} =~ s/\@ALIAS\@/$self->{"alias"}/g; |
195 |
|
|
}; |
196 |
|
|
} |
197 |
|
|
# reversible toggle options |
198 |
|
|
foreach my $key ( qw / warnings errors cache / ) { |
199 |
|
|
delete $self->{"no$key"} if $::cnf->{$self->{"alias"}}->{$key} or |
200 |
|
|
$::cnf->{$self->{"anchorname"}}->{$key} or |
201 |
|
|
$::cnf->{_}->{$key}; |
202 |
|
|
} |
203 |
|
|
foreach my $key ( qw / nohttp_proxy noprepend_url nopostpend_url |
204 |
|
|
nostatedir / ) { |
205 |
|
|
(my $nokey = $key) =~ s/^no//; |
206 |
|
|
delete $self->{"$nokey"} if $::cnf->{$self->{"alias"}}->{$key} or |
207 |
|
|
$::cnf->{$self->{"anchorname"}}->{$key} or |
208 |
|
|
$::cnf->{_}->{$key}; |
209 |
|
|
} |
210 |
|
|
|
211 |
|
|
# overriding of the URLs (alias takes precedence over anchorname |
212 |
|
|
foreach my $section ( qw / anchorname alias / ) { |
213 |
|
|
my $i = 0; |
214 |
|
|
while ( defined ($::cnf->{$self->{$section}}->{"crl_url.".$i}) ) { |
215 |
|
|
my $urls; |
216 |
|
|
($urls=$::cnf->{$self->{$section}}->{"crl_url.".$i} )=~s/[;\s]+//g; |
217 |
|
|
${$self->{"crlurls"}}[$i] = $urls; |
218 |
|
|
$i++; |
219 |
|
|
} |
220 |
|
|
} |
221 |
|
|
|
222 |
|
|
# templates to construct a CA name may still have other separators |
223 |
|
|
$self->{"catemplate"} =~ s/[;\s]+//g; |
224 |
|
|
|
225 |
|
|
# select only http/https/ftp/file URLs |
226 |
|
|
# also transform the URLs using the base patterns and prepend any |
227 |
|
|
# local URL patterns (@ANCHORNAME@, @ALIAS@, and @R@) |
228 |
|
|
for ( my $i=0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { |
229 |
|
|
my $urlstring = @{$self->{"crlurls"}}[$i]; |
230 |
|
|
my @urls = split(//,$urlstring); |
231 |
|
|
$urlstring=""; |
232 |
|
|
foreach my $url ( @urls ) { |
233 |
|
|
if ( $url =~ /^(http:|https:|ftp:|file:)/ ) { |
234 |
|
|
$urlstring.="" if $urlstring; $urlstring.=$url; |
235 |
|
|
} else { |
236 |
|
|
$::log->verb(0,"URL $url in $basename$suffix unsupported, ignored"); |
237 |
|
|
} |
238 |
|
|
} |
239 |
|
|
if ( my $purl = $self->{"prepend_url"} ) { |
240 |
|
|
$purl =~ s/\@R\@/$i/g; |
241 |
|
|
$urlstring = join "" , $purl , $urlstring; |
242 |
|
|
} |
243 |
|
|
if ( my $purl = $self->{"postpend_url"} ) { |
244 |
|
|
$purl =~ s/\@R\@/$i/g; |
245 |
|
|
$urlstring = join "" , $urlstring, $purl; |
246 |
|
|
} |
247 |
|
|
if ( ! $urlstring ) { |
248 |
|
|
$::log->err("No usable CRL URLs for",$self->getAnchorName); |
249 |
|
|
$self->{"crlurls"}[$i] = ""; |
250 |
|
|
} else { |
251 |
|
|
$self->{"crlurls"}[$i] = $urlstring; |
252 |
|
|
} |
253 |
|
|
} |
254 |
|
|
|
255 |
|
|
return 1; |
256 |
|
|
} |
257 |
|
|
|
258 |
|
|
sub getAnchorName($) { |
259 |
|
|
my $self = shift; |
260 |
|
|
return ($self->{"anchorname"} || undef); |
261 |
|
|
} |
262 |
|
|
|
263 |
|
|
sub printAnchorName($) { |
264 |
|
|
my $self = shift; |
265 |
|
|
print "" . ($self->{"anchorname"} || "undefined") ."\n"; |
266 |
|
|
} |
267 |
|
|
|
268 |
|
|
sub loadCAfiles($) { |
269 |
|
|
my $self = shift; |
270 |
|
|
my $idx = 0; |
271 |
|
|
|
272 |
davidg |
1767 |
# try to find a CA dir, whatever it takes, almost |
273 |
|
|
my $cadir = $self->{"cadir"} || $self->{"infodir"}; |
274 |
|
|
|
275 |
|
|
-d $cadir or |
276 |
|
|
$::log->err("CA directory",$cadir,"does not exist") and |
277 |
davidg |
1758 |
return 0; |
278 |
|
|
|
279 |
|
|
@{$self->{"cafile"}} = (); |
280 |
|
|
do { |
281 |
|
|
my $cafile; |
282 |
|
|
foreach my $catpl ( split //, $self->{"catemplate"} ) { |
283 |
|
|
$catpl =~ s/\@R\@/$idx/g; |
284 |
davidg |
1767 |
-e $cadir.'/'.$catpl and |
285 |
|
|
$cafile = $cadir.'/'.$catpl and last; |
286 |
davidg |
1758 |
} |
287 |
|
|
defined $cafile or do { |
288 |
|
|
$idx or do $::log->err("Cannot find any CA for", |
289 |
davidg |
1767 |
$self->{"alias"},"in",$cadir); |
290 |
davidg |
1758 |
return $idx?1:0; |
291 |
|
|
}; |
292 |
davidg |
1878 |
# is the new one any different from the previous (i.e. is the CA indexed?) |
293 |
|
|
$#{$self->{"cafile"}} >= 0 and |
294 |
|
|
$cafile eq $self->{"cafile"}[$#{$self->{"cafile"}}] and return 1; |
295 |
davidg |
1758 |
push @{$self->{"cafile"}}, $cafile; |
296 |
|
|
$::log->verb(3,"Added CA file $idx: $cafile"); |
297 |
|
|
} while(++$idx); |
298 |
|
|
return 0; # you never should come here |
299 |
|
|
} |
300 |
|
|
|
301 |
|
|
|
302 |
|
|
sub loadState($$) { |
303 |
|
|
my $self = shift; |
304 |
|
|
my $fallbackmode = shift; |
305 |
|
|
|
306 |
|
|
$self->{"crlurls"} or |
307 |
|
|
$::log->err("loading state for uninitialised list of CRLs") and return 0; |
308 |
|
|
$self->{"alias"} or |
309 |
|
|
$::log->err("loading state for uninitialised trust anchor") and return 0; |
310 |
|
|
|
311 |
|
|
for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices |
312 |
|
|
if ( $self->{"statedir"} and |
313 |
|
|
-e $self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state' |
314 |
|
|
) { |
315 |
|
|
my $state = ConfigTiny->new(); |
316 |
|
|
$state->read($self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state') |
317 |
|
|
or $::log->err("Cannot read existing state file", |
318 |
|
|
$self->{"statedir"}.'/'.$self->{"alias"}.'.$i.state', |
319 |
|
|
" - ",$state->errstr) and return 0; |
320 |
|
|
foreach my $key ( keys %{$state->{$self->{"alias"}}} ) { |
321 |
|
|
$self->{"crl"}[$i]{"state"}{$key} = $state->{$self->{"alias"}}->{$key}; |
322 |
|
|
} |
323 |
|
|
} |
324 |
|
|
|
325 |
|
|
# fine, but we should find at least an mtime if at all possible |
326 |
|
|
# make sure it is there: |
327 |
|
|
# try to retrieve state from installed files in @output_ |
328 |
|
|
# where the first look-alike CRL will win. NSS databases |
329 |
|
|
# are NOT supported for this heuristic |
330 |
|
|
if ( ! defined $self->{"crl"}[$i]{"state"}{"mtime"} ) { |
331 |
|
|
my $mtime; |
332 |
davidg |
1901 |
STATEHUNT: foreach my $output ( ( $::cnf->{_}->{"output"}, |
333 |
|
|
$::cnf->{_}->{"output_der"}, $::cnf->{_}->{"output_pem"}, |
334 |
|
|
$::cnf->{_}->{"output_nss"}, $::cnf->{_}->{"output_openssl"}) ) { |
335 |
|
|
defined $output and $output or next; |
336 |
davidg |
1758 |
foreach my $file ( |
337 |
|
|
$self->{"nametemplate_der"}, |
338 |
|
|
$self->{"nametemplate_pem"}, |
339 |
|
|
$self->{"alias"}.".r\@R\@", |
340 |
|
|
$self->{"anchorname"}.".r\@R\@", |
341 |
|
|
) { |
342 |
|
|
next unless $file; |
343 |
|
|
$file =~ s/\@R\@/$i/g; |
344 |
|
|
$file = join "/", $output, $file; |
345 |
|
|
next if ! -e $file; |
346 |
|
|
$mtime = (stat(_))[9]; |
347 |
|
|
last STATEHUNT; |
348 |
|
|
} |
349 |
|
|
} |
350 |
|
|
$::log->verb(3,"Inferred mtime for",$self->{"alias"},"is",$mtime) if $mtime; |
351 |
|
|
$self->{"crl"}[$i]{"state"}{"mtime"} = $mtime if $mtime; |
352 |
|
|
} |
353 |
davidg |
1901 |
|
354 |
|
|
# as a last resort, set mtime to curren time |
355 |
|
|
$self->{"crl"}[$i]{"state"}{"mtime"} ||= time; |
356 |
|
|
|
357 |
davidg |
1758 |
} |
358 |
|
|
return 1; |
359 |
|
|
} |
360 |
|
|
|
361 |
|
|
sub saveState($$) { |
362 |
|
|
my $self = shift; |
363 |
|
|
my $fallbackmode = shift; |
364 |
|
|
|
365 |
|
|
$self->{"statedir"} and -d $self->{"statedir"} and -w $self->{"statedir"} or |
366 |
|
|
return 0; |
367 |
|
|
|
368 |
|
|
$self->{"crlurls"} or |
369 |
|
|
$::log->err("loading state for uninitialised list of CRLs") and return 0; |
370 |
|
|
$self->{"alias"} or |
371 |
|
|
$::log->err("loading state for uninitialised trust anchor") and return 0; |
372 |
|
|
|
373 |
|
|
# of state, mtime is set based on CRL write in $output and filled there |
374 |
|
|
for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices |
375 |
|
|
if ( defined $self->{"statedir"} and |
376 |
|
|
-d $self->{"statedir"} |
377 |
|
|
) { |
378 |
|
|
my $state = ConfigTiny->new; |
379 |
|
|
foreach my $key ( keys %{$self->{"crl"}[$i]{"state"}} ) { |
380 |
|
|
$state->{$self->{"alias"}}->{$key} = $self->{"crl"}[$i]{"state"}{$key}; |
381 |
|
|
} |
382 |
|
|
$state->write( |
383 |
|
|
$self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state' ); |
384 |
|
|
$::log->verb(5,"State saved in", |
385 |
|
|
$self->{"statedir"}.'/'.$self->{"alias"}.'.'.$i.'.state'); |
386 |
|
|
} |
387 |
|
|
|
388 |
|
|
} |
389 |
|
|
return 1; |
390 |
|
|
} |
391 |
|
|
|
392 |
|
|
sub retrieveHTTP($$) { |
393 |
|
|
my $self = shift; |
394 |
|
|
my $idx = shift; |
395 |
|
|
my $url = shift; |
396 |
|
|
my %metadata; |
397 |
|
|
my $data; |
398 |
|
|
|
399 |
|
|
$url =~ /^(http:|https:|ftp:)/ or die "retrieveHTTP: non-http URL $url\n"; |
400 |
|
|
|
401 |
|
|
$::log->verb(3,"Downloading data from $url"); |
402 |
|
|
my $ua = LWP::UserAgent->new; |
403 |
|
|
$ua->agent('fetch-crl/'.$::cnf->{_}->{version} . ' ('. |
404 |
|
|
$ua->agent . '; '.$::cnf->{_}->{packager} . ')' |
405 |
|
|
); |
406 |
|
|
$ua->timeout($self->{"httptimeout"}); |
407 |
|
|
$ua->use_eval(0); |
408 |
|
|
if ( $self->{"http_proxy"} ) { |
409 |
|
|
if ( $self->{"http_proxy"} =~ /^ENV/i ) { |
410 |
|
|
$ua->env_proxy(); |
411 |
|
|
} else { |
412 |
|
|
$ua->proxy("http", $self->{"http_proxy"}); |
413 |
|
|
} |
414 |
|
|
} |
415 |
|
|
|
416 |
|
|
|
417 |
|
|
# see with a HEAD request if we can get by with old data |
418 |
|
|
# but to assess that we need Last-Modified from the previous request |
419 |
|
|
# (so if the CA did not send that: too bad) |
420 |
|
|
if ( $self->{"crl"}[$idx]{"state"}{"lastmod"} and |
421 |
|
|
$self->{"crl"}[$idx]{"state"}{"b64data"} |
422 |
|
|
) { |
423 |
|
|
$::log->verb(4,"Lastmod set to",$self->{"crl"}[$idx]{"state"}{"lastmod"}); |
424 |
|
|
$::log->verb(4,"Attemping HEAD retrieval of $url"); |
425 |
|
|
|
426 |
|
|
my $response; |
427 |
|
|
eval { |
428 |
|
|
local $SIG{ALRM}=sub{die "timed out after ".$self->{"httptimeout"}."s\n";}; |
429 |
|
|
alarm $self->{"httptimeout"}; |
430 |
|
|
$response = $ua->head($url); |
431 |
|
|
alarm 0; |
432 |
|
|
}; |
433 |
|
|
alarm 0; # make sure the alarm stops ticking, regardless of the eval |
434 |
|
|
|
435 |
|
|
if ( $@ ) { |
436 |
|
|
$::log->verb(2,"HEAD error $url:", $@); |
437 |
|
|
return undef; |
438 |
|
|
} |
439 |
|
|
|
440 |
|
|
# try get if head fails anyway |
441 |
|
|
if ( ( ! $@ ) and |
442 |
|
|
$response->is_success and |
443 |
|
|
$response->header("Last-Modified") ) { |
444 |
|
|
|
445 |
|
|
my $lastmod = HTTP::Date::str2time($response->header("Last-Modified")); |
446 |
|
|
if ( $lastmod == $self->{"crl"}[$idx]{"state"}{"lastmod"}) { |
447 |
|
|
$::log->verb(4,"HEAD lastmod unchanged, using cache"); |
448 |
|
|
$data = base64::b64decode($self->{"crl"}[$idx]{"state"}{"b64data"}); |
449 |
|
|
%metadata = ( |
450 |
|
|
"freshuntil" => $response->fresh_until(heuristic_expiry=>0)||time, |
451 |
|
|
"lastmod" => $self->{"crl"}[$idx]{"state"}{"lastmod"} || time, |
452 |
|
|
"sourceurl" => $self->{"crl"}[$idx]{"state"}{"sourceurl"} || $url |
453 |
|
|
); |
454 |
|
|
return ($data,%metadata) if wantarray; |
455 |
|
|
return $data; |
456 |
|
|
|
457 |
|
|
} elsif ( $lastmod < $self->{"crl"}[$idx]{"state"}{"lastmod"} ) { |
458 |
|
|
# retrieve again, but print warning abount this wierd behaviour |
459 |
|
|
$::log->warn("Retrieved HEAD Last-Modified is older than cache: ". |
460 |
|
|
"cache invalidated, GET issued"); |
461 |
|
|
} |
462 |
|
|
} |
463 |
|
|
} |
464 |
|
|
|
465 |
|
|
# try get if head fails anyway |
466 |
|
|
|
467 |
|
|
my $response; |
468 |
|
|
eval { |
469 |
|
|
local $SIG{ALRM}=sub{die "timed out after ".$self->{"httptimeout"}."s\n";}; |
470 |
|
|
alarm $self->{"httptimeout"}; |
471 |
davidg |
2232 |
$ua->parse_head(0); |
472 |
davidg |
1758 |
$response = $ua->get($url); |
473 |
|
|
alarm 0; |
474 |
|
|
}; |
475 |
|
|
alarm 0; # make sure the alarm stops ticking, regardless of the eval |
476 |
|
|
|
477 |
|
|
if ( $@ ) { |
478 |
|
|
chomp($@); |
479 |
|
|
$::log->verb(0,"Download error $url:", $@); |
480 |
|
|
return undef; |
481 |
|
|
} |
482 |
|
|
|
483 |
|
|
if ( ! $response->is_success ) { |
484 |
|
|
$::log->verb(0,"Download error $url:",$response->status_line); |
485 |
|
|
return undef; |
486 |
|
|
} |
487 |
|
|
|
488 |
|
|
$data = $response->content; |
489 |
|
|
|
490 |
|
|
$metadata{"freshuntil"}=$response->fresh_until(heuristic_expiry=>0)||time; |
491 |
|
|
if ( my $lastmod = $response->header("Last-Modified") ) { |
492 |
|
|
$metadata{"lastmod"} = HTTP::Date::str2time($lastmod); |
493 |
|
|
} |
494 |
|
|
$metadata{"sourceurl"} = $url; |
495 |
|
|
|
496 |
|
|
return ($data,%metadata) if wantarray; |
497 |
|
|
return $data; |
498 |
|
|
} |
499 |
|
|
|
500 |
|
|
sub retrieveFile($$) { |
501 |
|
|
my $self = shift; |
502 |
|
|
my $idx = shift; |
503 |
|
|
my $url = shift; |
504 |
|
|
$url =~ /^file:\/*(\/.*)$/ or die "retrieveFile: non-file URL $url\n"; |
505 |
|
|
$::log->verb(4,"Retrieving data from $url"); |
506 |
|
|
|
507 |
|
|
# for files the previous state does not matter, we retrieve it |
508 |
|
|
# anyway |
509 |
|
|
|
510 |
|
|
my $data; |
511 |
|
|
{ |
512 |
|
|
open CRLFILE,$1 or do { |
513 |
|
|
$! = "Cannot open $1: $!"; |
514 |
|
|
return undef; |
515 |
|
|
}; |
516 |
|
|
binmode CRLFILE; |
517 |
|
|
local $/; |
518 |
|
|
$data = <CRLFILE>; |
519 |
|
|
close CRLFILE; |
520 |
|
|
} |
521 |
|
|
|
522 |
|
|
my %metadata; |
523 |
|
|
$metadata{"lastmod"} = (stat($1))[9]; |
524 |
|
|
$metadata{"freshuntil"} = time; |
525 |
|
|
$metadata{"sourceurl"} = $url; |
526 |
|
|
|
527 |
|
|
return ($data,%metadata) if wantarray; |
528 |
|
|
return $data; |
529 |
|
|
} |
530 |
|
|
|
531 |
|
|
sub retrieve($) { |
532 |
|
|
my $self = shift; |
533 |
|
|
|
534 |
|
|
$self->{"crlurls"} or |
535 |
|
|
$::log->err("Retrieving uninitialised list of CRL URLs") and return 0; |
536 |
|
|
|
537 |
|
|
$::log->verb(2,"Retrieving CRLs for",$self->{"alias"}); |
538 |
|
|
|
539 |
|
|
for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices |
540 |
|
|
my ($result,%response); |
541 |
|
|
|
542 |
|
|
$::log->verb(3,"Retrieving CRL for",$self->{"alias"},"index $i"); |
543 |
|
|
|
544 |
|
|
# within the list of CRL URLs for a specific index, all entries |
545 |
|
|
# are considered equivalent. I.e., if we get one, the metadata will |
546 |
|
|
# be used for all (like Last-Modified, and cache control data) |
547 |
|
|
|
548 |
|
|
# if we have a cached piece of fresh data, return that one |
549 |
davidg |
1763 |
if ( !$self->{"nocache"} and |
550 |
|
|
($self->{"crl"}[$i]{"state"}{"freshuntil"} || 0) > time and |
551 |
davidg |
2085 |
($self->{"crl"}[$i]{"state"}{"nextupdate"} || time) >= time and |
552 |
davidg |
1758 |
$self->{"crl"}[$i]{"state"}{"b64data"} ) { |
553 |
|
|
$::log->verb(3,"Using cached content for",$self->{"alias"},"index",$i); |
554 |
|
|
$::log->verb(4,"Content dated", |
555 |
|
|
scalar gmtime($self->{"crl"}[$i]{"state"}{"lastmod"}), |
556 |
|
|
"valid until", |
557 |
|
|
scalar gmtime($self->{"crl"}[$i]{"state"}{"freshuntil"}), |
558 |
|
|
"UTC"); |
559 |
|
|
$result = base64::b64decode($self->{"crl"}[$i]{"state"}{"b64data"}); |
560 |
|
|
%response = ( |
561 |
|
|
"freshuntil" => $self->{"crl"}[$i]{"state"}{"freshuntil"} || time, |
562 |
|
|
"lastmod" => $self->{"crl"}[$i]{"state"}{"lastmod"} || time, |
563 |
|
|
"sourceurl" => $self->{"crl"}[$i]{"state"}{"sourceurl"} || "null:" |
564 |
|
|
); |
565 |
|
|
} else { |
566 |
|
|
foreach my $url ( split(//,$self->{"crlurls"}[$i]) ) { |
567 |
|
|
# of these, the first one wins |
568 |
|
|
$url =~ /^(http:|https:|ftp:)/ and |
569 |
|
|
($result,%response) = $self->retrieveHTTP($i,$url); |
570 |
|
|
$url =~ /^(file:)/ and |
571 |
|
|
($result,%response) = $self->retrieveFile($i,$url); |
572 |
|
|
last if $result; |
573 |
|
|
} |
574 |
|
|
} |
575 |
|
|
|
576 |
|
|
# check if result is there, otherwise invoke agingtolerance clause |
577 |
|
|
# before actually raising this as an error |
578 |
|
|
# note that agingtolerance stats counting only AFTER the freshness |
579 |
|
|
# of the cache control directives has passed ... |
580 |
|
|
|
581 |
|
|
if ( ! $result ) { |
582 |
|
|
|
583 |
|
|
$::log->verb(1,"CRL retrieval for", |
584 |
|
|
$self->{"alias"},($i?"[$i] ":"")."failed from all URLs"); |
585 |
|
|
|
586 |
|
|
if ( $self->{"agingtolerance"} && $self->{"crl"}[$i]{"state"}{"mtime"} ) { |
587 |
|
|
if ( ( time - $self->{"crl"}[$i]{"state"}{"mtime"} ) < |
588 |
|
|
3600*$self->{"agingtolerance"}) { |
589 |
|
|
$::log->warn("CRL retrieval for", |
590 |
|
|
$self->{"alias"},($i?"[$i] ":"")."failed,", |
591 |
|
|
int((3600*$self->{"agingtolerance"}+ |
592 |
|
|
$self->{"crl"}[$i]{"state"}{"mtime"}- |
593 |
|
|
time )/3600). |
594 |
|
|
" left of ".$self->{"agingtolerance"}."h, retry later."); |
595 |
|
|
} else { |
596 |
|
|
$::log->err("CRL retrieval for", |
597 |
|
|
$self->{"alias"},($i?"[$i] ":"")."failed.", |
598 |
|
|
$self->{"agingtolerance"}."h grace expired.", |
599 |
|
|
"CRL not updated"); |
600 |
|
|
} |
601 |
|
|
} else { # direct errors, no tolerance anymore |
602 |
|
|
$::log->err("CRL retrieval for", |
603 |
|
|
$self->{"alias"},($i?"[$i] ":"")."failed,", |
604 |
|
|
"CRL not updated"); |
605 |
|
|
} |
606 |
|
|
next; # next subindex CRL for same CA, no further action on this one |
607 |
|
|
} |
608 |
|
|
|
609 |
|
|
# now data for $i is loaded in $result; |
610 |
|
|
# for freshness checks, take a sum (SysV style) |
611 |
|
|
my $sum = unpack("%32C*",$result) % 65535; |
612 |
|
|
|
613 |
|
|
$::log->verb(4,"Got",length($result),"bytes of data (sum=$sum)"); |
614 |
|
|
|
615 |
|
|
$self->{"crl"}[$i]{"data"} = $result; |
616 |
|
|
$self->{"crl"}[$i]{"state"}{"alias"} = $self->{"alias"}; |
617 |
|
|
$self->{"crl"}[$i]{"state"}{"index"} = $i; |
618 |
|
|
$self->{"crl"}[$i]{"state"}{"sum"} = $sum; |
619 |
|
|
($self->{"crl"}[$i]{"state"}{"b64data"} = |
620 |
|
|
base64::b64encode($result)) =~ s/\s+//gm; |
621 |
|
|
|
622 |
|
|
$self->{"crl"}[$i]{"state"}{"retrievaltime"} = time; |
623 |
|
|
$self->{"crl"}[$i]{"state"}{"sourceurl"} = $response{"sourceurl"}||"null:"; |
624 |
davidg |
1763 |
$self->{"crl"}[$i]{"state"}{"freshuntil"} = $response{"freshuntil"}||time; |
625 |
davidg |
1758 |
$self->{"crl"}[$i]{"state"}{"lastmod"} = $response{"lastmod"}||time; |
626 |
|
|
|
627 |
|
|
} |
628 |
|
|
return 1; |
629 |
|
|
} |
630 |
|
|
|
631 |
|
|
sub verifyAndConvertCRLs($) { |
632 |
|
|
my $self = shift; |
633 |
|
|
$self->{"crlurls"} or |
634 |
|
|
$::log->err("Verifying uninitialised list of CRLs impossible") and return 0; |
635 |
|
|
|
636 |
|
|
# all CRLs must be valid in order to proceed |
637 |
|
|
# or we would end up shifting the relative ordering around and |
638 |
|
|
# possibly creatiing holes (or overwriting good local copies of |
639 |
|
|
# CRLs that have gone bad on the remote end |
640 |
|
|
|
641 |
|
|
for ( my $i = 0; $i <= $#{$self->{"crlurls"}} ; $i++ ) { # all indices |
642 |
|
|
$self->{"crlurls"}[$i] or |
643 |
|
|
$::log->verb(3,"CRL",$self->getAnchorName."/".$i,"ignored (no valid URL)") |
644 |
|
|
and next; |
645 |
|
|
$self->{"crl"}[$i]{"data"} or |
646 |
|
|
$::log->verb(3,"CRL",$self->getAnchorName."/".$i,"ignored (no new data)") |
647 |
|
|
and next; |
648 |
|
|
$::log->verb(4,"Verifying CRL $i for",$self->getAnchorName); |
649 |
|
|
|
650 |
|
|
my $crl = CRL->new($self->getAnchorName."/$i",$self->{"crl"}[$i]{"data"}); |
651 |
|
|
my @verifyMessages= $crl->verify(@{$self->{"cafile"}}); |
652 |
|
|
|
653 |
|
|
# do additional checks on correlation between download and current |
654 |
|
|
# lastUpdate of current file? have to guess the current file |
655 |
|
|
# unless we are stateful! |
656 |
|
|
my $oldlastupdate = $self->{"crl"}[$i]{"state"}{"lastupdate"} || undef; |
657 |
|
|
$oldlastupdate or do { |
658 |
|
|
$::log->verb(6,"Attempting to extract lastUpdate of previous D/L"); |
659 |
|
|
CRLSTATEHUNT: foreach my $output ( @{$::cnf->{_}->{"output_"}} , |
660 |
|
|
$self->{"infodir"} |
661 |
|
|
) { |
662 |
|
|
foreach my $file ( |
663 |
|
|
$self->{"nametemplate_der"}, |
664 |
|
|
$self->{"nametemplate_pem"}, |
665 |
|
|
$self->{"alias"}.".r\@R\@", |
666 |
|
|
$self->{"anchorname"}.".r\@R\@", |
667 |
|
|
) { |
668 |
|
|
next unless $file; |
669 |
|
|
(my $thisfile = $file ) =~ s/\@R\@/$i/g; |
670 |
|
|
$thisfile = join "/", $output, $thisfile; |
671 |
|
|
$::log->verb(6,"Trying guess $file for old CRL"); |
672 |
|
|
next if ! -e $thisfile; |
673 |
|
|
my $oldcrldata; { |
674 |
|
|
open OCF,$thisfile and do { |
675 |
|
|
binmode OCF; |
676 |
|
|
local $/; |
677 |
|
|
$oldcrldata = <OCF>; |
678 |
|
|
close OCF; |
679 |
|
|
} |
680 |
|
|
} |
681 |
|
|
my $oldcrl = CRL->new($thisfile,$oldcrldata); |
682 |
|
|
$oldlastupdate = $oldcrl->getLastUpdate; |
683 |
|
|
last CRLSTATEHUNT; |
684 |
|
|
} |
685 |
|
|
} |
686 |
|
|
$::log->verb(3,"Inferred lastupdate for",$self->{"alias"},"is", |
687 |
|
|
$oldlastupdate) if $oldlastupdate; |
688 |
|
|
}; |
689 |
|
|
|
690 |
|
|
if ( ! $crl->getLastUpdate ) { |
691 |
|
|
push @verifyMessages,"downloaded CRL lastUpdate could not be derived"; |
692 |
|
|
} elsif ( $oldlastupdate and ($crl->getLastUpdate < $oldlastupdate) and |
693 |
davidg |
1901 |
($self->{"crl"}[$i]{"state"}{"mtime"} <= time) |
694 |
davidg |
1758 |
) { |
695 |
|
|
push @verifyMessages,"downloaded CRL lastUpdate predates installed CRL,", |
696 |
|
|
"and current version has sane timestamp"; |
697 |
|
|
} elsif ( defined $oldlastupdate and $oldlastupdate > time ) { |
698 |
|
|
$::log->warn($self->{"anchorname"}."/$i:","replaced with downloaded CRL", |
699 |
|
|
"since current one has lastUpdate in the future"); |
700 |
|
|
} |
701 |
|
|
|
702 |
|
|
$#verifyMessages >= 0 and do { |
703 |
|
|
$::log->err("CRL verification failed for",$self->{"anchorname"}."/$i", |
704 |
|
|
"(".$self->{"alias"}.")"); |
705 |
|
|
foreach my $m ( @verifyMessages ) { |
706 |
|
|
$::log->verb(0,$self->{"anchorname"}."/$i:",$m); |
707 |
|
|
} |
708 |
|
|
return 0; |
709 |
|
|
}; |
710 |
|
|
|
711 |
|
|
$self->{"crl"}[$i]{"pemdata"} = $crl->getPEMdata(); |
712 |
|
|
foreach my $key ( qw/ lastupdate nextupdate sha1fp issuer / ) { |
713 |
|
|
$self->{"crl"}[$i]{"state"}{$key} = $crl->getAttribute($key) || ""; |
714 |
|
|
} |
715 |
|
|
} |
716 |
|
|
return 1; |
717 |
|
|
} |
718 |
|
|
|
719 |
|
|
|
720 |
|
|
1; |
721 |
|
|
|