view release on metacpan or  search on metacpan

lib/AWS/Signature/V4/X509.pm  view on Meta::CPAN

package AWS::Signature::V4::X509;
use v5.24;
use experimental qw< signatures >;
use Moo;
use MIME::Base64 qw< encode_base64 decode_base64 >;
use Math::BigInt;

use AWS::Signature::V4::Error qw< fail shown >;

# a plain string or an arrayref of plain strings => arrayref
sub _items ($value, $name) {
   $value = [$value] unless ref $value;
   ref $value eq 'ARRAY'
      or fail 400, "x509/$name must be a string or an array reference";
   for my $item ($value->@*) {
      fail 400, "x509/$name must hold strings" if !defined $item || ref $item;
   }
   return $value;
}

sub _b64 ($der) { encode_base64($der, '') }

# ---- X.509 helpers (no external dependencies) ------------------------------

sub _slurp ($file) {
   open my $fh, '<:raw', $file or fail 400, 'open(' . shown($file) . "): $!";
   local $/;
   my $data = <$fh>;
   close $fh;
   return $data;
}

sub _to_ders ($cert) {    # PEM bundles hold many certificates
   return _check_der($cert) unless $cert =~ m{-----BEGIN};
   my @ders = map { decode_base64($_) }
      $cert =~ m{-----BEGIN CERTIFICATE-----(.*?)-----END CERTIFICATE-----}sg;
   @ders or fail 400, 'no CERTIFICATE block in PEM';
   return map { _check_der($_) } @ders;
}

sub _to_der ($cert) {
   return _check_der($cert) unless $cert =~ m{-----BEGIN};
   $cert =~ m{-----BEGIN CERTIFICATE-----(.*?)-----END CERTIFICATE-----}s
      or fail 400, 'no CERTIFICATE block in PEM';
   return _check_der(decode_base64($1));
}

# a certificate is a DER SEQUENCE that fits exactly in the data
sub _check_der ($der) {
   my ($tag, undef, $end) = _tlv($der, 0);
   fail 400, 'not a DER-encoded certificate'
      unless $tag == 0x30 && $end == length $der;
   return $der;
}

# read one DER TLV at $off => (tag, content_start, content_end)
sub _tlv ($der, $off) {
   my $max = length $der;
   $off + 2 <= $max or fail 400, 'truncated certificate';
   my $tag = ord substr $der, $off++, 1;
   my $len = ord substr $der, $off++, 1;
   if ($len & 0x80) {    # long form, DER wants it minimal and definite
      my $n = $len & 0x7F;
      fail 400, 'not a DER-encoded certificate' if $n == 0 || $n > 4;
      $off + $n <= $max or fail 400, 'truncated certificate';
      $len = 0;
      $len = ($len << 8) | ord substr($der, $off++, 1) for 1 .. $n;
      fail 400, 'not a DER-encoded certificate'
         if $len < 0x80 || $len < 1 << 8 * ($n - 1);
   }
   $off + $len <= $max or fail 400, 'truncated certificate';
   return ($tag, $off, $off + $len);
}

# Certificate ::= SEQ { tbs SEQ { [0] version?, INTEGER serial, ... }, ... }
sub _certificate_serial ($der) {
   my (undef, $cs) = _tlv($der, 0);
   my (undef, $ts) = _tlv($der, $cs);
   my ($tag, $s, $e) = _tlv($der, $ts);
   ($tag, $s, $e) = _tlv($der, $e) if $tag == 0xA0;    # skip explicit version
   fail 400, 'cannot find certificate serial number' unless $tag == 0x02;
   return Math::BigInt->from_hex(unpack 'H*', substr $der, $s, $e - $s)
      ->bstr;   # DER integers here are positive; leading 0x00 is harmless
}

# The error of CryptX, without the location and the backtrace that Carp adds
# when verbose (the arguments in it may hold the password), escaped as caller
# input because it can hold the file name.
sub _clean_error ($e) {
   $e =~ s{\n\t.*}{}s;    # the backtrace lines start with a tab
   $e =~ s{\s+at \S+ line \d+\.?\s*\z}{};
   return shown($e =~ s{\A\s+|\s+\z}{}gr);
}

# $key is a file name or a scalar reference to the PEM text
sub _cryptx_signer ($algo, $key, $password = undef) {
   my $class = $algo eq 'RSA' ? 'Crypt::PK::RSA' : 'Crypt::PK::ECC';
   eval "require $class; 1" or fail 500, "cannot load $class";
   my @args = ($key, defined $password ? ($password) : ());
   my $pk = eval {
      # no backtrace, e.g. from -MCarp=verbose or Carp::Always, with the password
      local $Carp::Verbose = 0;
      local $Carp::MaxArgNums = -1;
      local $SIG{__DIE__};
      $class->new(@args);
   } // fail 400, "cannot load the private key: " . _clean_error($@);
   fail 400, 'the key is not a private key' unless $pk->is_private;
   return $algo eq 'RSA'