]> Raphaël G. Git Repositories - acme/blob - Acme.pm
Rapsys Git / acme / blob
? search:


a27e3852f94a8db79434475d3d2e88a2e31157bc
[acme] / Acme.pm
1 # This file is part of Acmepl
2 #
3 # Acmepl is is free software: you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation, either version 3 of the License, or
6 # (at your option) any later version.
7 #
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
12 #
13 # You should have received a copy of the GNU General Public License
14 # along with this program. If not, see <http://www.gnu.org/licenses/>.
15 #
16 # Copyright (C) 2016 - 2017 Raphaël Gertz <acme@rapsys.eu>
17
18 # Acme package
19 package Acme;
20
21 # Best practice
22 use strict;
23 use warnings;
24
25 # Add acl support to file tests
26 use filetest qw(access);
27
28 # Symbol export
29 use Exporter;
30 our @ISA = qw(Exporter);
31 our @EXPORT_OK = qw(ACCOUNT CONFIG MAIL PENDING TERM THUMBPRINT VERSION);
32
33 # Load dependancies
34 use Carp qw(carp confess);
35 use Date::Parse qw(str2time);
36 use DateTime;
37 use Digest::SHA qw(sha256_base64);
38 use Email::Valid;
39 use File::Copy qw(copy);
40 use File::Path qw(make_path);
41 use File::Slurp qw(read_file write_file);
42 use File::Spec qw(splitpath);
43 use File::stat qw(stat);
44 use File::Temp; # qw( :seekable );
45 use IPC::System::Simple qw(capturex);
46 use JSON qw(from_json to_json);
47 use LWP;
48 use MIME::Base64 qw(encode_base64url encode_base64);
49 use Net::DNS qw();
50 use Net::Domain::TLD qw(tld_exists);
51 use POSIX qw(EXIT_FAILURE);
52 use Tie::IxHash;
53
54 # Load debug
55 #use Data::Dumper;
56
57 # Documentation links
58 #XXX: see https://letsencrypt.github.io/acme-spec/ (probably based on https://ietf-wg-acme.github.io/acme/)
59 #XXX: see jwk rfc http://www.rfc-editor.org/rfc/rfc7517.txt
60 #XXX: see javascript implementation https://github.com/diafygi/gethttpsforfree/blob/gh-pages/js/index.js
61
62 # Set constants
63 use constant {
64 # Config infos
65 ACCOUNT => '/etc/acme/account.pem',
66 CONFIG => '/etc/acme/config',
67 PENDING => '/tmp/acme',
68 THUMBPRINT => '/etc/acme/thumbprint',
69 TERM => 'https://letsencrypt.org/documents/LE-SA-v1.3-September-21-2022.pdf',
70 MAIL => 'webmaster',
71
72 # Certificate info
73 CSR_SUFFIX => '.der',
74
75 # Redhat infos
76 RH_CERTS => '/etc/pki/tls/certs',
77 RH_PRIVATE => '/etc/pki/tls/private',
78 RH_SUFFIX => '.pem',
79
80 # Debian infos
81 DEB_CERTS => '/etc/ssl/certs',
82 DEB_PRIVATE => '/etc/ssl/private',
83 DEB_CERTS_SUFFIX => '.crt',
84 DEB_PRIVATE_SUFFIX => '.key',
85
86 # Dns infos
87 DNS_PREFIX => '_acme-challenge.',
88 DNS_SUFFIX => '.',
89
90 # Key infos
91 KEY_TYPE => 'rsa',
92 KEY_SIZE => 4096,
93
94 # Acme infos
95 #ACME_CERT => 'https://letsencrypt.org/certs/lets-encrypt-x3-cross-signed.pem',
96 ACME_DIR => 'https://acme-staging-v02.api.letsencrypt.org/directory',
97 ACME_PROD_DIR => 'https://acme-v02.api.letsencrypt.org/directory',
98
99 # Version
100 VERSION => '2.0.4',
101
102 # Timeout
103 TIMEOUT => 300
104 };
105
106 # User agent object
107 our $ua;
108
109 # Strerr backup
110 our $_stderr;
111
112 # JSON Web Key (JWK)
113 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
114 #our %jwk = (
115 # pubkey => undef,
116 # jwk => {
117 # alg => 'RS256',
118 # jwk => {
119 # # Exponent
120 # e => undef,
121 # # Key type
122 # kty => uc(KEY_TYPE),
123 # # Modulus
124 # n => undef
125 # }
126 # },
127 # thumbprint => undef
128 #);
129 tie(our %jwk, 'Tie::IxHash', pubkey => undef, jwk => undef, thumbprint => undef);
130 tie(%{$jwk{jwk}}, 'Tie::IxHash', alg => 'RS256', jwk => undef);
131 #XXX: strict ordering only really needed here for thumbprint sha256 digest
132 tie(%{$jwk{jwk}{jwk}}, 'Tie::IxHash', e => undef, kty => uc(KEY_TYPE), n => undef);
133
134 # Constructor
135 sub new {
136 # Extract params
137 my ($class, $verbose, $domain, $config) = @_;
138
139 # Create self hash
140 my $self = {};
141
142 # Link self to package
143 bless($self, $class);
144
145 # Save verbose
146 $self->{verbose} = $verbose;
147
148 # Save domain
149 $self->{domain} = $domain;
150
151 # Save config
152 $self->{config} = $config;
153
154 # Save domains
155 my @domains = ($domain->{domain}, @{$domain->{domains}});
156
157 # Show error if check fail
158 unless (defined $self->{domain}{mail}) {
159 confess('Missing mail');
160 }
161
162 # Transform mail in an array
163 unless (ref($self->{domain}{mail}) eq 'ARRAY') {
164 $self->{domain}{mail} = [ $self->{domain}{mail} ];
165 }
166
167 # Add extra check to mail validity
168 #XXX: mxcheck fail if there is only a A record on the domain
169 my $ev = Email::Valid->new(-fqdn => 1, -tldcheck => 1, -mxcheck => 1);
170
171 # Loop on each mail
172 map {
173 # Checke address
174 if (! defined $ev->address($_)) {
175 map { carp 'failed check: '.$_ if ($self->{verbose}) } $ev->details();
176 confess('Validate '.$_.' mail address failed');
177 }
178 } @{$self->{domain}{mail}};
179
180 # Check domains
181 map {
182 my $tld;
183
184 # Extract tld
185 unless (($tld) = $_ =~ m/\.(\w+)$/) {
186 confess('Extract '.$_.' tld failed');
187 }
188
189 # Check if tld exists
190 unless(Net::Domain::TLD::tld_exists($tld)) {
191 confess('Extracted '.$_.' tld '.$tld.' do not exists');
192 }
193
194 # Search a record
195 my $a = Net::DNS::Resolver->new->search($_, 'A', 'IN');
196
197 # Search aaaa record
198 my $aaaa = Net::DNS::Resolver->new->search($_, 'AAAA', 'IN');
199
200 # Trigger error for unresolvable domain
201 unless (
202 # Check if either has a A or AAAA record
203 scalar map {
204 ($_->type eq 'A' or $_->type eq 'AAAA') ? 1 : ();
205 }
206 # Merge both answer
207 (
208 (defined $a and defined $a->answer) ? $a->answer : (),
209 (defined $aaaa and defined $aaaa->answer) ? $aaaa->answer : ()
210 )
211 ) {
212 confess('Resolve '.$_.' to an A or AAAA record failed');
213 }
214 } @domains;
215
216 # Return class reference
217 return $self;
218 }
219
220 # Prepare environement
221 sub prepare {
222 my ($self) = @_;
223
224 # Extract cert directory and filename
225 my ($certFile, $certDir) = File::Spec->splitpath($self->{domain}{cert});
226
227 # Extract key directory and filename
228 my ($keyFile, $keyDir) = File::Spec->splitpath($self->{domain}{key});
229
230 # Extract account directory and filename
231 my ($accountFile, $accountDir) = File::Spec->splitpath($self->{domain}{account});
232
233 # Create all paths
234 {
235 make_path($certDir, $keyDir, $accountDir, $self->{config}{pending}, {error => \my $err});
236 if (@$err) {
237 map {
238 my ($file, $msg) = %{$_};
239 carp 'Mkdir '.($file ? $file.' ' : '').'failed: '.$msg if ($self->{verbose});
240 } @$err;
241 confess('Make path failed');
242 }
243 }
244
245 # Create user agent
246 $ua = LWP::UserAgent->new;
247 $ua->agent(__PACKAGE__.'/'.VERSION);
248
249 # Check that certificate is writable
250 unless (-w $certDir || -w $self->{domain}{cert}) {
251 confess('Directory '.$certDir.' or file '.$self->{domain}{cert}.' must be writable: '.$!);
252 }
253
254 # Check that key is readable or parent directory is writable
255 unless (-r $self->{domain}{key} || -w $keyDir) {
256 confess('File '.$self->{domain}{key}.' must be readable or directory '.$keyDir.' must be writable: '.$!);
257 }
258
259 # Check that account key is readable or parent directory is writable
260 unless (-r $self->{domain}{account} || -w $accountDir) {
261 confess('File '.$self->{domain}{account}.' must be readable or directory '.$accountDir.' must be writable: '.$!);
262 }
263
264 # Backup old certificate if possible
265 if (-w $certDir && -f $self->{domain}{cert}) {
266 my ($dt, $suffix) = undef;
267
268 # Extract datetime suffix
269 $suffix = ($dt = DateTime->from_epoch(epoch => stat($self->{domain}{cert})->mtime))->ymd('').$dt->hms('');
270
271 # Rename old certificate
272 unless(copy($self->{domain}{cert}, $self->{domain}{cert}.'.'.$suffix)) {
273 carp('Copy '.$self->{domain}{cert}.' to '.$self->{domain}{cert}.'.'.$suffix.' failed: '.$!);
274 }
275 }
276 }
277
278 # Drop stderr
279 sub _dropStdErr {
280 # Save stderr
281 open($_stderr, '>&STDERR') or die $!;
282 # Close it
283 close(STDERR) or die $!;
284 # Send to /dev/null
285 open(STDERR, '>', '/dev/null') or die $!;
286 }
287
288 # Restore stderr
289 sub _restoreStdErr {
290 # Close stderr
291 close(STDERR);
292 # Open it back
293 open(STDERR, '>&', $_stderr) or die $!;
294 }
295
296 # Generate required keys
297 sub genKeys {
298 my ($self) = @_;
299
300 # Generate account and server key if required
301 map {
302 # Check key existence
303 if (! -f $_) {
304 # Drop stderr
305 _dropStdErr();
306 # Generate key
307 #XXX: we drop stderr here because openssl can't be quiet on this command
308 capturex('openssl', ('genrsa', '-out', $_, KEY_SIZE));
309 # Restore stderr
310 _restoreStdErr();
311 }
312 } ($self->{domain}{account}, $self->{domain}{key});
313
314 # Extract modulus and publicExponent jwk
315 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
316 tie(%{$self->{account}}, 'Tie::IxHash', %jwk);
317 map {
318 if (/^Modulus=([0-9A-F]+)$/) {
319 # Extract to binary from hex and convert to base64 url
320 $self->{account}{jwk}{jwk}{n} = encode_base64url(pack("H*", $1) =~ s/^\0+//r);
321 } elsif (/^publicExponent:\s([0-9]+)\s\(0x[0-1]+\)$/) {
322 # Extract to binary from int, trim leading zeros and convert to base64 url
323 chomp ($self->{account}{jwk}{jwk}{e} = encode_base64url(pack("N", $1) =~ s/^\0+//r));
324 }
325 } capturex('openssl', ('rsa', '-text', '-in', $self->{domain}{account}, '-noout', '-modulus'));
326
327 # Drop stderr
328 _dropStdErr();
329 # Extract account public key
330 $self->{account}{pubkey} = join('', map { chomp; $_; } capturex('openssl', ('rsa', '-in', $self->{domain}{account}, '-pubout')));
331 # Restore stderr
332 _restoreStdErr();
333
334 # Store thumbprint
335 #XXX: convert base64 to base64 url
336 $self->{account}{thumbprint} = (sha256_base64(to_json($self->{account}{jwk}{jwk})) =~ s/=+\z//r) =~ tr[+/][-_]r;
337 }
338
339 # Directory call
340 sub directory {
341 my ($self) = @_;
342
343 # Set time
344 my $time = time;
345
346 # Set directory
347 my $dir = $self->{domain}{prod} ? ACME_PROD_DIR : ACME_DIR;
348
349 # Create a request
350 my $req = HTTP::Request->new(GET => $dir.'?'.$time);
351
352 # Get request
353 my $res = $ua->request($req);
354
355 # Handle error
356 unless ($res->is_success) {
357 confess('GET '.$dir.'?'.$time.' failed: '.$res->status_line);
358 }
359
360 # Init content
361 my %content;
362
363 # Extract content
364 unless (%content = %{from_json($res->content)}) {
365 confess('GET '.$dir.'?'.$time.' from_json failed: '.$res->status_line);
366 }
367
368 # Merge uris in self content
369 $self->{req}{dir} = $dir;
370 $self->{req}{keyChange} = $content{keyChange};
371 $self->{req}{newNonce} = $content{newNonce};
372 $self->{req}{newAccount} = $content{newAccount};
373 $self->{req}{revokeCert} = $content{revokeCert};
374 $self->{req}{newOrder} = $content{newOrder};
375
376 # Check term
377 unless ($self->{config}{term} eq $content{meta}{termsOfService}) {
378 confess('GET '.$dir.'?'.$time.' term: '.$content{meta}{termsOfService}.' differ from config: '.$self->{config}{term});
379 }
380 }
381
382 # Nonce call
383 sub nonce {
384 my ($self) = @_;
385
386 # Set time
387 my $time = time;
388
389 # Create a request
390 my $req = HTTP::Request->new(HEAD => $self->{req}{newNonce}.'?'.$time);
391
392 # Get request
393 my $res = $ua->request($req);
394
395 # Handle error
396 unless ($res->is_success) {
397 confess('HEAD '.$self->{req}{newNonce}.'?'.$time.' failed: '.$res->status_line);
398 }
399
400 # Save nonce
401 $self->{req}{nonce} = $res->headers->{'replay-nonce'};
402 }
403
404 # Post request
405 sub _post {
406 my ($self, $uri, $payload) = @_;
407
408 # Init protected
409 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
410 #XXX: strict ordering only really needed here for thumbprint sha256 digest
411 tie(my %protected, 'Tie::IxHash', alg => $self->{account}{jwk}{alg}, jwk => $self->{account}{jwk}{jwk}, nonce => $self->{req}{nonce}, url => $uri);
412
413 # We have a kid
414 if (defined($self->{req}{kid})) {
415 # Replace jwk entry with it
416 #XXX: when kid is available all request with jwk are rejected by the api
417 %protected = (alg => $self->{account}{jwk}{alg}, kid => $self->{req}{kid}, nonce => $self->{req}{nonce}, url => $uri);
418 }
419
420 # Encode protected
421 my $protected = encode_base64url(to_json(\%protected));
422
423 # Encode payload
424 $payload = encode_base64url(to_json($payload)) unless ($payload eq '');
425
426 # Sign temp file
427 my $stf = File::Temp->new();
428
429 # Append protect.payload to stf
430 print $stf $protected.'.'.$payload;
431
432 # Close stf
433 close($stf);
434
435 # Generate digest of stf
436 my $signature = encode_base64url(join('', capturex('openssl', ('dgst', '-sha256', '-binary', '-sign', $self->{domain}{account}, $stf->filename))) =~ s/^\0+//r);
437
438 # Create a request
439 my $req = HTTP::Request->new(POST => $uri);
440
441 # Set request header
442 $req->header('Content-Type' => 'application/jose+json');
443
444 # Set new-reg request content
445 $req->content(to_json({
446 protected => $protected,
447 payload => $payload,
448 signature => $signature
449 }));
450
451 # Post request
452 my $res = $ua->request($req);
453
454 # Save nonce
455 if (defined $res->headers->{'replay-nonce'}) {
456 $self->{req}{nonce} = $res->headers->{'replay-nonce'};
457 }
458
459 # Return res object
460 return $res;
461 }
462
463 # Resolve dns and check content
464 #XXX: see https://community.centminmod.com/threads/looks-like-letsencrypt-dns-01-is-ready.5845/#12 for example
465 sub _dnsCheck {
466 my ($self, $domain, $token) = @_;
467
468 # Generate signature from content
469 my $signature = ((sha256_base64($token.'.'.$self->{account}{thumbprint})) =~ s/=+\z//r) =~ tr[+/][-_]r;
470
471 # Search txt record
472 my $txt = Net::DNS::Resolver->new->search(DNS_PREFIX.$domain.DNS_SUFFIX, 'TXT', 'IN');
473
474 # Check that we have a txt record
475 unless (defined $txt and defined $txt->answer and scalar map { $_->type eq 'TXT' ? 1 : (); } $txt->answer) {
476 carp 'Resolve '.DNS_PREFIX.$domain.DNS_SUFFIX.' to a TXT record failed' if ($self->{verbose});
477 return;
478 }
479
480 # Check that txt record data match signature
481 unless (scalar map { ($_->type eq 'TXT' and $_->txtdata eq $signature) ? 1 : (); } $txt->answer) {
482 # Check verbose
483 if ($self->{verbose}) {
484 # Loop on each answer
485 map {
486 # Check if we have a TXT record with different value
487 if ($_->type eq 'TXT' and $_->txtdata ne $signature) {
488 carp 'Resolved '.DNS_PREFIX.$domain.DNS_SUFFIX.' with "'.$_->txtdata.'" instead of "'.$signature.'"';
489 }
490 } $txt->answer;
491 }
492 return;
493 }
494
495 # Return success
496 return 1;
497 }
498
499 # Get uri and check content
500 sub _httpCheck {
501 my ($self, $domain, $token) = @_;
502
503 # Create a request
504 my $req = HTTP::Request->new(GET => 'http://'.$domain.'/.well-known/acme-challenge/'.$token);
505
506 # Check if thumbprint is writeable
507 if (-w $self->{config}{thumbprint}) {
508 # Try to write thumbprint
509 write_file($self->{config}{thumbprint}, $self->{account}{thumbprint});
510 }
511
512 # Get request
513 my $res = $ua->request($req);
514
515 # Handle error
516 unless ($res->is_success) {
517 carp 'Fetch http://'.$domain.'/.well-known/acme-challenge/'.$token.' failed: '.$res->status_line if ($self->{verbose});
518 return;
519 }
520
521 # Handle invalid content
522 unless($res->content =~ /^$token.$self->{account}{thumbprint}\s*$/) {
523 carp 'Fetched http://'.$domain.'/.well-known/acme-challenge/'.$token.' with "'.$res->content.'" instead of "'.$token.'.'.$self->{account}{thumbprint}.'"' if ($self->{verbose});
524 return;
525 }
526
527 # Return success
528 return 1;
529 }
530
531 # Register account
532 #XXX: see doc at https://ietf-wg-acme.github.io/acme/#rfc.section.6.3
533 sub account {
534 my ($self) = @_;
535
536 # Init pending directory
537 $self->{req}{pending} = $self->{config}{pending}.'/'.encode_base64url($self->{req}{dir}).'/'.encode_base64url(join(',', @{$self->{domain}{mail}}));
538
539 # Create pending directory
540 {
541 make_path($self->{req}{pending}, {error => \my $err});
542 if (@$err) {
543 map {
544 my ($file, $msg) = %{$_};
545 carp 'Mkdir '.($file ? $file.' ' : '').'failed: '.$msg if ($self->{verbose});
546 } @$err;
547 confess('Make path failed');
548 }
549 }
550
551 # Init file
552 #XXX: we use this file to store the fetched account
553 my $file = $self->{req}{pending}.'/'.(((sha256_base64(join(',', @{$self->{domain}{mail}}))) =~ s/=+\z//r) =~ tr[+/][-_]r);
554
555 # Init content
556 my $content = undef;
557
558 # Load account content or post a new one
559 if (
560 #XXX: use eval to workaround a fatal in from_json
561 ! defined eval {
562 # Check that file exists
563 -f $file &&
564 # Read it
565 ($content = read_file($file)) &&
566 # Decode it
567 ($content = from_json($content))
568 }
569 ) {
570 # Init tied payload
571 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
572 tie(my %payload, 'Tie::IxHash', termsOfServiceAgreed => JSON::true, contact => []);
573
574 # Loop on mails
575 map {
576 # Append mail to payload
577 $payload{contact}[scalar @{$payload{contact}}] = 'mailto:'.$_;
578 } @{$self->{domain}{mail}};
579
580 # Post newAccount request
581 # TODO: change contact field in config to contain directly the array [mailto:example@example.com,...] ???
582 #XXX: contact array may contain a tel:+33612345678 for example (supported ???)
583 my $res = $self->_post($self->{req}{'newAccount'}, \%payload);
584
585 # Handle error
586 unless ($res->is_success) {
587 confess('POST '.$self->{req}{'newAccount'}.' failed: '.$res->status_line)
588 }
589
590 # Store kid from header location
591 $content = {
592 'kid' => $res->headers->{location},
593 };
594
595 # Write to file
596 write_file($file, to_json($content));
597 }
598
599 # Set kid from content
600 $self->{req}{kid} = $content->{kid};
601
602 }
603
604 # Authorize domains
605 sub order {
606 my ($self) = @_;
607
608 # Init file
609 #XXX: we use this file to store the requested domains on our side
610 #XXX: see bug https://github.com/letsencrypt/boulder/issues/3335 and https://community.letsencrypt.org/t/acmev2-orders-list/51662
611 my $file = $self->{req}{pending}.'/'.(((sha256_base64(join(',', ($self->{domain}{domain}, @{$self->{domain}{domains}})))) =~ s/=+\z//r) =~ tr[+/][-_]r);
612
613 # Init content
614 my $content = undef;
615
616 # Load account content or post a new one
617 if (
618 #XXX: use eval to workaround a fatal in from_json
619 ! defined eval {
620 # Check that file exists
621 -f $file &&
622 # Read it
623 ($content = read_file($file)) &&
624 # Decode it
625 ($content = from_json($content))
626 # Check expiration
627 } || (str2time($content->{expires}) <= time()+3600)
628 ) {
629 # Init tied payload
630 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
631 #XXX: https://www.perlmonks.org/?node_id=1215976
632 #XXX: optional notBefore, notAfter, see https://ietf-wg-acme.github.io/acme/draft-ietf-acme-acme.html#applying-for-certificate-issuance
633 tie(my %payload, 'Tie::IxHash', identifiers => []);
634
635 # Loop on domains
636 map {
637 # Tie in a stable hash and append to identifiers array
638 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
639 tie(%{$payload{identifiers}[scalar @{$payload{identifiers}}]}, 'Tie::IxHash', type => 'dns', value => $_);
640 } ($self->{domain}{domain}, @{$self->{domain}{domains}});
641
642 # Post new order request
643 my $res = $self->_post($self->{req}{'newOrder'}, \%payload);
644
645 # Handle error
646 unless ($res->is_success) {
647 confess('POST '.$self->{req}{'newOrder'}.' failed: '.$res->status_line);
648 }
649
650 # Handle error
651 unless ($res->content) {
652 confess('POST '.$self->{req}{'newOrder'}.' empty content: '.$res->status_line);
653 }
654
655 # Handle error
656 unless ($res->headers->{location}) {
657 confess('POST '.$self->{req}{'newOrder'}.' missing location: '.$res->status_line);
658 }
659
660 # Extract content
661 $content = from_json($res->content);
662
663 # Write to file
664 write_file($file, to_json($content));
665 }
666
667 # Save the authorizations
668 $self->{req}{authorizations} = [ keys %{{ map { $_ => undef } @{$content->{authorizations}} }} ];
669
670 # Save the finalize uri
671 $self->{req}{finalize} = $content->{finalize};
672
673 # Create challenges hash
674 %{$self->{req}{challenges}} = ();
675
676 # Extract authorizations
677 map {
678 # Init uri
679 my $uri = $_;
680
681 # Init content
682 my $content = undef;
683
684 # Init file
685 #XXX: tmpdir.'/'.<orderuri>.'/'.<authuri>
686 my $file = $self->{req}{pending}.'/'.encode_base64url($uri);
687
688 # Load auth request content or post a new one
689 #TODO: add more check on cache file ???
690 if (
691 #XXX: use eval to workaround a fatal in from_json
692 ! defined eval {
693 # Check that file exists
694 -f $file &&
695 # Read it
696 ($content = read_file($file)) &&
697 # Decode it
698 ($content = from_json($content))
699 # Check expiration
700 } || (str2time($content->{expires}) <= time()+3600)
701 ) {
702 # Post new-authz request
703 my $res = $self->_post($uri, '');
704
705 # Handle error
706 unless ($res->is_success) {
707 confess('POST '.$uri.' failed: '.$res->status_line);
708 }
709
710 # Decode content
711 $content = from_json($res->content);
712
713 # Check identifier
714 unless (
715 defined $content->{identifier} and
716 defined $content->{identifier}{type} and
717 defined $content->{identifier}{value}
718 ) {
719 confess('POST '.$uri.' missing identifier: '.$res->status_line);
720 } else {
721 unless (
722 $content->{identifier}{type} eq 'dns' and
723 $content->{identifier}{value}
724 ) {
725 confess('POST '.$uri.' invalid identifier: '.$res->status_line);
726 }
727 }
728
729 # Check status
730 unless ($content->{status} eq 'valid' or $content->{status} eq 'pending') {
731 confess('POST '.$uri.' for '.$content->{identifier}{value}.' failed: '.$res->status_line);
732 }
733
734 # Write to file
735 write_file($file, to_json($content));
736 }
737
738 # Add challenge
739 %{$self->{req}{challenges}{$content->{identifier}{value}}} = (
740 status => $content->{status},
741 expires => $content->{expires},
742 challenges => {},
743 polls => {}
744 );
745
746 # Extract challenges
747 map {
748 # Save if valid
749 if ($_->{status} eq 'valid') {
750 $self->{req}{challenges}{$content->{identifier}{value}}{status} = $_->{status};
751 # Check is still polling
752 } elsif ($content->{status} eq 'pending') {
753 # Add to challenges list for later use
754 $self->{req}{challenges}{$content->{identifier}{value}}{challenges}{$_->{type}} = {
755 status => $_->{status},
756 token => $_->{token},
757 url => $_->{url}
758 };
759 }
760 } @{$content->{challenges}};
761
762 # Set identifier
763 my $identifier = $content->{identifier}{value};
764
765 # Save pending data
766 if ($self->{req}{challenges}{$identifier}{status} eq 'pending') {
767 # Check challenges
768 map {
769 # One test already validated this auth request
770 unless($self->{req}{challenges}{$identifier}{status} eq 'valid') {
771 # One challenge validated
772 if ($self->{req}{challenges}{$identifier}{challenges}{$_}{status} eq 'valid') {
773 $self->{req}{challenges}{$identifier}{status} = $self->{req}{challenges}{$identifier}{challenges}{$_}{status};
774 # This challenge is to be validated
775 } elsif ($self->{req}{challenges}{$identifier}{challenges}{$_}{status} eq 'pending') {
776 #TODO: implement tls-alpn-01 challenge someday if possible
777 if (
778 ($_ eq 'http-01' and $self->_httpCheck($identifier, $self->{req}{challenges}{$identifier}{challenges}{$_}{token})) or
779 ($_ eq 'dns-01' and $self->_dnsCheck($identifier, $self->{req}{challenges}{$identifier}{challenges}{$_}{token}))
780 ) {
781 # Init file
782 #XXX: tmpdir.'/'.<orderuri>.'/'.<authuri>
783 my $file = $self->{req}{pending}.'/'.encode_base64url($self->{req}{challenges}{$identifier}{challenges}{$_}{url});
784
785 # Reset content
786 $content = undef;
787
788 # Load auth request content or post a new one
789 #TODO: add more check on cache file ???
790 if (
791 #XXX: use eval to workaround a fatal in from_json
792 ! defined eval {
793 # Check that file exists
794 -f $file &&
795 # Read it
796 ($content = read_file($file)) &&
797 # Decode it
798 ($content = from_json($content))
799 #TODO: Check file modification time ? There is no expires field in json answer
800 }# || (str2time($content->{expires}) <= time()+3600)
801 ) {
802 # Post challenge request
803 my $res = $self->_post(
804 $self->{req}{challenges}{$identifier}{challenges}{$_}{url},
805 {keyAuthorization => $self->{req}{challenges}{$identifier}{challenges}{$_}{token}.'.'.$self->{account}{thumbprint}}
806 );
807
808 # Handle error
809 unless ($res->is_success) {
810 confess('POST '.$self->{req}{challenges}{$identifier}{challenges}{$_}{url}.' failed: '.$res->status_line);
811 }
812
813 # Extract content
814 $content = from_json($res->content);
815
816 # Write to file
817 write_file($file, to_json($content));
818 }
819
820 # Save if valid
821 if ($content->{status} eq 'valid') {
822 $self->{req}{challenges}{$identifier}{status} = $content->{status};
823 # Check is still polling
824 } elsif ($content->{status} eq 'pending') {
825 # Add to poll list for later use
826 $self->{req}{challenges}{$identifier}{polls}{$content->{type}} = 1;
827 }
828 }
829 }
830 }
831 } keys %{$self->{req}{challenges}{$identifier}{challenges}};
832
833 # Check if check is challenge still in pending and no polls
834 if ($self->{req}{challenges}{$identifier}{status} eq 'pending' && scalar keys %{$self->{req}{challenges}{$identifier}{polls}} == 0) {
835 # Loop on all remaining challenges
836 map {
837 #TODO: implement tls-alpn-01 challenge someday if possible
838 # Display help for http-01 check
839 if ($_ eq 'http-01') {
840 print STDERR 'Require URI http://'.$identifier.'/.well-known/acme-challenge/'.$self->{req}{challenges}{$identifier}{challenges}{$_}{token}.' with "'.$self->{req}{challenges}{$identifier}{challenges}{$_}{token}.'.'.$self->{account}{thumbprint}.'"'."\n";
841 # Display help for dns-01 check
842 } elsif ($_ eq 'dns-01') {
843 print STDERR 'Require TXT record _acme-challenge.'.$identifier.'. with "'.(((sha256_base64($self->{req}{challenges}{$identifier}{challenges}{$_}{token}.'.'.$self->{account}{thumbprint})) =~ s/=+\z//r) =~ tr[+/][-_]r).'"'."\n";
844 }
845 } keys %{$self->{req}{challenges}{$identifier}{challenges}};
846 }
847 }
848 } @{$self->{req}{authorizations}};
849
850 # Init max run
851 my $remaining = TIMEOUT;
852
853 # Poll pending
854 while (--$remaining >= 0 and scalar map { ($_->{status} eq 'pending' and scalar keys %{$_->{polls}}) ? 1 : (); } values %{$self->{req}{challenges}}) {
855 # Sleep
856 sleep(1);
857
858 # Poll remaining pending
859 map {
860 # Init identifier
861 my $identifier = $_;
862
863 # Poll remaining polls
864 map {
865 # Post challenge request
866 #XXX: no cache here we force update
867 my $res = $self->_post(
868 $self->{req}{challenges}{$identifier}{challenges}{$_}{url},
869 {keyAuthorization => $self->{req}{challenges}{$identifier}{challenges}{$_}{token}.'.'.$self->{account}{thumbprint}}
870 );
871
872 # Handle error
873 unless ($res->is_success) {
874 confess('POST '.$self->{req}{challenges}{$identifier}{challenges}{$_}{url}.' failed: '.$res->status_line);
875 }
876
877 # Extract content
878 $content = from_json($res->content);
879
880 # Init file
881 #XXX: tmpdir.'/'.<orderuri>.'/'.<authuri>
882 my $file = $self->{req}{pending}.'/'.encode_base64url($self->{req}{challenges}{$identifier}{challenges}{$_}{url});
883
884 # Write to file
885 write_file($file, to_json($content));
886
887 # Save status
888 if ($content->{status} ne 'pending') {
889 $self->{req}{challenges}{$identifier}{status} = $content->{status};
890 }
891 } keys %{$self->{req}{challenges}{$identifier}{polls}};
892 } map { $self->{req}{challenges}{$_}{status} eq 'pending' ? $_ : (); } keys %{$self->{req}{challenges}};
893 }
894
895
896 # Check if thumbprint is writeable
897 if (-w $self->{config}{thumbprint}) {
898 # Try to write thumbprint
899 write_file($self->{config}{thumbprint}, '');
900 }
901
902 # Stop here with remaining challenge
903 if (scalar map { $_->{status} ne 'valid' ? 1 : (); } values %{$self->{req}{challenges}}) {
904 #TODO: Deactivate all activated domains ?
905 #XXX: see if implemented by letsencrypt ACMEv2
906 #map {
907 # # Post deactivation request
908 # my $res = $self->_post($self->{challenges}{$_}{http_uri}, {resource => 'authz', status => 'deactivated'});
909 # # Handle error
910 # unless ($res->is_success) {
911 # confess('POST '.$self->{challenges}{$_}{http_uri}.' failed: '.$res->status_line);
912 # }
913 #} map { $self->{challenges}{$_}{status} eq 'valid' ? $_ : () } keys %{$self->{challenges}};
914
915 # Stop here as a domain of csr list failed authorization
916 if ($self->{verbose}) {
917 my @domains = map { $self->{req}{challenges}{$_}{status} ne 'valid' ? $_ : (); } keys %{$self->{req}{challenges}};
918 #my @domains = map { ! defined $self->{challenges}{$_}{status} or $self->{challenges}{$_}{status} ne 'valid' ? $_ : (); } keys %{$self->{challenges}};
919 carp 'Fix challenge'.(scalar @domains > 1?'s':'').' for: '.join(', ', @domains);
920 }
921 exit EXIT_FAILURE;
922 }
923 }
924
925 # Generate certificate request
926 sub genCsr {
927 my ($self) = @_;
928
929 # Init csr file
930 #XXX: tmpdir.'/'.<orderuri>.'/'.<thumbprint>.':'.<mail>.':'.join(',', @domains).'.<prodstaging>.'.CSR_SUFFIX
931 $self->{req}{csr} = $self->{req}{pending}.'/'.(((sha256_base64(join(',', ($self->{domain}{domain}, @{$self->{domain}{domains}})))) =~ s/=+\z//r) =~ tr[+/][-_]r).CSR_SUFFIX;
932
933 # Reuse certificate request file without domain/mail change
934 if (! -f $self->{req}{csr}) {
935 # Openssl config template
936 my $oct = File::Temp->new(UNLINK => 0);
937
938 # Save data start position
939 my $pos = tell DATA;
940
941 # Init counter
942 my $i = 0;
943
944 # Prepare mail
945 my $mail = join("\n", map { $i++.'.emailAddress'."\t\t\t".'= '.$_; } @{$self->{domain}{mail}});
946
947 # Load template from data
948 map { s/__EMAIL_ADDRESS__/$mail/; s/__COMMON_NAME__/$self->{domain}{domain}/; print $oct $_; } <DATA>;
949
950 # Reseek data
951 seek(DATA, $pos, 0);
952
953 # Append domain names
954 $i = 0;
955 map { print $oct 'DNS.'.$i++.' = '.$_."\n"; } ($self->{domain}{domain}, @{$self->{domain}{domains}});
956
957 # Generate csr
958 #XXX: read certificate request with: openssl req -inform DER -in $self->{req}{csr} -text
959 capturex('openssl', ('req', '-new', '-outform', 'DER', '-key', $self->{domain}{key}, '-config', $oct->filename, '-out', $self->{req}{csr}));
960
961 # Close oct
962 close($oct);
963 }
964 }
965
966 # Issue certificate
967 sub issue {
968 my ($self) = @_;
969
970 # Open csr file
971 open(my $fh, '<', $self->{req}{csr}) or die $!;
972
973 # Load csr
974 my $csr = encode_base64url(join('', <$fh>) =~ s/^\0+//r);
975
976 # Close csr file
977 close($fh) or die $!;
978
979 # Init file
980 #XXX: tmpdir.'/'.<orderuri>.'/'.<finalizeuri>
981 my $file = $self->{req}{pending}.'/'.encode_base64url($self->{req}{finalize});
982
983 # Init content
984 my $content = undef;
985
986 # Init res
987 my $res = undef;
988
989 # Load auth request content or post a new one
990 #TODO: add more check on cache file ???
991 if (
992 #XXX: use eval to workaround a fatal in from_json
993 ! defined eval {
994 # Check that file exists
995 -f $file &&
996 # Read it
997 ($content = read_file($file)) &&
998 # Decode it
999 ($content = from_json($content))
1000 # Check file modification time ? There is no expires field in json answer
1001 } || (str2time($content->{expires}) <= time()+3600)
1002 ) {
1003 # Post certificate request
1004 $res = $self->_post($self->{req}{finalize}, {csr => $csr});
1005
1006 # Handle error
1007 unless ($res->is_success) {
1008 confess('POST '.$self->{req}{finalize}.' failed: '.$res->status_line);
1009 }
1010
1011 # Extract content
1012 $content = from_json($res->content);
1013
1014 # Check status
1015 unless (defined $content->{status} and $content->{status} eq 'valid') {
1016 confess('POST '.$self->{req}{finalize}.' failed: invalid status: '.(defined $content->{status}?$content->{status}:'undefined'));
1017 }
1018
1019 # Check certificate
1020 unless (defined $content->{certificate} and $content->{certificate}) {
1021 confess('POST '.$self->{req}{finalize}.' failed: invalid certificate: '.(defined $content->{certificate}?$content->{certificate}:'undefined'));
1022 }
1023
1024 # Write to file
1025 write_file($file, to_json($content));
1026 }
1027
1028 # Set certificate
1029 $self->{req}{certificate} = $content->{certificate};
1030
1031 # Set file
1032 #XXX: tmpdir.'/'.<orderuri>.'/'.<certificateuri>
1033 $file = $self->{req}{pending}.'/'.encode_base64url($self->{req}{certificate});
1034
1035 # Reset content
1036 $content = undef;
1037
1038 # Load auth request content or post a new one
1039 #TODO: add more check on cache file ???
1040 if (
1041 #XXX: use eval to workaround a fatal in from_json
1042 ! defined eval {
1043 # Check that file exists
1044 -f $file &&
1045 # Read it
1046 ($content = read_file($file))
1047 # Check file modification time ? There is no expires field in json answer
1048 #TODO: add a checck on modification time ???
1049 }# || (str2time($content->{expires}) <= time()+3600)
1050 ) {
1051 # Post certificate request
1052 $res = $self->_post($self->{req}{certificate}, '');
1053
1054 # Handle error
1055 unless ($res->is_success) {
1056 confess('POST '.$self->{req}{certificate}.' failed: '.$res->status_line);
1057 }
1058
1059 # Set content
1060 $content = $res->content;
1061
1062 # Write to file
1063 write_file($file, $content);
1064 }
1065
1066 # Remove first multi-line jump
1067 $content =~ s/\n\n/\n/;
1068
1069 # Remove ISRG Root X1 certificate signed by DST Root CA X3 present after second multi-line jump
1070 $content =~ s/\n\n.*//s;
1071
1072 # Remove trailing line jump
1073 chomp $content;
1074
1075 # Write to cert file
1076 write_file($self->{domain}{cert}, $content);
1077
1078 # Print success
1079 carp 'Saved '.$self->{domain}{cert}.' pem certificate' if ($self->{verbose});
1080 }
1081
1082 1;
1083
1084 __DATA__
1085 #
1086 # OpenSSL configuration file.
1087 # This is mostly being used for generation of certificate requests.
1088 #
1089
1090 [ req ]
1091 default_bits = 2048
1092 default_md = sha256
1093 prompt = no
1094 distinguished_name = req_distinguished_name
1095 # The extentions to add to the self signed cert
1096 x509_extensions = v3_ca
1097 # The extensions to add to a certificate request
1098 req_extensions = v3_req
1099
1100 # This sets a mask for permitted string types. There are several options.
1101 # utf8only: only UTF8Strings (PKIX recommendation after 2004).
1102 # WARNING: ancient versions of Netscape crash on BMPStrings or UTF8Strings.
1103 string_mask = utf8only
1104
1105 [ req_distinguished_name ]
1106 countryName = US
1107 stateOrProvinceName = State or Province Name
1108 localityName = Locality Name
1109 organizationName = Organization Name
1110 organizationalUnitName = Organizational Unit Name
1111 commonName = __COMMON_NAME__
1112 __EMAIL_ADDRESS__
1113
1114 [ v3_req ]
1115 basicConstraints = CA:false
1116 keyUsage = nonRepudiation, digitalSignature, keyEncipherment
1117 subjectAltName = email:move
1118 subjectAltName = @alt_names
1119
1120 [ v3_ca ]
1121 subjectKeyIdentifier = hash
1122 authorityKeyIdentifier = keyid:always,issuer
1123 basicConstraints = CA:true
1124
1125 [alt_names]
Letsencrypt perl client