view release on metacpan or  search on metacpan

lib/Crypt/LE.pm  view on Meta::CPAN

        ca      => '',
        dir     => '',
        live    => 0,
        debug   => 0,
        autodir => 1,
        delay   => 2,
        version => 0,
        try     => 300,
    };
    foreach my $key (keys %{$self}) {
        $self->{$key} = $params{$key} if (exists $params{$key} and !ref $params{$key});
    }
    # Init UA
    $self->{ua} = HTTP::Tiny->new( agent => $self->{ua} || __PACKAGE__ . " v$VERSION", verify_SSL => 1 );
    # Init server
    my $opts;
    if ($self->{server}) {
        # Custom server - drop the protocol if given (defaults to https later). If that leaves nothing, the check below
        # will set the servers to LE standard ones.
        $self->{server}=~s~^\w+://~~;
    } elsif ($self->{dir}) {
        $self->{dir} = "https://$self->{dir}" unless $self->{dir}=~m~^https?://~i;
    } elsif ($self->{ca}) {
        $opts = $cas->{lc($self->{ca})} || $cas->{$default_ca};
    } else {
        $opts = $cas->{$default_ca};
    }

    if ($opts) {
        # Only check for live option if the 'stage' is supported by CA. Otherwise use live URL.
        if ($opts->{'stage'}) {
            $self->{dir} = $self->{live} ? $opts->{live} : $opts->{stage};
        } else {
            $self->{dir} = $opts->{live};
        }
    }

    # Init logger
    $self->{logger} = $params{logger} if ($params{logger} and blessed $params{logger});
    bless $self, $class;
}

#====================================================================================================
# API Setup functions
#====================================================================================================

=head2 load_account_key($filename|$scalar_ref)

Loads the private account key from the file or scalar in PEM or DER formats.

Returns: OK | READ_ERROR | LOAD_ERROR | INVALID_DATA.

=cut

sub load_account_key {
    my ($self, $file) = @_;
    $self->_reset_key;
    my $key = $self->_file($file);
    return $self->_status(READ_ERROR, "Key reading error.") unless $key;
    eval {
        $key = Crypt::OpenSSL::RSA->new_private_key($self->_convert($key, 'RSA PRIVATE KEY'));
    };
    return $self->_status(LOAD_ERROR, "Key loading error.") if $@;
    return $self->_set_key($key, "Account key loaded.");
}

=head2 generate_account_key()

Generates a new private account key of the $keysize bits (4096 by default). The key is additionally validated for not being divisible by small primes.

Returns: OK | INVALID_DATA.

=cut

sub generate_account_key {
    my $self = shift;
    my ($pk, $err, $code) = _key();
    return $self->_status(INVALID_DATA, $err||"Could not generate account key") unless $pk;
    my $key = Crypt::OpenSSL::RSA->new_private_key(Net::SSLeay::PEM_get_string_PrivateKey($pk));
    _free(k => $pk);
    return $self->_set_key($key, "Account key generated.");
}

=head2 account_key()

Returns: A previously loaded or generated private key in PEM format or undef.

=cut

sub account_key {
    return shift->{pem};
}

=head2 load_csr($filename|$scalar_ref [, $domains])

Loads Certificate Signing Requests from the file or scalar. Domains list can be omitted or it can be given as a string of comma-separated names or as an array reference.
If omitted, then names will be loaded from the CSR. If it is given, then the list of names will be verified against those found on CSR.

Returns: OK | READ_ERROR | LOAD_ERROR | INVALID_DATA | DATA_MISMATCH.

=cut

sub load_csr {
    my $self = shift;
    my ($file, $domains) = @_;
    $self->_reset_csr;
    my $csr = $self->_file($file);
    return $self->_status(READ_ERROR, "CSR reading error.") unless $csr;
    my $bio = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem());
    return $self->_status(LOAD_ERROR, "Could not allocate memory for the CSR") unless $bio;
    my ($in, $cn, $san, $i);
    unless (Net::SSLeay::BIO_write($bio, $csr) and $in = Net::SSLeay::PEM_read_bio_X509_REQ($bio)) {
        _free(b => $bio);
        return $self->_status(LOAD_ERROR, "Could not load the CSR");
    }
    $cn = Net::SSLeay::X509_REQ_get_subject_name($in);
    if ($cn) {
        $cn = Net::SSLeay::X509_NAME_print_ex($cn, $flag_rfc22536_utf8, 1);
        $cn = lc($1) if ($cn and $cn=~/^.*?\bCN=([^\s,]+).*$/);
    }
    my @list = @{$self->_get_list($domains)};
    $i = Net::SSLeay::X509_REQ_get_attr_by_NID($in, &Net::SSLeay::NID_ext_req, -1);
    if ($i > -1) {
        my $o = Net::SSLeay::P_X509_REQ_get_attr($in, $i);
        if ($o) {
            my $exts = $asn->find("Extensions");
            my $dec = $exts->decode(Net::SSLeay::P_ASN1_STRING_get($o));
            if ($dec) {
                foreach my $ext (@{$dec}) {
                     if ($ext->{extnID} and $ext->{extnID} eq SAN) {
                         $exts = $asn->find("SubjectAltName");
                         $san = $exts->decode($ext->{extnValue});
                         last;
                     }
                }
            }
        }
    }
    my @loaded_domains = ();

lib/Crypt/LE.pm  view on Meta::CPAN

=head2 set_domains($domains)

Sets the list of domains to be used for verification process. This call is optional if you load or generate a CSR, in which case the list of the domains will be set at that point.

Returns: OK | INVALID_DATA.

=cut

sub set_domains {
    my ($self, $domains) = @_;
    my @list = @{$self->_get_list($domains)};
    return $self->_status(INVALID_DATA, "No domains provided.") unless @list;
    if (my $odd = $self->_verify_list(\@list)) {
         return $self->_status(INVALID_DATA, "Unsupported domain names provided: " . join(", ", @{$odd}));
    }
    $self->{loaded_domains} = \@list;
    my %loaded_domains = map {$_, undef} @list;
    $self->{domains} = \%loaded_domains;
    return $self->_status(OK, "Domains list is set");
}

=head2 set_version($version)

Sets the API version to be used. To pick the version automatically, use 0, other accepted values are currently 1 and 2.

Returns: OK | INVALID_DATA.

=cut

sub set_version {
    my ($self, $version) = @_;
    return $self->_status(INVALID_DATA, "Unsupported API version") unless (defined $version and $version=~/^\d+$/ and $version <= 2);
    $self->{version} = $version;
    return $self->_status(OK, "API version is set to $version.");
}

=head2 version()

Returns: The API version currently used (1 or 2). If 0 is returned, it means it is set to automatic detection and the directory has not yet been retrieved.

=cut

sub version {
    my $self = shift;
    return $self->{version};
}

#====================================================================================================
# API Setup helpers
#====================================================================================================

sub _reset_key {
    my $self = shift;
    undef $self->{$_} for qw<key_params key pem jwk fingerprint>;
}

sub _set_key {
    my $self = shift;
    my ($key, $msg) = @_;
    my $pem = $key->get_private_key_string;
    my ($n, $e) = $key->get_key_parameters;
    return $self->_status(INVALID_DATA, "Key modulus is divisible by a small prime and will be rejected.") if $self->_is_divisible($n);
    $key->use_pkcs1_padding;
    $key->use_sha256_hash;
    $self->{key_params} = { n => $n, e => $e };
    $self->{key} = $key;
    $self->{pem} = $pem;
    $self->{jwk} = $self->_jwk();
    $self->{fingerprint} = encode_base64url(sha256($j->encode($self->{jwk})));
    if ($self->{autodir}) {
        my $status = $self->directory;
        return $status unless ($status == OK);
    }
    return $self->_status(OK, $msg);
}

sub _is_divisible {
    my ($self, $n) = @_;
    my ($quotient, $remainder);
    my $ctx = Crypt::OpenSSL::Bignum::CTX->new();
    foreach my $prime (@primes) {
        ($quotient, $remainder) = $n->div($prime, $ctx);
        return 1 if $remainder->is_zero;
    }
    return 0;
}

sub _reset_csr {
    my $self = shift;
    undef $self->{$_} for qw<domains loaded_domains csr>;
}

sub _set_csr {
    my $self = shift;
    my ($csr, $pk, $domains) = @_;
    $self->{csr} = $csr;
    $self->{csr_key} = $pk;
    my %loaded_domains = map {$_, undef} @{$domains};
    $self->{loaded_domains} = $domains;
    $self->{domains} = \%loaded_domains;
}

sub _get_list {
    my ($self, $list) = @_;
    return [ map {lc $_} (ref $list eq 'ARRAY') ? @{$list} : $list ? split /\s*,\s*/, $list : () ];
}

sub _verify_list {
    my ($self, $list) = @_;
    my @odd = grep { /[\s\[\{\(\<\@\>\)\}\]\/\\:]/ or /^[\d\.]+$/ or !/\./ } @{$list};
    return @odd ? \@odd : undef;
}

#====================================================================================================
# API Workflow functions
#====================================================================================================

=head1 METHODS (API Workflow)

The following methods are provided for the API workflow processing. All but C<accept_challenge()> methods interact with Let's Encrypt servers.