view release on metacpan or  search on metacpan

lib/Zuzu/Module/Secure.pm  view on Meta::CPAN

	my $curve = eval { $x509->curve } // '';
	my ( $algorithm, $pk );
	if ( ( $x509->pubkey_type // '' ) eq 'ec' ) {
		$algorithm = $curve eq 'prime256v1'
			? 'ecdsa-p256-sha256'
			: $curve eq 'secp384r1'
				? 'ecdsa-p384-sha384'
				: $curve eq 'secp521r1'
					? 'ecdsa-p521-sha512'
					: undef;
		_error(
			'Certificate.public_key certificate public-key algorithm '
			. 'is unsupported',
		) if not defined $algorithm;
		$pk = Crypt::PK::ECC->new;
		_error( 'Certificate.public_key failed to import public key' )
			if not eval { $pk->import_key( \$pem ); 1 };
	}
	elsif ( ( $x509->pubkey_type // '' ) eq 'ed25519' ) {
		$algorithm = 'ed25519';
		$pk = Crypt::PK::Ed25519->new;
		_error( 'Certificate.public_key failed to import public key' )
			if not eval { $pk->import_key( \$pem ); 1 };
	}
	else {
		_error(
			'Certificate.public_key certificate public-key algorithm '
			. 'is unsupported',
		);
	}
	return _new_public_key( $public_key_class, $algorithm, $pk );
}

sub _new_tls_identity {
	my ( $tls_identity_class, %slots ) = @_;

	return native_object(
		class => $tls_identity_class,
		slots => \%slots,
		const => {
			_cert_pem => 1,
			_key_pem => 1,
			_password => 1,
			_chain_pem => 1,
			_source => 1,
		},
	);
}

sub _tls_identity_state {
	my ( $self, $label ) = @_;

	_error( "TypeException: $label expects TlsIdentity" )
		if not blessed($self)
			or not $self->can('class')
			or $self->class->name ne 'TlsIdentity';
	return $self->slots;
}

sub _tls_identity_from_pem {
	my ( $tls_identity_class, $certificate_pem, $private_key_pem, $password ) = @_;

	my $label = 'TlsIdentity.from_pem';
	my $cert_pem = _string_arg(
		$certificate_pem,
		$label,
		'String certificate_pem',
	);
	my $key_pem = _string_arg(
		$private_key_pem,
		$label,
		'String private_key_pem',
	);
	my $pass = _optional_password_text( $password, $label, 'String password' );
	my @blocks = _pem_blocks( $cert_pem, $label );
	_parse_x509_der( native_class( name => 'Certificate' ), $blocks[0], $label );
	_error( "$label expects PEM private key text" )
		if $key_pem !~ /-----BEGIN [A-Z ]*PRIVATE KEY-----/;

	return _new_tls_identity(
		$tls_identity_class,
		_cert_pem => _der_to_pem_certificate( $blocks[0] ),
		_key_pem => $key_pem,
		_password => $pass,
		_chain_pem => join( '', map { _der_to_pem_certificate($_) } @blocks ),
		_source => 'pem',
	);
}

sub _tls_identity_from_pkcs12 {
	my ( $tls_identity_class, $bytes_value, $password ) = @_;

	my $label = 'TlsIdentity.from_pkcs12';
	my $bytes = _binary_bytes( $bytes_value, $label, 'BinaryString bytes' );
	my $pass = _optional_password_text( $password, $label, 'String password' );
	my $pkcs12 = eval { Crypt::OpenSSL::PKCS12->new_from_string($bytes) };
	_error( "$label expects PKCS#12 data" ) if not defined $pkcs12;
	_error( "$label failed to decrypt PKCS#12 data" )
		if not eval { $pkcs12->mac_ok($pass) };
	my $cert_pem = eval { $pkcs12->certificate($pass) };
	my $key_pem = eval { $pkcs12->private_key($pass) };
	_error( "$label expects PKCS#12 data with certificate and private key" )
		if not defined $cert_pem or not defined $key_pem;
	my $ca_pem = eval { $pkcs12->ca_certificate($pass) } // '';
	my @blocks = _pem_blocks( $cert_pem, $label );

	return _new_tls_identity(
		$tls_identity_class,
		_cert_pem => _der_to_pem_certificate( $blocks[0] ),
		_key_pem => $key_pem,
		_password => '',
		_chain_pem => $cert_pem . $ca_pem,
		_source => 'pkcs12',
	);
}

sub _tls_identity_certificate {
	my ( $certificate_class, $self ) = @_;

	my $state = _tls_identity_state( $self, 'TlsIdentity.certificate' );
	my ( $der ) = _pem_blocks( $state->{_cert_pem}, 'TlsIdentity.certificate' );
	return _parse_x509_der( $certificate_class, $der, 'TlsIdentity.certificate' );
}

sub _tls_identity_private_key {
	my ( $signing_key_class, $self ) = @_;

	my $state = _tls_identity_state( $self, 'TlsIdentity.private_key' );
	my $options = Zuzu::Value::Dict->new(
		map => {
			format => 'pem',
			password => $state->{_password},
		},
	);
	return eval {
		_signing_import_private(
			$signing_key_class,
			$state->{_key_pem},
			$options,
		);
	} // do {
		_error(
			'TlsIdentity.private_key only supports Ed25519, ECDSA P-256, '
			. 'ECDSA P-384, and ECDSA P-521 private keys',
		);
	};
}

sub _signing_generate {
	my ( $signing_key_class, $algorithm ) = @_;

	my $label = 'SigningKey.generate';
	$algorithm = _signing_algorithm( $algorithm, $label );
	my $meta = _signing_meta($algorithm);
	my $pk = _new_key_for_algorithm($algorithm);
	if ( $meta->{type} eq 'ed25519' ) {
		$pk->generate_key;
	}
	elsif ( $meta->{type} eq 'ecdsa' ) {
		$pk->generate_key( $meta->{curve} );
	}
	return _new_signing_key( $signing_key_class, $algorithm, $pk );
}

sub _signing_import_private {
	my ( $signing_key_class, $key, $options ) = @_;

	my $label = 'SigningKey.import_private';
	my $opts = _signing_options( $options, $label );
	my $format = _key_format( $options, $key, $label );
	my $algorithm = _signing_algorithm_option( $opts, $label );
	my $password = exists $opts->{password}
		? _optional_password_text(
			$opts->{password},
			$label,
			'String options.password',
		)
		: undef;
	my $pk;
	if ( $format eq 'raw' ) {
		my $bytes = _binary_bytes( $key, $label, 'BinaryString key' );
		$algorithm //= 'ed25519';
		my $meta = _signing_meta($algorithm);
		_error( "$label expects a $meta->{private_length}-byte raw private key" )
			if length($bytes) != $meta->{private_length};
		$pk = _new_key_for_algorithm($algorithm);
		if ( $meta->{type} eq 'ed25519' ) {
			$pk->import_key_raw( $bytes, 'private' );
		}
		else {
			$pk->import_key_raw( $bytes, $meta->{curve} );
		}
	}
	elsif ( $format eq 'pem' ) {
		my $pem = _string_arg( $key, $label, 'String key' );
		if ( defined $algorithm ) {
			$pk = _new_key_for_algorithm($algorithm);
			_error( "$label expects PEM private key" )
				if not eval { $pk->import_key( \$pem, $password ); 1 };
			if ( _signing_meta($algorithm)->{type} eq 'ecdsa' ) {
				my $actual = _ecdsa_algorithm_for_key( $pk, $label );
				_error( "$label PEM key algorithm does not match $algorithm" )
					if $actual ne $algorithm;

lib/Zuzu/Module/Secure.pm  view on Meta::CPAN

					return $runtime->_new_task(
						name => 'SigningKey.import_public_async',
						status => 'fulfilled',
						result => $value,
					);
				},
			),
		},
		methods => {
			public_key => native_function(
				name => 'public_key',
				native => sub {
					my ( $self ) = @_;
					return _signing_public_key(
						$public_key_class,
						$self,
					);
				},
			),
			sign => native_function(
				name => 'sign',
				native => sub {
					my ( $self, $message ) = @_;
					return _signing_sign( $self, $message );
				},
			),
			sign_async => native_function(
				name => 'sign_async',
				native => sub {
					my ( $self, $message ) = @_;
					my $value = _signing_sign( $self, $message );
					return $runtime->_new_task(
						name => 'SigningKey.sign_async',
						status => 'fulfilled',
						result => $value,
					);
				},
			),
			export_private => native_function(
				name => 'export_private',
				native => sub {
					my ( $self, $options ) = @_;
					return _signing_export_private(
						$self,
						$options,
					);
				},
			),
		},
	);
	my $tls_identity_class;
	$tls_identity_class = native_class(
		name => 'TlsIdentity',
		static_methods => {
			from_pem => native_function(
				name => 'from_pem',
				native => sub {
					my (
						$self,
						$certificate_pem,
						$private_key_pem,
						$password,
					) = @_;
					return _tls_identity_from_pem(
						$tls_identity_class,
						$certificate_pem,
						$private_key_pem,
						$password,
					);
				},
			),
			from_pkcs12 => native_function(
				name => 'from_pkcs12',
				native => sub {
					my ( $self, $bytes, $password ) = @_;
					return _tls_identity_from_pkcs12(
						$tls_identity_class,
						$bytes,
						$password,
					);
				},
			),
		},
		methods => {
			certificate => native_function(
				name => 'certificate',
				native => sub {
					my ( $self ) = @_;
					return _tls_identity_certificate(
						$certificate_class,
						$self,
					);
				},
			),
			private_key => native_function(
				name => 'private_key',
				native => sub {
					my ( $self ) = @_;
					return _tls_identity_private_key(
						$signing_key_class,
						$self,
					);
				},
			),
		},
	);

	return {
		Secure => $secure_class,
		SecureRandom => $random_class,
		PasswordHash => $password_hash_class,
		KeyDerivation => $kdf_class,
		Cipher => $cipher_class,
		KeyAgreement => $key_agreement_class,
		SigningKey => $signing_key_class,
		Certificate => $certificate_class,
		PrivateKey => native_class( name => 'PrivateKey' ),
		PublicKey => $public_key_class,
		SealedBox => native_class( name => 'SealedBox' ),
		TlsIdentity => $tls_identity_class,
	};
}

1;

=pod

=head1 NAME

Zuzu::Module::Secure - std/secure bindings for ZuzuScript.

=head1 DESCRIPTION

Implements the Phase 1 C<std/secure> runtime-supported module skeleton.

=head1 COPYRIGHT AND LICENCE

B<< Zuzu::Module::Secure >> is copyright Toby Inkster.

It is free software; you may redistribute it and/or modify it under
the terms of either the Artistic License 1.0 or the GNU General Public
License version 2.

=cut