]>
Commit | Line | Data |
---|---|---|
4e0952c9 FG |
1 | package PVE::Certificate; |
2 | ||
3 | use strict; | |
4 | use warnings; | |
5 | ||
6 | use Date::Parse; | |
7 | use Encode qw(decode encode); | |
8 | use MIME::Base64 qw(decode_base64 encode_base64); | |
9 | use Net::SSLeay; | |
10 | ||
11 | use PVE::JSONSchema qw(get_standard_option); | |
12 | ||
13 | Net::SSLeay::load_error_strings(); | |
14 | Net::SSLeay::randomize(); | |
15 | ||
16 | PVE::JSONSchema::register_format('pem-certificate', sub { | |
17 | my ($content, $noerr) = @_; | |
18 | ||
19 | return check_pem($content, noerr => $noerr); | |
20 | }); | |
21 | ||
22 | PVE::JSONSchema::register_format('pem-certificate-chain', sub { | |
23 | my ($content, $noerr) = @_; | |
24 | ||
25 | return check_pem($content, noerr => $noerr, multiple => 1); | |
26 | }); | |
27 | ||
28 | PVE::JSONSchema::register_format('pem-string', sub { | |
29 | my ($content, $noerr) = @_; | |
30 | ||
31 | return check_pem($content, noerr => $noerr, label => qr/.*?/); | |
32 | }); | |
33 | ||
34 | PVE::JSONSchema::register_standard_option('pve-certificate-info', { | |
35 | type => 'object', | |
36 | properties => { | |
37 | filename => { | |
38 | type => 'string', | |
39 | optional => 1, | |
40 | }, | |
41 | fingerprint => get_standard_option('fingerprint-sha256', { | |
42 | optional => 1, | |
43 | }), | |
44 | subject => { | |
45 | type => 'string', | |
46 | description => 'Certificate subject name.', | |
47 | optional => 1, | |
48 | }, | |
49 | issuer => { | |
50 | type => 'string', | |
51 | description => 'Certificate issuer name.', | |
52 | optional => 1, | |
53 | }, | |
54 | notbefore => { | |
55 | type => 'integer', | |
56 | description => 'Certificate\'s notBefore timestamp (UNIX epoch).', | |
57 | optional => 1, | |
58 | }, | |
59 | notafter => { | |
60 | type => 'integer', | |
61 | description => 'Certificate\'s notAfter timestamp (UNIX epoch).', | |
62 | optional => 1, | |
63 | }, | |
64 | san => { | |
65 | type => 'array', | |
66 | description => 'List of Certificate\'s SubjectAlternativeName entries.', | |
67 | optional => 1, | |
68 | items => { | |
69 | type => 'string', | |
70 | }, | |
71 | }, | |
72 | pem => { | |
73 | type => 'string', | |
74 | description => 'Certificate in PEM format', | |
75 | format => 'pem-certificate', | |
76 | optional => 1, | |
77 | }, | |
78 | }, | |
79 | }); | |
80 | ||
81 | # see RFC 7468 | |
82 | my $b64_char_re = qr![0-9A-Za-z\+/]!; | |
83 | my $header_re = sub { | |
84 | my ($label) = @_; | |
85 | return qr!-----BEGIN\ $label-----(?:\s|\n)*!; | |
86 | }; | |
87 | my $footer_re = sub { | |
88 | my ($label) = @_; | |
89 | return qr!-----END\ $label-----(?:\s|\n)*!; | |
90 | }; | |
91 | my $pem_re = sub { | |
92 | my ($label) = @_; | |
93 | ||
94 | my $header = $header_re->($label); | |
95 | my $footer = $footer_re->($label); | |
96 | ||
97 | return qr{ | |
98 | $header | |
99 | (?:(?:$b64_char_re)+\s*\n)* | |
100 | (?:$b64_char_re)*(?:=\s*\n=|={0,2})?\s*\n | |
101 | $footer | |
102 | }x; | |
103 | }; | |
104 | ||
105 | sub strip_leading_text { | |
106 | my ($content) = @_; | |
107 | ||
108 | my $header = $header_re->(qr/.*?/); | |
109 | $content =~ s/^.*?(?=$header)//s; | |
110 | return $content; | |
111 | }; | |
112 | ||
113 | sub split_pem { | |
114 | my ($content, %opts) = @_; | |
115 | my $label = $opts{label} // 'CERTIFICATE'; | |
116 | ||
117 | my $header = $header_re->($label); | |
118 | return split(/(?=$header)/,$content); | |
119 | } | |
120 | ||
121 | sub check_pem { | |
122 | my ($content, %opts) = @_; | |
123 | ||
124 | my $label = $opts{label} // 'CERTIFICATE'; | |
125 | my $multiple = $opts{multiple}; | |
126 | my $noerr = $opts{noerr}; | |
127 | ||
128 | $content = strip_leading_text($content); | |
129 | ||
130 | my $re = $pem_re->($label); | |
131 | ||
132 | $re = qr/($re\n+)*$re/ if $multiple; | |
133 | ||
134 | if ($content =~ /^$re$/) { | |
135 | return $content; | |
136 | } else { | |
137 | return undef if $noerr; | |
138 | die "not a valid PEM-formatted string.\n"; | |
139 | } | |
140 | } | |
141 | ||
142 | sub pem_to_der { | |
143 | my ($content) = @_; | |
144 | ||
145 | my $header = $header_re->(qr/.*?/); | |
146 | my $footer = $footer_re->(qr/.*?/); | |
147 | ||
148 | $content = strip_leading_text($content); | |
149 | ||
150 | # only take first PEM entry | |
151 | $content =~ s/^$header$//mg; | |
152 | $content =~ s/$footer.*//sg; | |
153 | ||
154 | $content = decode_base64($content); | |
155 | ||
156 | return $content; | |
157 | } | |
158 | ||
159 | sub der_to_pem { | |
160 | my ($content, %opts) = @_; | |
161 | ||
162 | my $label = $opts{label} // 'CERTIFICATE'; | |
163 | ||
164 | my $b64 = encode_base64($content, ''); | |
165 | $b64 = join("\n", ($b64 =~ /.{1,64}/sg)); | |
166 | return "-----BEGIN $label-----\n$b64\n-----END $label-----\n"; | |
167 | } | |
168 | ||
169 | my $ssl_die = sub { | |
170 | my ($msg) = @_; | |
171 | Net::SSLeay::die_now($msg); | |
172 | }; | |
173 | ||
174 | my $ssl_warn = sub { | |
175 | my ($msg) = @_; | |
176 | Net::SSLeay::print_errs(); | |
177 | warn $msg if $msg; | |
178 | }; | |
179 | ||
180 | my $read_certificate = sub { | |
181 | my ($cert_path) = @_; | |
182 | ||
183 | die "'$cert_path' does not exist!\n" if ! -e $cert_path; | |
184 | ||
185 | my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r') | |
186 | or $ssl_die->("unable to read '$cert_path' - $!\n"); | |
187 | ||
188 | my $cert = Net::SSLeay::PEM_read_bio_X509($bio); | |
189 | if (!$cert) { | |
190 | Net::SSLeay::BIO_free($bio); | |
191 | die "unable to read certificate from '$cert_path'\n"; | |
192 | } | |
193 | ||
194 | return $cert; | |
195 | }; | |
196 | ||
197 | sub convert_asn1_to_epoch { | |
198 | my ($asn1_time) = @_; | |
199 | ||
200 | $ssl_die->("invalid ASN1 time object\n") if !$asn1_time; | |
201 | my $iso_time = Net::SSLeay::P_ASN1_TIME_get_isotime($asn1_time); | |
202 | $ssl_die->("unable to parse ASN1 time\n") if $iso_time eq ''; | |
203 | return Date::Parse::str2time($iso_time); | |
204 | } | |
205 | ||
206 | sub get_certificate_info { | |
207 | my ($cert_path) = @_; | |
208 | ||
209 | my $cert = $read_certificate->($cert_path); | |
210 | ||
211 | my $parse_san = sub { | |
212 | my $res = []; | |
213 | while (my ($type, $value) = splice(@_, 0, 2)) { | |
214 | if ($type != 2 && $type != 7) { | |
215 | warn "unexpected SAN type encountered: $type\n"; | |
216 | next; | |
217 | } | |
218 | ||
219 | if ($type == 7) { | |
220 | my $hex = unpack("H*", $value); | |
221 | if (length($hex) == 8) { | |
222 | # IPv4 | |
223 | $value = join(".", unpack("C4C4C4C4", $value)); | |
224 | } elsif (length($hex) == 32) { | |
225 | # IPv6 | |
226 | $value = join(":", unpack("H4H4H4H4H4H4H4H4", $value)); | |
227 | } else { | |
228 | warn "cannot parse SAN IP entry '0x${hex}'\n"; | |
229 | next; | |
230 | } | |
231 | } | |
232 | ||
233 | push @$res, $value; | |
234 | } | |
235 | return $res; | |
236 | }; | |
237 | ||
238 | my $info = {}; | |
239 | ||
240 | $info->{fingerprint} = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); | |
241 | ||
242 | my $subject = Net::SSLeay::X509_get_subject_name($cert); | |
243 | if ($subject) { | |
244 | $info->{subject} = Net::SSLeay::X509_NAME_oneline($subject); | |
245 | } | |
246 | ||
247 | my $issuer = Net::SSLeay::X509_get_issuer_name($cert); | |
248 | if ($issuer) { | |
249 | $info->{issuer} = Net::SSLeay::X509_NAME_oneline($issuer); | |
250 | } | |
251 | ||
252 | eval { $info->{notbefore} = convert_asn1_to_epoch(Net::SSLeay::X509_get_notBefore($cert)) }; | |
253 | warn $@ if $@; | |
254 | eval { $info->{notafter} = convert_asn1_to_epoch(Net::SSLeay::X509_get_notAfter($cert)) }; | |
255 | warn $@ if $@; | |
256 | ||
257 | $info->{san} = $parse_san->(Net::SSLeay::X509_get_subjectAltNames($cert)); | |
258 | $info->{pem} = Net::SSLeay::PEM_get_string_X509($cert); | |
259 | ||
260 | Net::SSLeay::X509_free($cert); | |
261 | ||
262 | $cert_path =~ s!^.*/!!g; | |
263 | $info->{filename} = $cert_path; | |
264 | ||
265 | return $info; | |
266 | }; | |
267 | ||
268 | # Checks whether certificate expires before $timestamp (UNIX epoch) | |
269 | sub check_expiry { | |
270 | my ($cert_path, $timestamp) = @_; | |
271 | ||
272 | $timestamp //= time(); | |
273 | ||
274 | my $cert = $read_certificate->($cert_path); | |
275 | my $not_after = eval { convert_asn1_to_epoch(Net::SSLeay::X509_get_notAfter($cert)) }; | |
276 | my $err = $@; | |
277 | ||
278 | Net::SSLeay::X509_free($cert); | |
279 | ||
280 | die $err if $err; | |
281 | ||
282 | return ($not_after < $timestamp) ? 1 : 0; | |
283 | }; | |
284 | ||
285 | # Create a CSR and certificate key for a given order | |
286 | # returns path to CSR file or path to CSR and key files | |
287 | sub generate_csr { | |
288 | my (%attr) = @_; | |
289 | ||
290 | # optional | |
291 | my $bits = delete($attr{bits}) // 4096; | |
292 | my $dig_alg = delete($attr{digest}) // 'sha256'; | |
293 | my $pem_key = delete($attr{private_key}); | |
294 | ||
295 | # required | |
296 | my $identifiers = delete($attr{identifiers}); | |
297 | ||
298 | die "Identifiers are required to generate a CSR.\n" | |
299 | if !defined($identifiers); | |
300 | ||
301 | my $san = [ map { $_->{value} } grep { $_->{type} eq 'dns' } @$identifiers ]; | |
302 | die "DNS identifiers are required to generate a CSR.\n" if !scalar @$san; | |
303 | ||
304 | my $md = eval { Net::SSLeay::EVP_get_digestbyname($dig_alg) }; | |
305 | die "Invalid digest algorithm '$dig_alg'\n" if !$md; | |
306 | ||
307 | my ($bio, $pk, $req); | |
308 | ||
309 | my $cleanup = sub { | |
310 | my ($warn, $die_msg) = @_; | |
311 | $ssl_warn->() if $warn; | |
312 | ||
313 | Net::SSLeay::X509_REQ_free($req) if $req; | |
314 | Net::SSLeay::EVP_PKEY_free($pk) if $pk; | |
315 | Net::SSLeay::BIO_free($bio) if $bio; | |
316 | ||
317 | die $die_msg if $die_msg; | |
318 | }; | |
319 | ||
320 | # this unfortunately causes a small memory leak, since there is no | |
321 | # X509_NAME_free() (yet) | |
322 | my $name = Net::SSLeay::X509_NAME_new(); | |
323 | $ssl_die->("Failed to allocate X509_NAME object\n") if !$name; | |
324 | my $add_name_entry = sub { | |
325 | my ($k, $v) = @_; | |
326 | if (!Net::SSLeay::X509_NAME_add_entry_by_txt($name, | |
327 | $k, | |
328 | &Net::SSLeay::MBSTRING_UTF8, | |
329 | encode('utf-8', $v))) { | |
330 | $cleanup->(1, "Failed to add '$k'='$v' to DN\n"); | |
331 | } | |
332 | }; | |
333 | ||
334 | $add_name_entry->('CN', @$san[0]); | |
335 | for (qw(C ST L O OU)) { | |
336 | if (defined(my $v = $attr{$_})) { | |
337 | $add_name_entry->($_, $v); | |
338 | } | |
339 | } | |
340 | ||
341 | if (defined($pem_key)) { | |
342 | my $bio_s_mem = Net::SSLeay::BIO_s_mem(); | |
343 | $cleanup->(1, "Failed to allocate BIO_s_mem for private key\n") | |
344 | if !$bio_s_mem; | |
345 | ||
346 | $bio = Net::SSLeay::BIO_new($bio_s_mem); | |
347 | $cleanup->(1, "Failed to allocate BIO for private key\n") if !$bio; | |
348 | ||
349 | $cleanup->(1, "Failed to write PEM-encoded key to BIO\n") | |
350 | if Net::SSLeay::BIO_write($bio, $pem_key) <= 0; | |
351 | ||
352 | $pk = Net::SSLeay::PEM_read_bio_PrivateKey($bio); | |
353 | $cleanup->(1, "Failed to read private key into EVP_PKEY\n") if !$pk; | |
354 | } else { | |
355 | $pk = Net::SSLeay::EVP_PKEY_new(); | |
356 | $cleanup->(1, "Failed to allocate EVP_PKEY for private key\n") if !$pk; | |
357 | ||
358 | my $rsa = Net::SSLeay::RSA_generate_key($bits, 65537); | |
359 | $cleanup->(1, "Failed to generate RSA key pair\n") if !$rsa; | |
360 | ||
361 | $cleanup->(1, "Failed to assign RSA key to EVP_PKEY\n") | |
362 | if !Net::SSLeay::EVP_PKEY_assign_RSA($pk, $rsa); | |
363 | } | |
364 | ||
365 | $req = Net::SSLeay::X509_REQ_new(); | |
366 | $cleanup->(1, "Failed to allocate X509_REQ\n") if !$req; | |
367 | ||
368 | $cleanup->(1, "Failed to set subject name\n") | |
369 | if (!Net::SSLeay::X509_REQ_set_subject_name($req, $name)); | |
370 | ||
371 | $cleanup->(1, "Failed to add extensions to CSR\n") | |
372 | if !Net::SSLeay::P_X509_REQ_add_extensions($req, | |
373 | &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', | |
374 | &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', | |
375 | &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', | |
376 | &Net::SSLeay::NID_subject_alt_name => join(',', map { "DNS:$_" } @$san), | |
377 | ); | |
378 | ||
379 | $cleanup->(1, "Failed to set public key\n") | |
380 | if !Net::SSLeay::X509_REQ_set_pubkey($req, $pk); | |
381 | ||
382 | $cleanup->(1, "Failed to set CSR version\n") | |
383 | if !Net::SSLeay::X509_REQ_set_version($req, 2); | |
384 | ||
385 | $cleanup->(1, "Failed to sign CSR\n") | |
386 | if !Net::SSLeay::X509_REQ_sign($req, $pk, $md); | |
387 | ||
388 | my $pk_pem = Net::SSLeay::PEM_get_string_PrivateKey($pk); | |
389 | my $req_pem = Net::SSLeay::PEM_get_string_X509_REQ($req); | |
390 | ||
391 | $cleanup->(); | |
392 | ||
393 | return wantarray ? ($req_pem, $pk_pem) : $req_pem; | |
394 | } | |
395 | ||
396 | 1; |