File Coverage

blib/lib/Crypt/MagicSignatures/Key.pm

Criterion	Covered	Total	%
statement	192	236	81.3
branch	86	110	78.1
condition	31	43	72.0
subroutine	35	36	97.2
pod	11	11	100.0
total	355	436	81.4

package Crypt::MagicSignatures::Key;
use strict;
use warnings;
use Scalar::Util qw/blessed/;
use Carp 'carp';

use v5.10.1;

our @CARP_NOT;
our $VERSION = '0.20';

our $DEFAULT_KEY_SIZE = 512;
our $MAX_GEN_ROUNDS = 100;

# Maximum number of tests for random prime generation = 100
# Range of valid key sizes = 512 - 4096
# Maximum number length for i2osp and os2ip = 30000

# This implementation uses a blessed array for speed.
# The array order is [n, e, d, size, emLen].

# TODO: Check extreme values for d, e, n, sign, verify
# TODO: Improve tests for _bitsize, b64url_encode, b64url_decode,
#       hex2b64url, b64url2hex

use overload '""' => sub { $_[0]->to_string }, fallback => 1;
use Digest::SHA qw/sha256 sha256_hex/;
use MIME::Base64 qw(decode_base64 encode_base64);

# Implement with GMP or PARI if existent
use Math::BigInt try => 'GMP,Pari';

# Export functions on request
use Exporter 'import';
our @EXPORT_OK = qw(b64url_encode b64url_decode);

# Primitive for Math::Prime::Util
sub random_nbit_prime ($);

our $GENERATOR;

# Load Math::Prime::Util and Math::Random::Secure
BEGIN {
  if (eval q{use Math::Prime::Util 'random_nbit_prime'; 1;}) {
    our $GENERATOR = 1;
  };
};


# Construct a new object
sub new {
  my $class = shift;
  my $self;

  # Message to pass to carp on parameter failure
  state $INVALID_MSG = 'Invalid parameters for MagicKey construction';

  # Check if the passed argument is an object
  if (my $bl = blessed($_[0])) {

    # It's already a MagicKey object - fine!
    return $_[0] if $bl->isa(__PACKAGE__);
  }

  # Do not support references
  if (ref $_[0]) {

    # Passed object or reference is invalid
    carp $INVALID_MSG;
    return;
  };

  # MagicKey in string notation
  if (@_ == 1 && index($_[0], 'RSA.') >= 0) {

    my $string = shift;

    # New object from parent class
    $self = bless [], $class;

    # Delete whitespace
    $string =~ tr{\t-\x0d }{}d;

    # Ignore mime-type prolog if given
    $string =~ s{^data\:application\/magic(?:\-public|\-private)?\-key[,;:]}{}i;

    # Split MagicKey
    my ($type, $mod, $exp, $private_exp) = split(/\./, $string);

    # RSA.modulus(n).exponent(e).private_exponent(d)?

    # MagicKey modulus is missing or invalid
    unless ($mod = _b64url_to_hex( $mod )) {
      carp $INVALID_MSG;
      return;
    };

    $exp = _b64url_to_hex( $exp ) if $exp;
    $private_exp = _b64url_to_hex( $private_exp ) if $private_exp;

    # Set modulus
    $self->n( $mod );

    # Set exponent
    $self->e( $exp ) if $exp;

    # Set private key
    $self->d( $private_exp ) if $private_exp;
  }

  # MagicKey defined by parameters
  elsif (@_ % 2 == 0) {
    my %param = @_;

    # RSA complete description
    if (defined $param{n}) {

      $self = bless [], $class;

      # Set attributes
      foreach (qw/n e d/) {
        $self->$_( $param{$_} ) if exists $param{$_};
      };

      # Modulus was not defined
      unless ($self->n) {
        carp $INVALID_MSG;
        return;
      };
    }

    # Generate new key
    else {

      carp 'Key generation in new() is DEPRECATED '
        . 'in favor of generate()';
      return $class->generate(@_);
    };
  }

  # Invalid request
  else {
    carp $INVALID_MSG;
    return;
  };

  # Get size (bitsize length of modulus)
  my $size = $self->size;

  # Size is to small
  if ($size < 512 || $size > 4096)  {
    carp 'Keysize is out of range';
    return;
  };

  # Set emLen (octet length of modulus)
  $self->_emLen( _octet_len( $self->n ) );

  return $self;
};


# Generate a new MagicKey
sub generate {

  # Generator not installed
  unless ($GENERATOR) {
    carp 'No Math::Prime::Util installed';
    return;
  };

  # Check for passing of
  my ($class, %param) = @_;

  # Define key size
  my $size = $param{size};

  # Size is given
  if ($size) {

    # Key size is too short or impractical
    if ($size < 512 || $size > 4096 || $size % 2) {
      carp "Key size $size is invalid";
      return;
    };
  }

  # Default size
  else {
    $size = $DEFAULT_KEY_SIZE;
  };

  # Public exponent
  my $e = $param{e};

  # Partial size
  my $psize = int( $size / 2 );

  my $n;

  # Maximum number of rounds
  my $m = $MAX_GEN_ROUNDS;

  my ($p, $q);

  # Start calculation of combining primes
 CALC_KEY:

  # Run as long as allowed
  while ($m > 0) {

    # Fetch random primes p and q
    # Uses Bytes::Random::Secure by default
    $p = random_nbit_prime($psize);
    $q = random_nbit_prime($psize);

    # Fetch a new prime if both are equal
    while ($p == $q) {
      $q = random_nbit_prime($psize);
      unless (--$m > 0) {
        $p = $q = Math::BigInt->bzero;
        last;
      };
    };

    # Calculate modulus
    $n = $p * $q;

    # Bitsize is correct based on given size
    last if _bitsize($n) == $size;

    $m--;
  };

  unless ($m > 0) {
    carp 'Maximum rounds for key generation is reached';
    return;
  };

  # Bless object
  my $self = bless [], $class;

  # Set e
  $self->e($e) if $e;

  # Calculate phi
  my $phi = ($p - 1) * ($q - 1);

  # Calculate multiplicative inverse of e modulo phi
  my $d = $self->e->copy->bmodinv($phi);

  # $d is too short
  goto CALC_KEY if _bitsize($d) < $size / 4;

  # Store d
  $self->d($d);

  # Store n
  $self->n($n);

  # Set emLen (octet length of modulus)
  $self->_emLen( _octet_len( $self->n ) );

  return $self;
};



# Get or set modulus
sub n {
  my $self = shift;

  # Get value
  return $self->[0] unless $_[0];

  # Set value
  my $n = Math::BigInt->new( shift );

  # n is not a number
  if ($n->is_nan) {
    carp 'n is not a number';
    return;
  };

  # Delete precalculated emLen and size
  $#{$self} = 2;

  $self->[0] = $n;
};


# Get or set public exponent
sub e {
  my $self = shift;

  # Get value
  return ($self->[1] //= Math::BigInt->new('65537')) unless $_[0];

  # Set value
  my $e = Math::BigInt->new( shift );

  # e is not a number
  if ($e->is_nan) {
    carp 'e is not a number';
    return;
  };

  $self->[1] = $e;
};


# Get or set private exponent
sub d {
  my $self = shift;

  # Get value
  return ($self->[2] // undef) unless $_[0];

  # Set value
  my $d = Math::BigInt->new( shift );

  # d is not a number
  if ($d->is_nan) {
    carp 'd is not a number';
    return;
  };

  $self->[2] = $d;
};


# Get key size
sub size {
  # return unless $_[0]->n;
  $_[0]->[3] // ($_[0]->[3] = _bitsize($_[0]->n));
};


# Sign a message
sub sign {
  my ($self, $message) = @_;

  unless ($self->d) {
    carp 'Unable to sign without a private key';
    return;
  };

  b64url_encode(
    _sign_emsa_pkcs1_v1_5($self, $message)
  );
};


# Verify a signature for a message (sig base)
sub verify {
  my ($self,
      $message,
      $encoded_message) =  @_;

  # Missing parameters
  unless ($encoded_message && $message) {
    carp 'No signature or message given';
    return;
  };

  # Delete whitespace and padding
  $encoded_message =~ tr{=\t-\x0d }{}d;

  # Invalid message
  unless ($encoded_message) {
    carp 'No signature given';
    return;
  };

  # No modulus
  # return unless $self->n;

  # Verify message
  _verify_emsa_pkcs1_v1_5(
    $self,
    $message,
    # _b64url_to_hex( $encoded_message )
    b64url_decode($encoded_message)
  );
};



# Return MagicKey-String (public only)
sub to_string {
  my $self = shift;

  # return '' unless $n; # Shouldn't be possible

  # Convert modulus and exponent and add to component array
  my @array = ('RSA', _hex_to_b64url($self->n), _hex_to_b64url($self->e));

  if ($_[0] && $self->d) {
    push(@array, _hex_to_b64url($self->d));
  };

  # Specification is not clear about $mkey =~ s/=+//g;
  join('.', @array);
};


# Returns the b64 urlsafe encoding of a string
sub b64url_encode {
  return '' unless $_[0];

  my $v = $_[0];

  utf8::encode $v if utf8::is_utf8 $v;
  $v = encode_base64($v, '');
  $v =~ tr{+/\t-\x0d }{-_}d;

  # Trim padding or not
  $v =~ s/\=+$// unless (defined $_[1] ? $_[1] : 1);
  $v;
};


# Returns the b64 urlsafe decoded string
sub b64url_decode {
  my $v = shift;
  return '' unless $v;

  $v =~ tr{-_}{+/};

  my $padding;

  # Add padding
  if ($padding = (length($v) % 4)) {
    $v .= chr(61) x (4 - $padding);
  };

  decode_base64($v);
};


# Get octet length of n
sub _emLen {
  # return 0 unless $_[0]->n;
  ($_[0]->[4] // ($_[0]->[4] = _octet_len( $_[0]->n )));
};


# Sign with emsa padding
sub _sign_emsa_pkcs1_v1_5 {
  # http://www.ietf.org/rfc/rfc3447.txt [Ch. 8.1.1]

  # key, message
  my ($K, $M) = @_;

  # octet length of n
  my $k = $K->_emLen;

  # encode message (Hash digest is always 'sha-256')
  my $EM = _emsa_encode($M, $k) or return;

  _i2osp(_rsasp1($K, _os2ip($EM)), $k);
};


# Verify with emsa padding
sub _verify_emsa_pkcs1_v1_5 {
  # http://www.ietf.org/rfc/rfc3447.txt [Ch. 8.2.2]

  # key, message, signature
  my ($K, $M, $S) = @_;

  my $k = $K->_emLen;

  # The length of the signature is not
  # equivalent to the length of the RSA modulus
  # TODO: This probably needs to check octetlength
  if (length($S) != $k) {
    carp 'Invalid signature';
    return;
  };

  my $s = _os2ip($S);
  my $m = _rsavp1($K, $s) or return;
  my $EM = _emsa_encode($M, $k) or return;

  return $EM eq _i2osp($m, $k);
};


# RSA signing
sub _rsasp1 {
  # http://www.ietf.org/rfc/rfc3447.txt [Ch. 5.2.1]

  # Key, message
  my ($K, $m) = @_;

  if ($m >= $K->n || $m < 0) {
    carp 'Message representative out of range';
    return;
  };

  return $m->bmodpow($K->d, $K->n);
};


# RSA verification
sub _rsavp1 {
  # http://www.ietf.org/rfc/rfc3447.txt [Ch. 5.2.2]

  # Key, signature
  my ($K, $s) = @_;

  # Is signature in range?
  if ($s > $K->n || $s < 0) {
    carp 'Signature representative out of range';
    return;
  };

  return $s->bmodpow($K->e, $K->n);
};


# Create code with emsa padding (only sha-256 support)
sub _emsa_encode {
  # http://www.ietf.org/rfc/rfc3447.txt [Ch. 9.2]

  my ($M, $emLen) = @_;

  # No message given
  return unless $M;

  # Hash digest is always 'sha-256'

  # Create Hash with DER padding
  my $H = sha256($M);
  my $T = "\x30\x31\x30\x0d\x06\x09\x60\x86\x48\x01" .
          "\x65\x03\x04\x02\x01\x05\x00\x04\x20" . $H;
  my $tLen = length( $T );

  if ($emLen < $tLen + 11) {
    carp 'Intended encoded message length too short';
    return;
  };

  return "\x00\x01" . ("\xFF" x ($emLen - $tLen - 3)) . "\x00" . $T;
};


# Convert from octet string to bigint
sub _os2ip {
  # Based on Crypt::RSA::DataFormat
  # See also Convert::ASN1
  my $os = shift;

  my $l = length $os;
  return if $l > 30_000;

  state $base = Math::BigInt->new(256);
  my $result = Math::BigInt->bzero;
  for (0 .. $l - 1) {
    # Maybe optimizable
    $result->badd(
      int(ord(unpack "x$_ a", $os)) * ($base ** int($l - $_ - 1))
    );
  };
  $result;
};


# Convert from bigint to octet string
sub _i2osp {
  # Based on Crypt::RSA::DataFormat
  # See also Convert::ASN1

  my $num = Math::BigInt->new(shift);

  return if $num->is_nan || $num->length > 30_000;

  my $l = shift || 0;
  state $base = Math::BigInt->new(256);

  my $result = '';

  if ($l && $num > ( $base ** $l )) {
    carp 'i2osp error - Integer is to short';
    return;
  };

  do {
    my $r = $num % 256;
    $num = ($num - $r) / 256;
    $result = chr($r) . $result;
  } until ($num < 256);

  $result = chr($num) . $result if $num != 0;

  if (length($result) < $l) {
    $result = chr(0) x ($l - length($result)) . $result;
  };

  $result;
};


# Returns the octet length of a given integer
sub _octet_len {
  return Math::BigInt->new( _bitsize( shift ))
    ->badd(7)
    ->bdiv(8)
    ->bfloor;
};


# Returns the bitlength of the integer
sub _bitsize {
  my $int = Math::BigInt->new( $_[0] );
  return 0 unless $int;
  # Trim leading '0b'
  length( $int->as_bin ) - 2;
};


# base64url to hex number
sub _b64url_to_hex {
  # Based on
  # https://github.com/sivy/Salmon/blob/master/lib/Salmon/
  #         MagicSignatures/SignatureAlgRsaSha256.pm

  # Decode and convert b64url encoded hex number
  my $b64 = b64url_decode( shift ) or return;
  Math::BigInt->new('0x' . unpack( 'H*', $b64));
};


# hex number to base64url
sub _hex_to_b64url {
  # https://github.com/sivy/Salmon/blob/master/lib/Salmon/
  #         MagicSignatures/SignatureAlgRsaSha256.pm

  # Trim leading '0x'
  my $num = substr(Math::BigInt->new( shift )->as_hex, 2);

  # Add leading zero padding
  $num = ( ( ( length $num ) % 2 ) > 0 ) ? '0' . $num : $num;

  # Encode number using b64url
  b64url_encode( pack( 'H*', $num ) );
};


1;


__END__