File Coverage

blib/lib/Protocol/ACME.pm
Criterion Covered Total %
statement 191 336 56.8
branch 51 122 41.8
condition 4 10 40.0
subroutine 29 40 72.5
pod 14 15 93.3
total 289 523 55.2


line stmt bran cond sub pod time code
1             package Protocol::ACME;
2              
3 6     6   236665 use 5.007003;
  6         19  
4 6     6   27 use strict;
  6         7  
  6         107  
5 6     6   19 use warnings;
  6         9  
  6         537  
6              
7              
8             our $VERSION = '0.16';
9              
10             =head1 NAME
11              
12             Protocol::ACME - Interface to the Let's Encrypt ACME API
13              
14             =head1 VERSION
15              
16             Version 0.16
17              
18             =head1 SYNOPSIS
19              
20             use Protocol::ACME;
21              
22             my @names = qw( www.example.com cloud.example.com );
23              
24             my $challenges = {
25             'www.example.com' => Protocol::ACME::Challenge::SimpleSSH->new(
26             { ssh_host => "host1", www_root => "~/www" }
27             ),
28             'cloud.example.com' => Protocol::ACME::Challenge::SimpleSSH->new(
29             { ssh_host => "home2", www_root => "/opt/local/www/htdocs" }
30             )
31             };
32              
33             eval
34             {
35             my $acme = Protocol::ACME->new( host => $host,
36             account_key => $account_key_pem_or_der,
37             );
38              
39             $acme->directory();
40             $acme->register();
41             $acme->accept_tos();
42              
43             for my $domain ( @names )
44             {
45             $acme->authz( $domain );
46             $acme->handle_challenge( $challenges->{$domain} );
47             $acme->check_challenge();
48             $acme->cleanup_challenge( $challenges->{$domain} );
49             }
50              
51             my $cert = $acme->sign( $csr_file );
52             };
53             if ( $@ )
54             {
55             die if !UNIVERSAL::isa($@, 'Protocol::ACME::Exception');
56             die "Error occurred: Status: $@->{status},
57             Detail: $@->{detail},
58             Type: $@->{type}\n";
59             }
60             else
61             {
62             # do something appropriate with the DER encoded cert
63             print "Success\n";
64             }
65              
66             =head1 DESCRIPTION
67              
68             The C is a class implementing an interface for the
69             Let's Encrypt ACME API.
70              
71             NOTE: This code at this point is functional but should be considered
72             'alpha' quality.
73              
74             The class handles the protocol details behind provisioning a Let's
75             Encrypt certificate.
76              
77             =head1 CONSTRUCTOR METHODS
78              
79             The following constructor methods are available:
80              
81             =over 4
82              
83             =item $acme = Protcol::ACME->new( %options )
84              
85             This method constructs a new C object and returns it.
86             Key/value pair arguments may be provided to set up the initial state.
87             The may be passed in as a hash or a hashref. The following options
88             correspond to attribute methods described below. Items marked with
89             a * are required.
90              
91             KEY DEFAULT
92             ----------- --------------------
93             *host undef
94             account_key undef
95             openssl undef
96             ua HTTP::Tiny->new()
97             loglevel error
98             debug 0
99             mailto undef
100              
101             B: The API end point to connect to. This will generally be acme-staging.api.letsencrypt.org
102             or acme-v01.api.letsencrypt.org
103              
104             B: The account private key in a scalar ref or filename. See C<$self->account_key>
105             for details on this arguemtn.
106              
107             B: The path to openssl. If this option is used a local version of the openssl binary will
108             be used for crypto operations rather than C.
109              
110             B: An HTTP::Tiny object customized as you see fit
111              
112             B: Set the loglevel to one of the C values.
113              
114             B: If set to non-zero this is a shortcut for C debug>
115              
116             B: This should be the email address that you want associated with your account. This is used
117             my Let's Encrypt for expiration notification.
118              
119             =back
120              
121             =head2 METHODS
122              
123             =over
124              
125             =item account_key( $key_filename )
126              
127             =item account_key( \$buffer )
128              
129             =item account_key( \%explicit_args )
130              
131              
132             C will load a the private account key if it was not already loaded
133             when the C object was constructed. There are three ways to call this:
134              
135             If the arg is a B it is assumed to be the filename of the
136             key. C will throw an error if there are problems reading the file.
137              
138             If the arg is a B reference it is assumed to be a buffer that
139             contains the KEY.
140              
141             If the arg is a B reference it contains named arguments. The arguments
142             are:
143              
144             KEY DEFAUL DESC
145             ----------- ----------- -------------------
146             filename undef The key Filename
147             buffer undef Buffer containing the key
148             format undef Explicitly state the format ( DER | PEM )
149              
150             If both C and C are set the C argument will be ignored.
151              
152             If the format is not explcitly set C will look at the key and
153             try and determine what the format it.
154              
155              
156             =item load_key_from_disk( $key_path )
157              
158             B
159              
160             Load a key from disk. Currently the key needs to be unencrypted.
161             Callbacks for handling password protected keys are still to come.
162              
163             =item directory()
164              
165             Loads the directory from the ACME host. This call must be made first
166             before any other calls to the API in order the bootstrap the API
167             resource list.
168              
169             =item register( %args )
170              
171             Call the new-reg resource and create an account associated with the
172             loaded account key. If that key has already been registered this method
173             will gracefully and silently handle that.
174              
175             Arguments that can be passed in:
176              
177             KEY DEFAULT
178             ----------- --------------------
179             mailto undef
180              
181             B: See C for a desciption. This will override the value passed to new
182             if any.
183              
184              
185             =item accept_tos()
186              
187             In order to use the Let's Encrypt service, the account needs to accept
188             the Terms of Service. This is provided in a link header in response
189             to the new-reg ( or reg ) resource call. If the TOS have already been
190             accepted as indicated by the reg structure returned by the API this
191             call will be a noop.
192              
193             =item authz( $domain )
194              
195             C needs to be called for each domain ( called identifiers in
196             ACME speak ) in the certificate. This included the domain in the subject
197             as well as the Subject Alternate Name (SAN) fields. Each call to
198             C will result in a challenge being issued from Let's Encrypt.
199             These challenges need to be handled individually.
200              
201             =item handle_challenge( $challenge_object )
202              
203             C is called for each challenge issued by C.
204             The challenge object must be a subclass of C
205             which implements a 'handle' method. This objects handle method
206             will be passed three arguments and is expected to fulfill the
207             preconditions for the chosen challenge. The three areguments
208             are:
209              
210             fingerprint: the sha256 hex digest of the account key
211             token: the challenge token
212             url: the url returned by the challenge
213              
214             Fully describing how to handle every challenge type of out of the
215             scope of this documentation ( at least for now ). Two challenge
216             classes have been included for reference:
217              
218             C is initialized with the
219             ssh host name and the www root for the web server for the http-01
220             challenge. It will ssh to the host and create the file in
221             the correct location for challenge fulfillment.
222              
223             C is initialized with just the
224             www root for the web server for the http-01 challenge. It will
225             simply create the challenge file in the correct place on the local
226             filesystem.
227              
228             C is intended to be run in an
229             interactive manner and will stop and prompt the user with the relevant
230             information so they can fulfill the challenge manually.
231              
232             but below is an example for handling the simpleHTTP ( http-01 )
233             challenge.
234              
235              
236             =item check_challenge()
237              
238             Called after C. This will poll the challenge status
239             resource and will return when the state changes from 'pending'.
240              
241             =item cleanup_challenge()
242              
243             Called after C to remove the challenge files.
244              
245             =item $cert = sign( $csr_filename )
246              
247             =item $cert = sign( \$buffer )
248              
249             =item $cert = sign( \%explicit_args )
250              
251              
252             Call C after the challenge for each domain ( itentifier ) has
253             been fulfilled. There are three ways to call this:
254              
255             If the arg is a B it is assumed to be the filename of the
256             CSR. C will throw an error if there are problems reading the file.
257              
258             If the arg is a B reference it is assumed to be a buffer that
259             contains the CSR.
260              
261             If the arg is a B reference it contains named arguments. The arguments
262             are:
263              
264             KEY DEFAUL DESC
265             ----------- ----------- -------------------
266             filename undef The CSR Filename
267             buffer undef Buffer containing the CSR
268             format undef Explicitly state the format ( DER | PEM )
269              
270             If both C and C are set the C argument will be ignored.
271              
272             If the format is not explcitly set Protocol::ACME will look at the CSR and
273             try and determine what the format it.
274              
275             On success C will return the DER encoded signed certificate.
276              
277             =item $cert_chain = chain()
278              
279             After C has been called and a cert successfully created, C will
280             fetch and return the DER encoded certificate issuer.
281              
282             =item revoke( $certfile )
283              
284             Call C to revoke an already issued certificate. C<$certfile>
285             must point the a DER encoded form of the certificate.
286              
287             =item recovery_key()
288              
289             LE does not yet support recovery keys. This method will die when
290             called.
291              
292              
293             =back
294              
295             =cut
296              
297             package Protocol::ACME;
298              
299 6     6   19 use strict;
  6         9  
  6         71  
300 6     6   13 use warnings;
  6         7  
  6         113  
301              
302 6     6   1855 use Protocol::ACME::Exception;
  6         41  
  6         133  
303 6     6   1858 use Protocol::ACME::Utils;
  6         11  
  6         131  
304              
305 6     6   2214 use Crypt::Format;
  6         1872  
  6         143  
306 6     6   1944 use Crypt::RSA::Parse ();
  6         183067  
  6         154  
307              
308 6     6   2594 use MIME::Base64 qw( encode_base64url decode_base64url decode_base64 encode_base64 );
  6         2836  
  6         405  
309              
310 6     6   3454 use HTTP::Tiny;
  6         174683  
  6         217  
311 6     6   3763 use JSON;
  6         53446  
  6         26  
312 6     6   3460 use Digest::SHA qw( sha256 );
  6         13948  
  6         678  
313 6     6   38 use Carp;
  6         9  
  6         16035  
314              
315              
316             my $USERAGENT = "Protocol::ACME v$VERSION";
317             my $NONCE_HEADER = "replay-nonce";
318              
319             sub new
320             {
321 6     6 1 166992 my $class = shift;
322 6         14 my $self = {};
323 6         18 bless $self, $class;
324 6         22 $self->_init( @_ );
325 6         49 return $self;
326             }
327              
328             sub _init
329             {
330 6     6   12 my $self = shift;
331              
332 6         7 my $args;
333              
334 6 50       21 if ( ref $_[0] eq "HASH" )
335             {
336 0         0 $args = $_[0];
337             }
338             else
339             {
340 6         29 %$args = @_;
341             }
342              
343             # TODO: There are more elegant and well baked ways to take care of the
344             # parameter handling that I am doing here
345 6 50       42 $self->{host} = $args->{host} if exists $args->{host};
346 6 50       19 $self->{ua} = $args->{ua} if exists $args->{ua};
347 6 100       28 $self->{openssl} = $args->{openssl} if exists $args->{openssl};
348 6 100       21 $self->{debug} = $args->{debug} if exists $args->{debug};
349 6 100       22 $self->{loglevel} = exists $args->{loglevel} ? $args->{loglevel} : "error";
350 6 50       15 $self->{contact}->{mailto} = $args->{mailto} if exists $args->{mailto};
351              
352 6 100       18 if ( $self->{debug} )
353             {
354 2         4 $self->{loglevel} = "debug";
355             }
356              
357 6 50       18 if ( ! exists $self->{ua} )
358             {
359 6         61 $self->{ua} = HTTP::Tiny->new( agent => $USERAGENT, verify_SSL => 1 );
360             }
361              
362 6 50       392 if ( ! exists $self->{host} )
363             {
364 0         0 _throw( detail => "host parameter is required for Protocol::ACME::new" );
365             }
366              
367             $self->{log} = $args->{'logger'} || do
368 6   33     21 {
369             require Log::Any::Adapter;
370             Log::Any::Adapter->set('+Protocol::ACME::Logger', log_level => $self->{loglevel});
371             Log::Any->get_logger;
372             };
373              
374 6 100       8254 if ( exists $args->{account_key} )
375             {
376 4         21 $self->account_key( $args->{account_key} );
377             }
378              
379 6         31 $self->{links}->{directory} = "https://" . $self->{host} . '/directory';
380              
381 6         36 $self->{nonce} = undef;
382              
383              
384             }
385              
386             sub _throw
387             {
388 0     0   0 my (@args) = @_;
389 0 0       0 if ( scalar(@_) == 1 )
390             {
391 0         0 @args = ( detail => $_[0] );
392             }
393 0         0 croak ( Protocol::ACME::Exception->new( { @args } ) );
394             }
395              
396             sub load_key
397             {
398 0     0 0 0 my ($self, $keystring) = @_;
399 0         0 return $self->account_key( \$keystring );
400             }
401              
402             sub load_key_from_disk
403             {
404 0     0 1 0 my $self = shift;
405 0         0 my $path = shift;
406              
407 0         0 return $self->account_key($path);
408             }
409              
410             sub account_key
411             {
412 28     28 1 3160706 my $self = shift;
413 28         42 my $key = shift;
414              
415 28         140 my %args = ( filename => undef,
416             buffer => undef,
417             format => undef );
418              
419 28 100       127 if ( ! ref $key )
    100          
420             {
421 4         8 $args{filename} = $key;
422             }
423             elsif( ref $key eq "SCALAR" )
424             {
425 8         19 $args{buffer} = $$key;
426             }
427             else
428             {
429 16         65 @args{ keys %$key } = values %$key;
430             }
431              
432 28 100       99 if ( $args{filename} )
433             {
434 8         30 $args{buffer} = _slurp( $args{filename} );
435 8 50       27 if ( ! $args{buffer} )
436             {
437 0         0 _throw( "Could not load key from file $args{filename}: $!" );
438             }
439             }
440              
441 28 50       73 if ( ! $args{buffer} )
442             {
443 0         0 _throw( "Either a buffer or filename must be passed" );
444             }
445              
446 28 100       62 if ( ! $args{format} )
447             {
448 20 100       84 $args{format} = Protocol::ACME::Utils::looks_like_pem( $args{buffer} ) ? "PEM" : "DER";
449             }
450              
451 28         45 my $keystring = $args{buffer};
452             # TODO: This should detect/handle PKCS8-formatted private keys as well.
453 28 100       65 if ( $args{format} eq "DER" )
454             {
455 12         49 $keystring = Crypt::Format::der2pem( $keystring, "RSA PRIVATE KEY" );
456             }
457              
458 28 100       453 if ( exists $self->{openssl} )
459             {
460 15         1837 require Protocol::ACME::Key;
461             $key = Protocol::ACME::Key->new( keystring => $keystring,
462 15         97 openssl => $self->{openssl} );
463             }
464             else
465             {
466             eval
467 13         22 {
468 13         92 require Crypt::OpenSSL::RSA;
469 13         40 require Crypt::OpenSSL::Bignum;
470             };
471 13 50       38 if ( $@ )
472             {
473 0         0 die "Invoked usage requires Crypt::OpenSSL::RSA and Crypt::OpenSSL::Bignum. " .
474             "To avoid these dependencies use the openssl parameter when creating the " .
475             "Protocol::ACME object. This will use a native openssl binary instead.";
476             }
477              
478 13         977 $key = Crypt::OpenSSL::RSA->new_private_key($keystring);
479             }
480              
481 25 50       110 if ( ! $key )
482             {
483 0         0 _throw( "Could not load key into key structure" );
484             }
485              
486 25         94 $key->use_sha256_hash();
487              
488 25         67 $self->{key}->{key} = $key;
489              
490 25         548 my ( $n_b64, $e_b64 ) = map { encode_base64url(_bigint_to_binary($_)) } $key->get_key_parameters();
  116         1757  
491 25         254 $self->{key}->{n} = $n_b64;
492 25         48 $self->{key}->{e} = $e_b64;
493              
494 25         146 $self->{log}->debug( "Private key loaded" );
495              
496             }
497              
498              
499              
500              
501             sub directory
502             {
503 4     4 1 3857 my $self = shift;
504              
505 4         23 my $resp = $self->_request_get( $self->{links}->{directory} );
506              
507              
508              
509 4 50       27 if ( $resp->{status} != 200 )
510             {
511 0         0 _throw( detail => "Failed to fetch the directory for $self->{host}", resp => $resp );
512             }
513              
514 4         20 my $data = _decode_json( $resp->{content} );
515              
516 4         25 @{$self->{links}}{keys %$data} = values %$data;
  4         27  
517              
518              
519 4         61 $self->{log}->debug( "Let's Encrypt Directories loaded." );
520             }
521              
522             #
523             # Register the account or load the reg url for an existing account ( new-reg or reg )
524             #
525             sub register
526             {
527 4     4 1 2890 my $self = shift;
528 4         16 my %args = @_;
529              
530 4         13 my $obj = {};
531 4         17 $obj->{resource} = 'new-reg';
532              
533 4 50       34 if ( exists $args{mailto} )
    50          
534             {
535 0         0 push @{$obj->{contact}}, "mailto:$args{mailto}";
  0         0  
536             }
537             elsif ( exists $self->{contact}->{mailto} )
538             {
539 0         0 push @{$obj->{contact}}, "mailto:$self->{contact}->{mailto}";
  0         0  
540             }
541              
542 4         18 my $msg = _encode_json( $obj );
543              
544 4         36 my $json = $self->_create_jws( $msg );
545              
546 3         52 $self->{log}->debug( "Sending registration message" );
547              
548 3         30 my $resp = $self->_request_post( $self->{links}->{'new-reg'}, $json );
549              
550 3 50       23 if ( $resp->{status} == 409 )
    0          
551             {
552 3         16 $self->{links}->{'reg'} = $resp->{headers}->{'location'};
553              
554 3         25 $self->{log}->debug( "Known key used" );
555 3         23 $self->{log}->debug( "Refetching with location URL" );
556              
557 3         31 my $json = $self->_create_jws( _encode_json( { "resource" => 'reg' } ) );
558              
559 2         29 $resp = $self->_request_post( $self->{links}->{'reg'}, $json );
560              
561 2 50       31 if ( $resp->{status} == 202 )
562             {
563 2         12 my $links = _link_to_hash( $resp->{headers}->{'link'} );
564              
565 2         10 @{$self->{links}}{keys %$links} = values %$links;
  2         18  
566             }
567             else
568             {
569 0         0 _throw( %{ $self->{content} } );
  0         0  
570             }
571             }
572             elsif ( $resp->{status} == 201 )
573             {
574 0         0 my $links = _link_to_hash( $resp->{headers}->{'link'} );
575              
576 0         0 @{$self->{links}}{keys %$links} = values %$links;
  0         0  
577              
578 0         0 $self->{links}->{'reg'} = $resp->{headers}->{'location'};
579 0         0 $self->{log}->debug( "New key used" );
580             }
581             else
582             {
583 0         0 _throw( %{ $self->{content} } );
  0         0  
584             }
585              
586              
587 2         35 $self->{reg} = $self->{content};
588             }
589              
590             sub recovery_key
591             {
592             # LE does not yet support the key recovery resource
593             # the below can be considered debug code
594              
595 0     0 1 0 die "Let's Encrypt does not yet support key recovery";
596              
597 0         0 my $self = shift;
598              
599 0         0 my $keyfile = shift;
600              
601              
602 0         0 my $pem = _slurp( $keyfile );
603 0 0       0 _throw( "$keyfile: $!" ) if ! $pem;
604              
605 0         0 my $url = "https://acme-staging.api.letsencrypt.org/acme/reg/101834";
606              
607 0         0 my $der = Crypt::Format::pem2der( $pem );
608              
609 0         0 my $pub = Crypt::PK::ECC->new( \$der );
610              
611 0         0 my $public_json_text = $pub->export_key_jwk('public');
612              
613 0         0 my $hash = $pub->export_key_jwk( 'public', 1 );
614              
615             my $msg = { "resource" => "reg",
616             "recoveryToken" => {
617             "client" => { "kty" => "EC",
618             "crv" => "P-256",
619             "x" => $hash->{x},
620             "y" => $hash->{y}
621             }
622             }
623 0         0 };
624              
625 0         0 my $json = $self->_create_jws( _encode_json($msg) );
626              
627 0         0 my $resp = $self->_request_post( $url, $json );
628              
629             # TODO: This is not complete
630             }
631              
632             sub accept_tos
633             {
634 2     2 1 1395 my $self = shift;
635              
636 2 50       10 if ( exists $self->{reg}->{agreement} )
637             {
638 2         23 $self->{log}->debug( "TOS already accepted. Skipping" );
639 2         12 return;
640             }
641              
642 0         0 $self->{log}->debug( "Accepting TOS" );
643             # TODO: check for existance of terms-of-service link
644             # TODO: assert on reg url being present
645              
646             my $msg = _encode_json( { "resource" => "reg",
647             "agreement" => $self->{links}->{'terms-of-service'},
648             "key" => { "e" => $self->{key}->{e},
649             "kty" => "RSA",
650 0         0 "n" => $self->{key}->{n} } } );
651              
652              
653 0         0 my $json = $self->_create_jws( $msg );
654              
655 0         0 my $resp = $self->_request_post( $self->{links}->{'reg'}, $json );
656              
657 0 0       0 if ( $resp->{status} == 202 )
658             {
659 0         0 $self->{log}->debug( "Accepted TOS" );
660             }
661             else
662             {
663 0         0 _throw( %{ $self->{content} } );
  0         0  
664             }
665             }
666              
667             sub revoke
668             {
669 0     0 1 0 my $self = shift;
670 0         0 my $certfile = shift;
671              
672 0         0 $self->{log}->debug( "Revoking Cert" );
673              
674 0         0 my $cert = _slurp( $certfile );
675              
676 0 0       0 if ( ! $cert )
677             {
678 0         0 _throw("Could not load cert from $certfile: $!");
679             }
680              
681              
682 0         0 my $msg = _encode_json( { "resource" => "revoke-cert",
683             "certificate" => encode_base64url( $cert ) } );
684              
685              
686 0         0 my $json = $self->_create_jws( $msg );
687              
688 0         0 my $resp = $self->_request_post( $self->{links}->{'revoke-cert'}, $json );
689              
690 0 0       0 if ( $resp->{status} != 200 )
691             {
692 0         0 _throw( %{ $self->{content} } );
  0         0  
693             }
694              
695             }
696              
697             sub authz
698             {
699 0     0 1 0 my $self = shift;
700 0         0 my $domain = shift;
701              
702 0         0 $self->{log}->debug( "Sending authz message for $domain" );
703             # TODO: check for 'next' URL and that is it authz
704              
705 0         0 my $msg = _encode_json( { "identifier" => { "type" => "dns", "value" => $domain },
706             "resource" => "new-authz" } );
707              
708 0         0 my $json = $self->_create_jws( $msg );
709              
710 0         0 my $resp = $self->_request_post( $self->{links}->{next}, $json );
711              
712 0 0       0 if ( $resp->{status} == 201 )
713             {
714 0         0 $self->{challenges} = $self->{content}->{challenges};
715             }
716             else
717             {
718 0         0 _throw( %{ $self->{content} } );
  0         0  
719             }
720             }
721              
722             sub handle_challenge
723             {
724 0     0 1 0 my $self = shift;
725 0         0 my $challenge = shift;
726 0         0 my @args = @_;
727              
728 0         0 my $key = $self->{key};
729              
730 0         0 my $jwk = _encode_json( { "e" => $key->{e}, "kty" => "RSA", "n" => $key->{n} } );
731 0         0 my $token;
732             my $challenge_url;
733              
734             # TODO: this is feeling hardcoded and messy - and fragile
735             # how do we handle other auth challenges?
736             # This is hardcoded for http-01
737 0         0 for ( @{$self->{challenges}} )
  0         0  
738             {
739 0 0       0 if ( $_->{type} eq "http-01" )
740             {
741 0         0 $token = $_->{token};
742 0         0 $challenge_url = $_->{uri};
743             }
744             }
745              
746              
747 0         0 my $fingerprint = encode_base64url( sha256( $jwk ) );
748              
749 0         0 $self->{log}->debug( "Handing challenge for token: $token.$fingerprint" );
750              
751 0         0 my $ret = $challenge->handle( $token, $fingerprint, @args );
752              
753 0 0       0 if ( $ret == 0 )
754             {
755 0         0 $self->{fingerprint} = $fingerprint;
756 0         0 $self->{token} = $token;
757 0         0 $self->{links}->{challenge} = $challenge_url;
758             }
759             else
760             {
761 0         0 _throw( status => 0, detail => $ret, type => "challenge_exec" );
762             }
763             }
764              
765              
766             sub check_challenge
767             {
768 0     0 1 0 my $self = shift;
769              
770 0         0 my $msg = _encode_json( { "resource" => "challenge", "keyAuthorization" => $self->{token} . '.' . $self->{fingerprint} } );
771              
772 0         0 my $json = $self->_create_jws( $msg );
773              
774              
775 0         0 my $resp = $self->_request_post( $self->{links}->{challenge}, $json );
776              
777 0         0 my $status_url = $self->{content}->{uri};
778              
779             # TODO: check for failure of challenge check
780             # TODO: check for other HTTP failures
781              
782 0         0 $self->{log}->debug( "Polling for challenge fulfillment" );
783 0         0 while( 1 )
784             {
785 0         0 $self->{log}->debug( "Status: $self->{content}->{status}" );
786 0 0       0 if ( $self->{content}->{status} eq "pending" )
    0          
787             {
788 0         0 sleep(2);
789 0         0 $resp = $self->_request_get( $status_url );
790             }
791             elsif ( $self->{content}{status} eq "invalid" )
792             {
793 0         0 _throw(%{ $self->{content} });
  0         0  
794             }
795             else
796             {
797 0         0 last;
798             }
799             }
800             }
801              
802             sub cleanup_challenge
803             {
804 0     0 1 0 my $self = shift;
805 0         0 my $challenge = shift;
806 0         0 return $challenge->cleanup();
807             }
808              
809             sub sign
810             {
811 0     0 1 0 my $self = shift;
812 0         0 my $csr = shift;
813              
814 0         0 $self->{log}->debug( "Signing" );
815              
816 0         0 my %args = ( filename => undef,
817             buffer => undef,
818             format => undef );
819              
820 0 0       0 if ( ! ref $csr )
    0          
821             {
822 0         0 $args{filename} = $csr;
823             }
824             elsif( ref $csr eq "SCALAR" )
825             {
826 0         0 $args{buffer} = $$csr;
827             }
828             else
829             {
830 0         0 @args{keys %$csr} = values %$csr;
831             }
832              
833 0 0       0 if ( $args{filename} )
834             {
835 0         0 $args{buffer} = _slurp( $args{filename} );
836 0 0       0 if ( ! $args{buffer} )
837             {
838 0         0 _throw( "Could not load CSR from file $args{filename}" );
839             }
840             }
841              
842 0 0       0 if ( ! $args{buffer} )
843             {
844 0         0 _throw( "Either a buffer or filename must be passed to sign" );
845             }
846              
847 0 0       0 if ( ! $args{format} )
848             {
849 0 0       0 $args{format} = Protocol::ACME::Utils::looks_like_pem( $args{buffer} ) ? "PEM" : "DER";
850             }
851              
852 0 0       0 my $der = $args{format} eq "DER" ? $args{buffer} : Crypt::Format::pem2der( $args{buffer} );
853              
854 0         0 my $msg = _encode_json( { "resource" => "new-cert", "csr" => encode_base64url( $der ) } );
855              
856 0         0 my $json = $self->_create_jws( $msg );
857              
858 0         0 my $resp = $self->_request_post( $self->{links}->{'new-cert'}, $json, 1 );
859              
860 0 0       0 if ( $resp->{status} != 201 )
861             {
862 0         0 _throw( %{_decode_json($resp->{content}) } );
  0         0  
863             }
864              
865 0         0 my $links = _link_to_hash( $resp->{headers}->{'link'} );
866              
867 0 0       0 $self->{links}->{chain} = $links->{up} if exists $links->{up};
868 0 0       0 $self->{links}->{cert} = $resp->{headers}->{location} if exists $resp->{headers}->{location};
869              
870 0         0 $self->{cert} = $resp->{content};
871              
872 0         0 return $self->{cert};
873             }
874              
875             sub chain
876             {
877 0     0 1 0 my $self = shift;
878              
879 0 0       0 if ( ! exists $self->{links}->{chain} )
880             {
881 0         0 _throw( "URL for the cert chain missing. Has sign() been called yet?" );
882             }
883              
884 0         0 my $resp = $self->_request_get( $self->{links}->{chain}, 1 );
885              
886 0 0       0 if ( $resp->{status} != 200 )
887             {
888             _throw( detail => "Error received fetching the certificate chain",
889 0         0 status => $resp->{status} );
890             }
891              
892 0         0 $self->{chain} = $resp->{content};
893              
894 0         0 return $self->{chain};
895             }
896              
897             #############################################################
898             ### "Private" functions
899              
900             sub _request_get
901             {
902 4     4   11 my $self = shift;
903 4         5 my $url = shift;
904 4   50     64 my $nodecode = shift || 0;
905              
906 4         139 my $resp = $self->{ua}->get( $url );
907              
908 4         1932916 $self->{nonce} = $resp->{headers}->{$NONCE_HEADER};
909 4         154 $self->{json} = $resp->{content};
910              
911             #Exception here should be fatal.
912 4         12 $self->{content} = undef;
913 4 50       75 $self->{content} = _decode_json( $resp->{content} ) unless $nodecode;
914              
915 4         15 $self->{response} = $resp;
916              
917 4         26 return $resp;
918             }
919              
920             sub _request_post
921             {
922 5     5   15 my $self = shift;
923 5         16 my $url = shift;
924 5         9 my $content = shift;
925 5   50     39 my $nodecode = shift || 0;
926              
927 5         320 my $resp = $self->{ua}->post( $url, { content => $content } );
928              
929 5         2000366 $self->{nonce} = $resp->{headers}->{$NONCE_HEADER};
930              
931 5         17 $self->{json} = $resp->{content};
932              
933             #Let exception from decode_json() propagate:
934             #if we failed to decode the JSON, that’s a show-stopper.
935 5         17 $self->{content} = undef;
936 5 50       69 $self->{content} = _decode_json( $resp->{content} ) unless $nodecode;
937              
938 5         16 $self->{response} = $resp;
939              
940 5         51 return $resp;
941             }
942              
943             sub _create_jws
944             {
945 7     7   20 my $self = shift;
946              
947 7         14 my $msg = shift;
948 7         37 return _create_jws_internal( $self->{key}, $msg, $self->{nonce} );
949             }
950              
951              
952             #############################################################
953             ### Helper functions - not class methods
954              
955             sub _slurp
956             {
957 8     8   13 my $filename = shift;
958              
959 8 50       371 open my $fh, '<', $filename or return undef;
960              
961 8 50       113 sysread( $fh, my $content, -s $fh ) or return undef;
962              
963 8         219 return $content;
964             }
965              
966              
967             sub _link_to_hash
968             {
969 2     2   5 my $arrayref = shift;
970 2         3 my $links;
971              
972 2 50       8 return {} unless $arrayref;
973              
974 2 50       10 if ( ! ref $arrayref )
975             {
976 0         0 $arrayref = [ $arrayref ];
977             }
978              
979 2         6 for my $link ( @$arrayref )
980             {
981 4         15 my ( $value, $key ) = split( ';', $link );
982 4         20 my ($url) = $value =~ /<([^>]*)>/;
983 4         14 my ($rel) = $key =~ /rel=\"([^"]*)"/;
984              
985 4 50 33     25 if ( $url && $rel )
986             {
987 4         17 $links->{$rel} = $url;
988             }
989             else
990             {
991             # TODO: Something wonderful
992             }
993             }
994              
995 2         4 return $links;
996             }
997              
998             sub _bigint_to_binary {
999 116     116   123 my ( $bigint ) = @_;
1000              
1001             # TODO: Inelegant hack to deal with different Bignum implementations
1002 116         90 my $hex;
1003 116 100       307 if ( UNIVERSAL::isa( $bigint, "Math::BigInt" ) )
1004             {
1005 28         101 $hex = substr( $bigint->as_hex(), 2 );
1006             #Prefix a 0 as needed to get an even number of digits.
1007 28 100       159781 if (length($hex) % 2) {
1008 14         38 substr( $hex, 0, 0, 0 );
1009             }
1010              
1011 28         206 return pack 'H*', $hex;
1012             }
1013             else
1014             {
1015 88         288 $bigint->to_bin();
1016             }
1017              
1018             }
1019              
1020             sub _create_jws_internal
1021             {
1022 7     7   14 my $key = shift;
1023 7         15 my $msg = shift;
1024 7         18 my $nonce = shift;
1025              
1026 7         25 my $protected_header = '{"nonce": "' . $nonce . '"}';
1027              
1028 7         51 my $sig = encode_base64url( $key->{key}->sign( encode_base64url($protected_header) . "." . encode_base64url($msg) ) );
1029              
1030             my $jws = { header => { alg => "RS256", jwk => { "e" => $key->{e}, "kty" => "RSA", "n" => $key->{n} } },
1031 5         8693 protected => encode_base64url( $protected_header ),
1032             payload => encode_base64url( $msg ),
1033             signature => $sig };
1034              
1035 5         154 my $json = _encode_json( $jws );
1036              
1037 5         81 return $json;
1038              
1039             }
1040              
1041             sub _decode_json
1042             {
1043 13     13   31 my $ref = shift;
1044              
1045 13         24 my $json = "";
1046              
1047             eval
1048 13         23 {
1049 13         447 $json = JSON->new->allow_nonref->decode($ref);
1050             };
1051              
1052 13         80 return $json;
1053             }
1054              
1055             sub _encode_json
1056             {
1057 12     12   25 my $ref = shift;
1058             # my $json = JSON->new();
1059             # $json->canonical();
1060             # return $json->encode($ref);
1061 12         611 return JSON->new->canonical->encode($ref);
1062             }
1063              
1064              
1065             =head1 AUTHOR
1066              
1067             Stephen Ludin, C<< >>
1068              
1069             =head1 BUGS
1070              
1071             Please report any bugs or feature requests to C, or through
1072             the web interface at L. I will be notified, and then you'll
1073             automatically be notified of progress on your bug as I make changes.
1074              
1075             =head1 REPOSITORY
1076              
1077             https://github.com/sludin/Protocol-ACME
1078              
1079              
1080             =head1 SUPPORT
1081              
1082             You can find documentation for this module with the perldoc command.
1083              
1084             perldoc Protocol::ACME
1085              
1086              
1087             You can also look for information at:
1088              
1089             =over 4
1090              
1091             =item * RT: CPAN's request tracker (report bugs here)
1092              
1093             L
1094              
1095             =item * AnnoCPAN: Annotated CPAN documentation
1096              
1097             L
1098              
1099             =item * CPAN Ratings
1100              
1101             L
1102              
1103             =item * Search CPAN
1104              
1105             L
1106              
1107             =back
1108              
1109              
1110             =head1 CONTRIBUTORS
1111              
1112             Felipe Gasper, C<< >>
1113              
1114             =head1 ACKNOWLEDGEMENTS
1115              
1116              
1117              
1118             =head1 LICENSE AND COPYRIGHT
1119              
1120             Copyright 2015 Stephen Ludin.
1121              
1122             This program is free software; you can redistribute it and/or modify it
1123             under the terms of the the Artistic License (2.0). You may obtain a
1124             copy of the full license at:
1125              
1126             L
1127              
1128             Any use, modification, and distribution of the Standard or Modified
1129             Version 0.16
1130             distributing the Package, you accept this license. Do not use, modify,
1131             or distribute the Package, if you do not accept this license.
1132              
1133             If your Modified Version has been derived from a Modified Version made
1134             by someone other than you, you are nevertheless required to ensure that
1135             your Modified Version complies with the requirements of this license.
1136              
1137             This license does not grant you the right to use any trademark, service
1138             mark, tradename, or logo of the Copyright Holder.
1139              
1140             This license includes the non-exclusive, worldwide, free-of-charge
1141             patent license to make, have made, use, offer to sell, sell, import and
1142             otherwise transfer the Package with respect to any patent claims
1143             licensable by the Copyright Holder that are necessarily infringed by the
1144             Package. If you institute patent litigation (including a cross-claim or
1145             counterclaim) against any party alleging that the Package constitutes
1146             direct or contributory patent infringement, then this Artistic License
1147             to you shall terminate on the date that such litigation is filed.
1148              
1149             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
1150             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
1151             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
1152             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
1153             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
1154             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
1155             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
1156             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1157              
1158              
1159             =cut
1160              
1161             1; # End of Protocol::ACME