]>
Raphaƫl G. Git Repositories - acme/blob - acme.pm
10 our @ISA = qw(Exporter) ;
13 use Carp
qw(carp confess) ;
14 use Date
:: Parse
qw(str2time) ;
16 use Digest
:: SHA
qw(sha256_base64) ;
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) ;
24 use MIME
:: Base64
qw(encode_base64url encode_base64) ;
27 use POSIX
qw(EXIT_FAILURE) ;
30 #XXX: see https://letsencrypt.github.io/acme-spec/ (probably based on https://ietf-wg-acme.github.io/acme/)
31 #XXX: see jwk rfc http://www.rfc-editor.org/rfc/rfc7517.txt
32 #XXX: see javascript implementation https://github.com/diafygi/gethttpsforfree/blob/gh-pages/js/index.js
39 # Directory for certificates
45 # Directory for pending cache
46 PENDING_DIR
=> 'pending' ,
48 # Request certificate file name
49 REQUEST_CSR
=> 'request.der' ,
51 # Account key file name
52 ACCOUNT_KEY
=> 'account.pem' ,
55 SERVER_KEY
=> 'server.pem' ,
57 # Server public certificate
58 SERVER_CRT
=> 'server.crt' ,
67 ACME_CERT
=> 'https://letsencrypt.org/certs/lets-encrypt-x3-cross-signed.pem' ,
68 ACME_DIR
=> 'https://acme-staging.api.letsencrypt.org/directory' ,
69 ACME_PROD_DIR
=> 'https://acme-v01.api.letsencrypt.org/directory' ,
70 ACME_TERMS
=> 'https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf' ,
76 CONFIG
=> '/etc/acmepl/config'
86 #XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
95 # kty => uc(KEY_TYPE),
100 # thumbprint => undef
102 tie
( our %jwk , 'Tie::IxHash' , pubkey
=> undef , jwk
=> undef , thumbprint
=> undef );
103 tie
(%{ $jwk { jwk
}}, 'Tie::IxHash' , alg
=> 'RS256' , jwk
=> undef );
104 #XXX: strict ordering only really needed here for thumbprint sha256 digest
105 tie
(%{ $jwk { jwk
}{ jwk
}}, 'Tie::IxHash' , e
=> undef , kty
=> uc ( KEY_TYPE
), n
=> undef );
110 my ( $class , $mail , $debug , $prod , @domains ) = @_ ;
115 # Link self to package
116 bless ( $self , $class );
119 $self ->{ debug
} = $debug ;
122 $self ->{ prod
} = $prod ;
124 # Add extra check to mail validity
125 #XXX: mxcheck fail if there is only a A record on the domain
126 my $ev = Email
:: Valid-
> new (- fqdn
=> 1 , - tldcheck
=> 1 , - mxcheck
=> 1 );
128 # Show error if check fail
129 if (! defined $ev -> address ( $mail )) {
130 map { carp
'failed check: ' . $_ if ( $self ->{ debug
}) } $ev -> details ();
131 confess
'Email::Valid->address failed' ;
135 $self ->{ mail
} = $mail ;
138 my $res = new Net
:: DNS
:: Resolver
();
145 unless (( $tld ) = $_ =~ m/\.(\w+)$/ ) {
146 confess
$_ . ' \' s tld extraction failed' ;
149 # Check if tld exists
150 unless ( Net
:: Domain
:: TLD
:: tld_exists
( $tld )) {
151 confess
$tld . ' tld from ' . $_ . ' don \' t exists' ;
154 # Check if we get dns answer
155 #XXX: only search A type because letsencrypt don't support ipv6 (AAAA) yet
156 unless ( my $rep = $res -> search ( $_ , 'A' )) {
157 confess
'search A record for ' . $_ . ' failed' ;
159 unless ( scalar map { $_ -> type eq 'A' ? 1 : (); } $rep -> answer ) {
160 confess
'search recursively A record for ' . $_ . ' failed' ;
166 @{ $self ->{ domains
}} = @domains ;
168 # Return class reference
172 # Prepare environement
177 make_path
( CERT_DIR
, KEY_DIR
, PENDING_DIR
. '/' . $self ->{ mail
}. '.' .( $self ->{ prod
} ? 'prod' : 'staging' ), { error
=> \
my $err });
180 my ( $file , $msg ) = %$_ ;
181 carp
( $file eq '' ? '' : $file . ': ' ). $msg if ( $self ->{ debug
});
183 confess
'make_path failed' ;
187 $ua = LWP
:: UserAgent-
> new ;
188 $ua -> agent ( __PACKAGE__
. '/' . VERSION
)
194 open ( $_stderr , '>&STDERR' ) or die $! ;
196 close ( STDERR
) or die $! ;
198 open ( STDERR
, '>' , '/dev/null' ) or die $! ;
206 open ( STDERR
, '>&' , $_stderr ) or die $! ;
209 # Generate required keys
213 # Generate account and server key if required
215 # Check key existence
220 #XXX: we drop stderr here because openssl can't be quiet on this command
221 capturex
( 'openssl' , ( 'genrsa' , '-out' , $_ , KEY_SIZE
));
225 } ( KEY_DIR
. DS
. ACCOUNT_KEY
, KEY_DIR
. DS
. SERVER_KEY
);
227 # Extract modulus and publicExponent jwk
228 #XXX: same here we tie to keep ordering
229 tie
(%{ $self ->{ account
}}, 'Tie::IxHash' , %jwk );
231 if ( /^Modulus=([0-9A-F]+)$/ ) {
232 # Extract to binary from hex and convert to base64 url
233 $self ->{ account
}{ jwk
}{ jwk
}{ n
} = encode_base64url
( pack ( "H*" , $1 ) =~ s/^\0+//r );
234 } elsif ( /^publicExponent:\s([0-9]+)\s\(0x[0-1]+\)$/ ) {
235 # Extract to binary from int, trim leading zeros and convert to base64 url
236 chomp ( $self ->{ account
}{ jwk
}{ jwk
}{ e
} = encode_base64url
( pack ( "N" , $1 ) =~ s/^\0+//r ));
238 } capturex
( 'openssl' , ( 'rsa' , '-text' , '-in' , KEY_DIR
. DS
. ACCOUNT_KEY
, '-noout' , '-modulus' ));
242 # Extract account public key
243 $self ->{ account
}{ pubkey
} = join ( '' , map { chomp ; $_ ; } capturex
( 'openssl' , ( 'rsa' , '-in' , KEY_DIR
. DS
. ACCOUNT_KEY
, '-pubout' )));
248 #XXX: convert base64 to base64 url
249 $self ->{ account
}{ thumbprint
} = ( sha256_base64
( encode_json
( $self ->{ account
}{ jwk
}{ jwk
})) =~ s/=+\z//r ) =~ tr
[+/][- _
] r
;
252 # Generate certificate request
256 # Openssl config template
257 my $oct = File
:: Temp-
> new ();
259 # Load template from data
260 map { s/__EMAIL_ADDRESS__/$self->{mail}/ ; s/__COMMON_NAME__/$self->{domains}[0]/ ; print $oct $_ ; } < DATA
>;
265 # Append domain names
267 map { print $oct 'DNS.' . $i++ . ' = ' . $_ . " \n " ; } @{ $self ->{ domains
}};
270 capturex
( 'openssl' , ( 'req' , '-new' , '-outform' , 'DER' , '-key' , KEY_DIR
. DS
. SERVER_KEY
, '-config' , $oct -> filename , '-out' , CERT_DIR
. DS
. REQUEST_CSR
));
284 my $dir = $self ->{ prod
} ? ACME_PROD_DIR
: ACME_DIR
;
287 my $req = HTTP
:: Request-
> new ( GET
=> $dir . '?' . $time );
290 my $res = $ua -> request ( $req );
293 unless ( $res -> is_success ) {
294 confess
'GET ' . $dir . '?' . $time . ' failed: ' . $res -> status_line ;
298 $self ->{ nonce
} = $res -> headers ->{ 'replay-nonce' };
300 # Merge uris in self content
301 %$self = ( %$self , %{ decode_json
( $res -> content )});
306 my ( $self , $uri , $payload ) = @_ ;
309 my $protected = encode_base64url
( encode_json
({ nonce
=> $self ->{ nonce
}}));
312 $payload = encode_base64url
( encode_json
( $payload ));
315 my $stf = File
:: Temp-
> new ();
317 # Append protect.payload to stf
318 print $stf $protected . '.' . $payload ;
323 # Generate digest of stf
324 my $signature = encode_base64url
( join ( '' , capturex
( 'openssl' , ( 'dgst' , '-sha256' , '-binary' , '-sign' , KEY_DIR
. DS
. ACCOUNT_KEY
, $stf -> filename ))) =~ s/^\0+//r );
327 my $req = HTTP
:: Request-
> new ( POST
=> $uri );
329 # Set new-reg request content
330 $req -> content ( encode_json
({
331 header
=> $self ->{ account
}{ jwk
},
332 protected
=> $protected ,
334 signature
=> $signature
338 my $res = $ua -> request ( $req );
341 if ( defined $res -> headers ->{ 'replay-nonce' }) {
342 $self ->{ nonce
} = $res -> headers ->{ 'replay-nonce' };
349 # Resolve dns and check content
350 #XXX: see https://community.centminmod.com/threads/looks-like-letsencrypt-dns-01-is-ready.5845/#12 for example
352 my ( $self , $domain , $token ) = @_ ;
354 # Generate signature from content
355 my $signature = (( sha256_base64
( $token . '.' . $self ->{ account
}{ thumbprint
})) =~ s/=+\z//r ) =~ tr
[+/][- _
] r
;
358 $domain = '_acme-challenge.' . $domain . '.' ;
361 my $res = new Net
:: DNS
:: Resolver
();
363 # Check if we get dns answer
364 unless ( my $rep = $res -> search ( $domain , 'TXT' )) {
365 carp
'TXT record search for ' . $domain . ' failed' if ( $self ->{ debug
});
368 unless ( scalar map { $_ -> type eq 'TXT' && $_ -> txtdata =~ /^$signature$/ ? 1 : (); } $rep -> answer ) {
369 carp
'TXT record recursive search for ' . $domain . ' failed' if ( $self ->{ debug
});
377 # Get uri and check content
379 my ( $self , $domain , $token ) = @_ ;
382 my $req = HTTP
:: Request-
> new ( GET
=> 'http://' . $domain . '/.well-known/acme-challenge/' . $token );
384 # Load config if available
387 #XXX: use eval to workaround a fatal in decode_json
389 # Check that file exists
392 ( $config = read_file
( CONFIG
)) &&
394 ( $config = decode_json
( $config )) &&
396 $config ->{ thumbprint
}
399 # Try to write thumbprint
400 write_file
( $config ->{ thumbprint
}, $self ->{ account
}{ thumbprint
});
404 my $res = $ua -> request ( $req );
407 unless ( $res -> is_success ) {
408 carp
'GET http://' . $domain . '/.well-known/acme-challenge/' . $token . ' failed: ' . $res -> status_line if ( $self ->{ debug
});
412 # Handle invalid content
413 unless ( $res -> content =~ /^$token.$self->{account}{thumbprint}\s*$/ ) {
414 carp
'GET http://' . $domain . '/.well-known/acme-challenge/' . $token . ' content match failed: /^' . $token . '.' . $self ->{ account
}{ thumbprint
}. '\s* $/ !~ ' . $res -> content if ( $self ->{ debug
});
423 #XXX: see doc at https://ietf-wg-acme.github.io/acme/#rfc.section.6.3
427 # Post new-reg request
428 #XXX: contact array may contain a tel:+33612345678 for example
429 my $res = $self -> _post ( $self ->{ 'new-reg' }, { resource
=> 'new-reg' , contact
=> [ 'mailto:' . $self ->{ mail
}], agreement
=> ACME_TERMS
});
432 unless ( $res -> is_success || $res -> code eq 409 ) {
433 confess
'POST ' . $self ->{ 'new-reg' }. ' failed: ' . $res -> status_line ;
436 # Update mail informations
437 if ( $res -> code eq 409 ) {
438 # Save registration uri
439 $self ->{ 'reg' } = $res -> headers ->{ location
};
442 #XXX: contact array may contain a tel:+33612345678 for example
443 $res = $self -> _post ( $self ->{ 'reg' }, { resource
=> 'reg' , contact
=> [ 'mailto:' . $self ->{ mail
}]});
446 unless ( $res -> is_success ) {
447 confess
'POST ' . $self ->{ 'reg' }. ' failed: ' . $res -> status_line ;
456 # Create challenges hash
457 %{ $self ->{ challenges
}} = ();
462 # Create or load auth request for each domain
468 my $file = PENDING_DIR
. '/' . $self ->{ mail
}. '.' .( $self ->{ prod
} ? 'prod' : 'staging' ). '/' . $_ ;
470 # Load auth request content or post a new one
471 #TODO: add more check on cache file ???
473 #XXX: use eval to workaround a fatal in decode_json
475 # Check that file exists
478 ( $content = read_file
( $file )) &&
480 ( $content = decode_json
( $content )) &&
482 ( DateTime-
> from_epoch ( epoch
=> str2time
( $content ->{ expires
})) >= DateTime-
> now ()-> add ( hours
=> 1 ))
485 # Post new-authz request
486 my $res = $self -> _post ( $self ->{ 'new-authz' }, { resource
=> 'new-authz' , identifier
=> { type
=> 'dns' , value
=> $_ }, existing
=> 'accept' });
489 unless ( $res -> is_success ) {
490 confess
'POST ' . $self ->{ 'new-authz' }. ' for ' . $_ . ' failed: ' . $res -> status_line ;
494 $content = decode_json
( $res -> content );
497 unless ( defined $content ->{ identifier
}{ value
} && $content ->{ identifier
}{ value
} eq $_ ) {
498 confess
'domain matching ' . $content ->{ identifier
}{ value
}. ' for ' . $_ . ' failed: ' . $res -> status_line ;
502 unless ( $content ->{ status
} eq 'valid' or $content ->{ status
} eq 'pending' ) {
503 confess
'POST ' . $self ->{ 'new-authz' }. ' for ' . $_ . ' failed: ' . $res -> status_line ;
507 write_file
( $file , encode_json
( $content ));
511 %{ $self ->{ challenges
}{ $_ }} = (
512 status
=> $content ->{ status
},
513 expires
=> $content ->{ expires
},
518 if ( $content ->{ status
} eq 'pending' ) {
519 # Extract validation data
520 foreach my $challenge (@{ $content ->{ challenges
}}) {
521 # One test already validated this auth request
522 if ( $self ->{ challenges
}{ $_ }{ status
} eq 'valid' ) {
524 } elsif ( $challenge ->{ status
} eq 'valid' ) {
525 $self ->{ challenges
}{ $_ }{ status
} = $challenge ->{ status
};
527 } elsif ( $challenge ->{ status
} eq 'pending' ) {
530 ( $challenge ->{ type
} =~ /^http-01$/ and $self -> _httpCheck ( $_ , $challenge ->{ token
})) or
531 ( $challenge ->{ type
} =~ /^dns-01$/ and $self -> _dnsCheck ( $_ , $challenge ->{ token
}))
533 # Post challenge request
534 my $res = $self -> _post ( $challenge ->{ uri
}, { resource
=> 'challenge' , keyAuthorization
=> $challenge ->{ token
}. '.' . $self ->{ account
}{ thumbprint
}});
537 unless ( $res -> is_success ) {
538 confess
'POST ' . $challenge ->{ uri
}. ' failed: ' . $res -> status_line ;
542 my $content = decode_json
( $res -> content );
545 if ( $content ->{ status
} eq 'valid' ) {
546 $self ->{ challenges
}{ $_ }{ status
} = $content ->{ status
};
547 # Check is still polling
548 } elsif ( $content ->{ status
} eq 'pending' ) {
549 # Add to poll list for later use
550 push (@{ $self ->{ challenges
}{ $_ }{ polls
}}, {
551 type
=> ( split ( /-/ , $challenge ->{ type
}))[ 0 ],
552 status
=> $content ->{ status
},
553 poll
=> $content ->{ uri
}
559 # Check if check is challenge still in pending and no polls
560 if ( $self ->{ challenges
}{ $_ }{ status
} eq 'pending' && scalar @{ $self ->{ challenges
}{ $_ }{ polls
}} == 0 ) {
561 # Loop on all remaining challenges
562 foreach my $challenge (@{ $content ->{ challenges
}}) {
563 # Display help for http-01 check
564 if ( $challenge ->{ type
} eq 'http-01' ) {
565 print STDERR
'Create URI http://' . $_ . '/.well-known/acme-challenge/' . $challenge ->{ token
}. ' with content ' . $challenge ->{ token
}. '.' . $self ->{ account
}{ thumbprint
}. " \n " ;
566 # Display help for dns-01 check
567 } elsif ( $challenge ->{ type
} eq 'dns-01' ) {
568 print STDERR
'Create TXT record _acme-challenge.' . $_ . '. with value ' .((( sha256_base64
( $challenge ->{ token
}. '.' . $self ->{ account
}{ thumbprint
})) =~ s/=+\z//r ) =~ tr
[+/][- _
] r
). " \n " ;
573 } @{ $self ->{ domains
}};
579 while (-- $remaining >= 0 and scalar map { $_ ->{ status
} eq 'valid' ? 1 : (); } values %{ $self ->{ challenges
}}) {
582 # Poll remaining pending
587 # Poll remaining polls
590 my $req = HTTP
:: Request-
> new ( GET
=> $_ ->{ poll
});
593 my $res = $ua -> request ( $req );
596 unless ( $res -> is_success ) {
597 carp
'GET ' . $self ->{ challenges
}{ $_ }{ http_challenge
}. ' failed: ' . $res -> status_line if ( $self ->{ debug
});
601 my $content = decode_json
( $res -> content );
604 if ( $content ->{ status
} ne 'pending' ) {
605 $self ->{ challenges
}{ $domain }{ status
} = $content ->{ status
};
607 } @{ $self ->{ challenges
}{ $_ }{ polls
}};
608 } map { $self ->{ challenges
}{ $_ }{ status
} eq 'pending' ? $_ : (); } keys %{ $self ->{ challenges
}};
611 # Load config if available
614 #XXX: use eval to workaround a fatal in decode_json
616 # Check that file exists
619 ( $config = read_file
( CONFIG
)) &&
621 ( $config = decode_json
( $config )) &&
623 $config ->{ thumbprint
}
626 # Try to write thumbprint
627 write_file
( $config ->{ thumbprint
}, '' );
630 # Stop here with remaining chanllenge
631 if ( scalar map { ! defined $_ ->{ status
} or $_ ->{ status
} ne 'valid' ? 1 : (); } values %{ $self ->{ challenges
}}) {
632 # Deactivate all activated domains
633 #XXX: not implemented by letsencrypt
635 # # Post deactivation request
636 # my $res = $self->_post($self->{challenges}{$_}{http_uri}, {resource => 'authz', status => 'deactivated'});
638 # unless ($res->is_success) {
639 # print Dumper($res);
640 # confess 'POST '.$self->{challenges}{$_}{http_uri}.' failed: '.$res->status_line;
642 #} map { $self->{challenges}{$_}{status} eq 'valid' ? $_ : () } keys %{$self->{challenges}};
644 # Stop here as a domain of csr list failed authorization
645 if ( $self ->{ debug
}) {
646 my @domains = map { ! defined $self ->{ challenges
}{ $_ }{ status
} or $self ->{ challenges
}{ $_ }{ status
} ne 'valid' ? $_ : (); } keys %{ $self ->{ challenges
}};
647 confess
'Fix the challenge' .( scalar @domains > 1 ? 's' : '' ). ' for domain' .( scalar @domains > 1 ? 's' : '' ). ': ' . join ( ', ' , @domains );
659 open ( my $fh , '<' , CERT_DIR
. DS
. REQUEST_CSR
) or die $! ;
662 my $csr = encode_base64url
( join ( '' , < $fh >) =~ s/^\0+//r );
665 close ( $fh ) or die $! ;
667 # Post certificate request
668 my $res = $self -> _post ( $self ->{ 'new-cert' }, { resource
=> 'new-cert' , csr
=> $csr });
671 unless ( $res -> is_success ) {
672 confess
'POST ' . $self ->{ 'new-cert' }. ' failed: ' . $res -> status_line ;
676 open ( $fh , '>' , CERT_DIR
. DS
. SERVER_CRT
) or die $! ;
679 print $fh '-----BEGIN CERTIFICATE-----' . " \n " . encode_base64
( $res -> content ). '-----END CERTIFICATE-----' . " \n " ;
682 my $req = HTTP
:: Request-
> new ( GET
=> ACME_CERT
);
685 $res = $ua -> request ( $req );
688 unless ( $res -> is_success ) {
689 carp
'GET ' . ACME_CERT
. ' failed: ' . $res -> status_line if ( $self ->{ debug
});
693 print $fh $res -> content ;
696 close ( $fh ) or die $! ;
699 carp
'Success, pem certificate in ' . CERT_DIR
. DS
. SERVER_CRT
if ( $self ->{ debug
});
706 # OpenSSL configuration file.
707 # This is mostly being used for generation of certificate requests.
714 distinguished_name
= req_distinguished_name
715 # The extentions to add to the self signed cert
716 x509_extensions
= v3_ca
717 # The extensions to add to a certificate request
718 req_extensions
= v3_req
720 # This sets a mask for permitted string types. There are several options.
721 # utf8only: only UTF8Strings (PKIX recommendation after 2004).
722 # WARNING: ancient versions of Netscape crash on BMPStrings or UTF8Strings.
723 string_mask
= utf8only
725 [ req_distinguished_name
]
727 stateOrProvinceName
= State
or Province Name
728 localityName
= Locality Name
729 organizationName
= Organization Name
730 organizationalUnitName
= Organizational Unit Name
731 commonName
= __COMMON_NAME__
732 emailAddress
= __EMAIL_ADDRESS__
735 basicConstraints
= CA
: false
736 keyUsage
= nonRepudiation
, digitalSignature
, keyEncipherment
737 subjectAltName
= email
: move
738 subjectAltName
= @alt_names
741 subjectKeyIdentifier
= hash
742 authorityKeyIdentifier
= keyid
: always
, issuer
743 basicConstraints
= CA
: true