dcfabf3ea5e97db38ee6484206841b02278fde00
[acme] / acme.pm
1 # acme package
2 package acme;
3
4 # Best practice
5 use strict;
6 use warnings;
7
8 # Symbol export
9 use Exporter;
10 our @ISA = qw(Exporter);
11
12 # Load dependancies
13 use Carp qw(carp confess);
14 use Date::Parse qw(str2time);
15 use DateTime;
16 use Digest::SHA qw(sha256_base64);
17 use Email::Valid;
18 use File::Path qw(make_path);
19 use File::Slurp qw(read_file write_file);
20 use File::Temp; # qw( :seekable );
21 use IPC::System::Simple qw(capturex);
22 use JSON qw(encode_json decode_json);
23 use LWP;
24 use MIME::Base64 qw(encode_base64url encode_base64);
25 use Net::Domain::TLD;
26 use Tie::IxHash;
27 use POSIX qw(EXIT_FAILURE);
28
29 # Debug
30 use Data::Dumper;
31
32 # Documentation links
33 #XXX: see https://letsencrypt.github.io/acme-spec/ (probably based on https://ietf-wg-acme.github.io/acme/)
34 #XXX: see jwk rfc http://www.rfc-editor.org/rfc/rfc7517.txt
35 #XXX: see javascript implementation https://github.com/diafygi/gethttpsforfree/blob/gh-pages/js/index.js
36
37 # Set constants
38 use constant {
39 DS => '/',
40
41 CERT_DIR => 'cert',
42 KEY_DIR => 'key',
43 PENDING_DIR => 'pending',
44
45 ACCOUNT_KEY => 'account.pem',
46 ACCOUNT_PUB => 'account.pub',
47 SERVER_KEY => 'server.pem',
48 REQUEST_CSR => 'request.der',
49 SERVER_CRT => 'server.crt',
50 # rsa
51 KEY_TYPE => 'rsa',
52 # 2048|4096
53 KEY_SIZE => 4096,
54
55 ACME_DIR => 'https://acme-staging.api.letsencrypt.org/directory',
56 #ACME_DIR => 'https://acme-v01.api.letsencrypt.org/directory',
57 ACME_TERMS => 'https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf',
58
59 VERSION => 'v0.1'
60 };
61
62 # User agent object
63 our $ua;
64
65 # Debug
66 our $_debug = 0;
67
68 # Strerr backup
69 our $_stderr;
70
71 # JSON Web Key (JWK)
72 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
73 #our %jwk = (
74 # pubkey => undef,
75 # jwk => {
76 # alg => 'RS256',
77 # jwk => {
78 # # Exponent
79 # e => undef,
80 # # Key type
81 # kty => uc(KEY_TYPE),
82 # # Modulus
83 # n => undef
84 # }
85 # },
86 # thumbprint => undef
87 #);
88 tie(our %jwk, 'Tie::IxHash', pubkey => undef, jwk => undef, thumbprint => undef);
89 tie(%{$jwk{jwk}}, 'Tie::IxHash', alg => 'RS256', jwk => undef);
90 #XXX: strict ordering only really needed here for thumbprint sha256 digest
91 tie(%{$jwk{jwk}{jwk}}, 'Tie::IxHash', e => undef, kty => uc(KEY_TYPE), n => undef);
92
93 # Constructor
94 sub new {
95 # Extract params
96 my ($class, $mail, @domains) = @_;
97
98 # Create self hash
99 my $self = {};
100
101 # Link self to package
102 bless($self, $class);
103
104 # Add extra check to mail validity
105 #XXX: mxcheck fail if there is only a A record on the domain
106 my $ev = Email::Valid->new(-fqdn => 1, -tldcheck => 1, -mxcheck => 1);
107
108 # Show error if check fail
109 if (! defined $ev->address($mail)) {
110 map { carp 'failed check: '.$_ if ($_debug) } $ev->details();
111 confess 'Email::Valid->address failed';
112 }
113
114 # Save mail
115 $self->{mail} = $mail;
116
117 # Create resolver
118 my $res = new Net::DNS::Resolver();
119
120 # Check domains
121 map {
122 my $tld;
123
124 # Extract tld
125 unless (($tld) = $_ =~ m/\.(\w+)$/) {
126 confess $_.'\'s tld extraction failed';
127 }
128
129 # Check if tld exists
130 unless(Net::Domain::TLD::tld_exists($tld)) {
131 confess $tld.' tld from '.$_.' don\'t exists';
132 }
133
134 # Check if we get dns answer
135 #XXX: only search A type because letsencrypt don't support ipv6 (AAAA) yet
136 unless(my $rep = $res->search($_, 'A')) {
137 confess 'search A record for '.$_.' failed';
138 } else {
139 unless (scalar map { $_->type eq 'A' ? 1 : (); } $rep->answer) {
140 confess 'search recursively A record for '.$_.' failed';
141 }
142 }
143 } @domains;
144
145 # Save domains
146 @{$self->{domains}} = @domains;
147
148 # Return class reference
149 return $self;
150 }
151
152 # Prepare environement
153 sub prepare {
154 my ($self) = @_;
155
156 # Create all paths
157 make_path(CERT_DIR, KEY_DIR, PENDING_DIR.'/'.$self->{mail}, {error => \my $err});
158 if (@$err) {
159 map {
160 my ($file, $msg) = %$_;
161 carp ($file eq '' ? '' : $file.': ').$msg if ($_debug);
162 } @$err;
163 confess 'make_path failed';
164 }
165
166 # Create user agent
167 $ua = LWP::UserAgent->new;
168 $ua->agent(__PACKAGE__.'/'.VERSION)
169 }
170
171 # Drop stderr
172 sub _dropStdErr {
173 # Save stderr
174 open($_stderr, '>&STDERR') or die $!;
175 # Close it
176 close(STDERR) or die $!;
177 # Send to /dev/null
178 open(STDERR, '>', '/dev/null') or die $!;
179 }
180
181 # Restore stderr
182 sub _restoreStdErr {
183 # Close stderr
184 close(STDERR);
185 # Open it back
186 open(STDERR, '>&', $_stderr) or die $!;
187 }
188
189 # Generate required keys
190 sub genKeys {
191 my ($self) = @_;
192
193 # Generate account and server key if required
194 map {
195 # Check key existence
196 if (! -f $_) {
197 # Drop stderr
198 _dropStdErr();
199 # Generate key
200 #XXX: we drop stderr here because openssl can't be quiet on this command
201 capturex('openssl', ('genrsa', '-out', $_, KEY_SIZE));
202 # Restore stderr
203 _restoreStdErr();
204 }
205 } (KEY_DIR.DS.ACCOUNT_KEY, KEY_DIR.DS.SERVER_KEY);
206
207 # Extract modulus and publicExponent jwk
208 #XXX: same here we tie to keep ordering
209 tie(%{$self->{account}}, 'Tie::IxHash', %jwk);
210 map {
211 if (/^Modulus=([0-9A-F]+)$/) {
212 # Extract to binary from hex and convert to base64 url
213 $self->{account}{jwk}{jwk}{n} = encode_base64url(pack("H*", $1) =~ s/^\0+//r);
214 } elsif (/^publicExponent:\s([0-9]+)\s\(0x[0-1]+\)$/) {
215 # Extract to binary from int, trim leading zeros and convert to base64 url
216 chomp ($self->{account}{jwk}{jwk}{e} = encode_base64url(pack("N", $1) =~ s/^\0+//r));
217 }
218 } capturex('openssl', ('rsa', '-text', '-in', KEY_DIR.DS.ACCOUNT_KEY, '-noout', '-modulus'));
219
220 # Drop stderr
221 _dropStdErr();
222 # Extract account public key
223 $self->{account}{pubkey} = join('', map { chomp; $_; } capturex('openssl', ('rsa', '-in', KEY_DIR.DS.ACCOUNT_KEY, '-pubout')));
224 # Restore stderr
225 _restoreStdErr();
226
227 # Store thumbprint
228 #XXX: convert base64 to base64 url
229 $self->{account}{thumbprint} = (sha256_base64(encode_json($self->{account}{jwk}{jwk})) =~ s/=+\z//r) =~ tr[+/][-_]r;
230 }
231
232 # Generate certificate request
233 sub genCsr {
234 my ($self) = @_;
235
236 # Openssl config template
237 my $oct = File::Temp->new();
238
239 # Load template from data
240 map { s/__EMAIL_ADDRESS__/$self->{mail}/; s/__COMMON_NAME__/$self->{domains}[0]/; print $oct $_; } <DATA>;
241
242 # Close data
243 close(DATA);
244
245 # Append domain names
246 my $i = 1;
247 map { print $oct 'DNS.'.$i++.' = '.$_."\n"; } @{$self->{domains}};
248
249 # Generate csr
250 capturex('openssl', ('req', '-new', '-outform', 'DER', '-key', KEY_DIR.DS.SERVER_KEY, '-config', $oct->filename, '-out', CERT_DIR.DS.REQUEST_CSR));
251
252 # Close oct
253 close($oct);
254 }
255
256 # Directory call
257 sub directory {
258 my ($self) = @_;
259
260 # Set time
261 my $time = time;
262
263 # Create a request
264 my $req = HTTP::Request->new(GET => ACME_DIR.'?'.$time);
265
266 # Get request
267 my $res = $ua->request($req);
268
269 # Handle error
270 unless ($res->is_success) {
271 confess 'GET '.ACME_DIR.'?'.$time.' failed: '.$res->status_line;
272 }
273
274 # Save nonce
275 $self->{nonce} = $res->headers->{'replay-nonce'};
276
277 # Merge uris in self content
278 %$self = (%$self, %{decode_json($res->content)});
279 }
280
281 # Post request
282 sub _post {
283 my ($self, $uri, $payload) = @_;
284
285 # Protected field
286 my $protected = encode_base64url(encode_json({nonce => $self->{nonce}}));
287
288 # Payload field
289 $payload = encode_base64url(encode_json($payload));
290
291 # Sign temp file
292 my $stf = File::Temp->new();
293
294 # Append protect.payload to stf
295 print $stf $protected.'.'.$payload;
296
297 # Close stf
298 close($stf);
299
300 # Generate digest of stf
301 my $signature = encode_base64url(join('', capturex('openssl', ('dgst', '-sha256', '-binary', '-sign', KEY_DIR.DS.ACCOUNT_KEY, $stf->filename))) =~ s/^\0+//r);
302
303 # Create a request
304 my $req = HTTP::Request->new(POST => $uri);
305
306 # Set new-reg request content
307 $req->content(encode_json({
308 header => $self->{account}{jwk},
309 protected => $protected,
310 payload => $payload,
311 signature => $signature
312 }));
313
314 # Post request
315 my $res = $ua->request($req);
316
317 # Save nonce
318 if (defined $res->headers->{'replay-nonce'}) {
319 $self->{nonce} = $res->headers->{'replay-nonce'};
320 }
321
322 # Return res object
323 return $res;
324 }
325
326 # Get uri and check content
327 sub _httpCheck {
328 my ($self, $uri, $content) = @_;
329
330 # Create a request
331 my $req = HTTP::Request->new(GET => $uri);
332
333 # Get request
334 my $res = $ua->request($req);
335
336 # Handle error
337 unless ($res->is_success) {
338 carp 'GET '.$uri.' failed: '.$res->status_line if ($_debug);
339 return;
340 }
341
342 # Handle invalid content
343 unless($res->content =~ /^$content\s*$/) {
344 carp 'GET '.$uri.' content match failed: /^'.$content.'\s*$/ !~ '.$res->content if ($_debug);
345 return;
346 }
347
348 # Return success
349 return 1;
350 }
351
352 # Register account
353 #XXX: see doc at https://ietf-wg-acme.github.io/acme/#rfc.section.6.3
354 sub register {
355 my ($self) = @_;
356
357 # Post new-reg request
358 #XXX: contact array may contain a tel:+33612345678 for example
359 my $res = $self->_post($self->{'new-reg'}, {resource => 'new-reg', contact => ['mailto:'.$self->{mail}], agreement => ACME_TERMS});
360
361 # Handle error
362 unless ($res->is_success || $res->code eq 409) {
363 confess 'POST '.$self->{'new-reg'}.' failed: '.$res->status_line;
364 }
365
366 # Update mail informations
367 if ($res->code eq 409) {
368 # Save registration uri
369 $self->{'reg'} = $res->headers->{location};
370
371 # Post reg request
372 #XXX: contact array may contain a tel:+33612345678 for example
373 $res = $self->_post($self->{'reg'}, {resource => 'reg', contact => ['mailto:'.$self->{mail}]});
374
375 # Handle error
376 unless ($res->is_success) {
377 confess 'POST '.$self->{'reg'}.' failed: '.$res->status_line;
378 }
379 }
380 }
381
382 # Authorize domains
383 #TODO: implement combinations check one day
384 sub authorize {
385 my ($self) = @_;
386
387 # Create challenges hash
388 %{$self->{challenges}} = ();
389
390 # Pending list
391 my @pending = ();
392
393 # Create request for each domain
394 map {
395 # Init content
396 my $content = undef;
397
398 # Init file
399 my $file = PENDING_DIR.'/'.$self->{mail}.'/'.$_;
400
401 # Load in content domain data or post a new authz request
402 #TODO: add check on cache file ???
403 if (
404 #XXX: use eval to workaround a fatal in decode_json
405 ! defined eval {
406 # Check that file exists
407 -f $file &&
408 # Read it
409 ($content = read_file($file)) &&
410 # Decode it
411 ($content = decode_json($content)) &&
412 # Check expiration
413 (DateTime->from_epoch(epoch => str2time($content->{expires})) >= DateTime->now()->add(hours => 1))
414 }
415 ) {
416 # Post new-authz request
417 my $res = $self->_post($self->{'new-authz'}, {resource => 'new-authz', identifier => {type => 'dns', value => $_}, existing => 'accept'});
418
419 # Handle error
420 unless ($res->is_success) {
421 confess 'POST '.$self->{'new-authz'}.' for '.$_.' failed: '.$res->status_line;
422 }
423
424 # Decode content
425 $content = decode_json($res->content);
426
427 # Check domain
428 unless (defined $content->{identifier}{value} && $content->{identifier}{value} eq $_) {
429 confess 'domain matching '.$content->{identifier}{value}.' for '.$_.' failed: '.$res->status_line;
430 }
431
432 # Check status
433 unless ($content->{status} eq 'valid' or $content->{status} eq 'pending') {
434 confess 'POST '.$self->{'new-authz'}.' for '.$_.' failed: '.$res->status_line;
435 }
436
437 # Write to file
438 write_file($file, encode_json($content));
439 }
440
441 # Add challenge
442 %{$self->{challenges}{$_}} = (
443 status => undef,
444 expires => undef,
445 dns_uri => undef,
446 dns_token => undef,
447 http_uri => undef,
448 http_token => undef,
449 http_challenge => undef
450 );
451
452 # Save status
453 $self->{challenges}{$_}{status} = $content->{status};
454
455 # Save pending data
456 if ($content->{status} eq 'pending') {
457 #XXX: debug
458 print Dumper($content);
459
460 # Exctract validation data
461 foreach my $challenge (@{$content->{challenges}}) {
462 if ($challenge->{type} eq 'http-01') {
463 $self->{challenges}{$_}{http_uri} = $challenge->{uri};
464 $self->{challenges}{$_}{http_token} = $challenge->{token};
465 } elsif ($challenge->{type} eq 'dns-01') {
466 $self->{challenges}{$_}{dns_uri} = $challenge->{uri};
467 $self->{challenges}{$_}{dns_token} = $challenge->{token};
468 }
469 }
470
471 # Check dns challenge
472 #XXX: disabled for now
473 #$self->_dnsCheck('_acme-challenge.'.$_.'.', $self->{challenges}{$_}{http_token}.'.'.$self->{account}{thumbprint});
474
475 # Check http challenge
476 # if ($self->_httpCheck(
477 # # Well known uri
478 # 'http://'.$_.'/.well-known/acme-challenge/'.$self->{challenges}{$_}{http_token},
479 # # token.thumbprint
480 # $self->{challenges}{$_}{http_token}.'.'.$self->{account}{thumbprint}
481 # )) {
482 # # Post challenge request
483 # my $res = $self->_post($self->{challenges}{$_}{http_uri}, {resource => 'challenge', keyAuthorization => $self->{challenges}{$_}{http_token}.'.'.$self->{account}{thumbprint}});
484 #
485 # # Handle error
486 # unless ($res->is_success) {
487 # confess 'POST '.$self->{challenges}{$_}{http_uri}.' failed: '.$res->status_line;
488 # }
489 #
490 # # Extract content
491 # my $content = decode_json($res->content);
492 #
493 # # Save status
494 # $self->{challenges}{$_}{status} = $content->{status};
495 #
496 # # Add challenge uri to poll
497 # #XXX: in case it is still pending
498 # if ($content->{status} eq 'pending') {
499 # $self->{challenges}{$_}{http_challenge} = $content->{uri};
500 # }
501 # } else {
502 # # Set failed status
503 # $self->{challenges}{$_}{status} = 'invalid';
504 #
505 # # Display challenge to fix
506 # print STDERR 'Makes http://'.$_.'/.well-known/acme-challenge/'.$self->{challenges}{$_}{http_token}.' return '.$self->{challenges}{$_}{http_token}.'.'.$self->{account}{thumbprint}."\n";
507 # }
508 }
509 } @{$self->{domains}};
510
511 #XXX: debug
512 exit EXIT_FAILURE;
513
514 # Poll pending
515 while (scalar map { $_->{status} eq 'pending' ? 1 : (); } values %{$self->{challenges}}) {
516 # Sleep
517 sleep(1);
518 # Poll remaining pending
519 map {
520 # Create a request
521 my $req = HTTP::Request->new(GET => $self->{challenges}{$_}{http_challenge});
522
523 # Get request
524 my $res = $ua->request($req);
525
526 # Handle error
527 unless ($res->is_success) {
528 carp 'GET '.$self->{challenges}{$_}{http_challenge}.' failed: '.$res->status_line if ($_debug);
529 }
530
531 # Extract content
532 my $content = decode_json($res->content);
533
534 # Save status
535 $self->{challenges}{$_}{status} = $content->{status};
536 } map { $self->{challenges}{$_}{status} eq 'pending' ? $_ : (); } keys %{$self->{challenges}};
537 }
538
539 # Stop here with remaining chanllenge
540 if (scalar map { ! defined $_->{status} or $_->{status} ne 'valid' ? 1 : (); } values %{$self->{challenges}}) {
541 # Deactivate all activated domains
542 #XXX: not implemented by letsencrypt
543 #map {
544 # # Post deactivation request
545 # my $res = $self->_post($self->{challenges}{$_}{http_uri}, {resource => 'authz', status => 'deactivated'});
546 # # Handle error
547 # unless ($res->is_success) {
548 # print Dumper($res);
549 # confess 'POST '.$self->{challenges}{$_}{http_uri}.' failed: '.$res->status_line;
550 # }
551 #} map { $self->{challenges}{$_}{status} eq 'valid' ? $_ : () } keys %{$self->{challenges}};
552
553 # Stop here as a domain of csr list failed authorization
554 if ($_debug) {
555 confess 'Fix the challenges for domains: '.join(', ', map { ! defined $self->{challenges}{$_}{status} or $self->{challenges}{$_}{status} ne 'valid' ? $_ : (); } keys %{$self->{challenges}});
556 } else {
557 exit EXIT_FAILURE;
558 }
559 }
560 }
561
562 # Issue certificate
563 sub issue {
564 my ($self) = @_;
565
566 # Open csr file
567 open(my $fh, '<', CERT_DIR.DS.REQUEST_CSR) or die $!;
568
569 # Load csr
570 my $csr = encode_base64url(join('', <$fh>) =~ s/^\0+//r);
571
572 # Close csr file
573 close($fh) or die $!;
574
575 # Post certificate request
576 my $res = $self->_post($self->{'new-cert'}, {resource => 'new-cert', csr => $csr});
577
578 # Handle error
579 unless ($res->is_success) {
580 print Dumper($res);
581 confess 'POST '.$self->{'new-cert'}.' failed: '.$res->status_line;
582 }
583
584 # Open crt file
585 open($fh, '>', CERT_DIR.DS.SERVER_CRT) or die $!;
586 # Convert to pem
587 print $fh '-----BEGIN CERTIFICATE-----'."\n".encode_base64($res->content).'-----END CERTIFICATE-----'."\n";
588 #TODO: merge https://letsencrypt.org/certs/lets-encrypt-x3-cross-signed.pem here
589 # Close file
590 close($fh) or die $!;
591
592 # Print success
593 carp 'Success, pem certificate in '.CERT_DIR.DS.SERVER_CRT if ($_debug);
594 }
595
596 # Resolve dns and check content
597 #XXX: this can't work without a plugin in dns to generate signature from token.thumbprint and store it in zone
598 #XXX: each identifier authorisation generate a new token, it's not possible to do a yescard answer
599 #XXX: the digest can be bigger than 255 TXT record limit and well known dns server will randomize TXT record order
600 #
601 #XXX: conclusion disabled for now
602 sub _dnsCheck {
603 my ($self, $domain, $content) = @_;
604
605 # Sign temp file
606 my $stf = File::Temp->new();
607
608 # Append protect.payload to stf
609 print $stf $content;
610
611 # Close stf
612 close($stf);
613
614 # Generate digest of stf
615 my $signature = encode_base64url(join('', capturex('openssl', ('dgst', '-sha256', '-binary', '-sign', KEY_DIR.DS.ACCOUNT_KEY, $stf->filename))));
616
617 # Create resolver
618 my $res = new Net::DNS::Resolver();
619
620 # Check if we get dns answer
621 unless(my $rep = $res->search($domain, 'TXT')) {
622 carp 'search TXT record for '.$domain.' failed' if ($_debug);
623 return;
624 } else {
625 unless (scalar map { $_->type eq 'TXT' && $_->txtdata =~ /^$signature$/ ? 1 : (); } $rep->answer) {
626 carp 'search recursively TXT record for '.$_.' failed' if ($_debug);
627 return;
628 }
629 }
630
631 return 1;
632 }
633
634 1;
635
636 __DATA__
637 #
638 # OpenSSL configuration file.
639 # This is mostly being used for generation of certificate requests.
640 #
641
642 [ req ]
643 default_bits = 2048
644 default_md = sha256
645 prompt = no
646 distinguished_name = req_distinguished_name
647 # The extentions to add to the self signed cert
648 x509_extensions = v3_ca
649 # The extensions to add to a certificate request
650 req_extensions = v3_req
651
652 # This sets a mask for permitted string types. There are several options.
653 # utf8only: only UTF8Strings (PKIX recommendation after 2004).
654 # WARNING: ancient versions of Netscape crash on BMPStrings or UTF8Strings.
655 string_mask = utf8only
656
657 [ req_distinguished_name ]
658 countryName = US
659 stateOrProvinceName = State or Province Name
660 localityName = Locality Name
661 organizationName = Organization Name
662 organizationalUnitName = Organizational Unit Name
663 commonName = __COMMON_NAME__
664 emailAddress = __EMAIL_ADDRESS__
665
666 [ v3_req ]
667 basicConstraints = CA:false
668 keyUsage = nonRepudiation, digitalSignature, keyEncipherment
669 subjectAltName = email:move
670 subjectAltName = @alt_names
671
672 [ v3_ca ]
673 subjectKeyIdentifier = hash
674 authorityKeyIdentifier = keyid:always,issuer
675 basicConstraints = CA:true
676
677 [alt_names]