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


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