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