view release on metacpan or  search on metacpan

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

package AWS::Signature::V4;
{ our $VERSION = '0.004' }

use v5.24;
use Moo;
use experimental qw< signatures >;
use Digest::SHA qw< sha256_hex >;
use POSIX qw< strftime >;
use Scalar::Util qw< openhandle >;

use AWS::Signature::V4::Error qw< fail shown >;
use AWS::Signature::V4::Checksum ();
use AWS::Signature::V4::Chunker ();
use AWS::Signature::V4::Credentials ();
use AWS::Signature::V4::X509 ();

use constant {

   # Headers that intermediaries commonly rewrite or that should never be
   # signed
   AUTH_PARAM => +{
      map { lc($_) => $_ } qw<
         X-Amz-Algorithm
         X-Amz-Credential
         X-Amz-Date
         X-Amz-Expires
         X-Amz-Security-Token
         X-Amz-Signature
         X-Amz-SignedHeaders
         X-Amz-X509
         X-Amz-X509-Chain
      >
   },

   # Headers that intermediaries commonly rewrite or that should never be
   # signed
   UNSIGNED => +{
      map { lc($_) => 1 } qw<
         Authorization
         Connection
         Expect
         Keep-Alive
         Proxy-Authenticate
         Proxy-Authorization
         Proxy-Connection
         TE
         Trailer
         Transfer-Encoding
         Upgrade
         User-Agent
         X-Amzn-Trace-Id
      >
   },

   # the arguments of some methods; anything else is an error
   ALLOWED_ARGS => +{
      encoded_length => +{
         map { $_ => 1 } qw<
            checksum
            signed
            trailers
         >
      },

      sign => +{
         map { $_ => 1 } qw<
            body
            body_fh
            checksum
            decoded_content_length
            headers
            method
            payload_hash
            signed_headers
            streaming
            time
            trailers
            unsigned_payload
            url
         >
      },

      presign => +{
         map { $_ => 1 } qw<
            body
            body_fh
            expires
            headers
            method
            payload_hash
            signed_headers
            time
            unsigned_payload
            url
         >
      },

      payload => [ qw< body body_fh payload_hash unsigned_payload > ],
      streaming => [ qw< decoded_content_length checksum trailers > ],
   },

   MAX_EPOCH => 253402300799,    # 9999-12-31T23:59:59Z
};

sub _copy ($value) { ref $value eq 'HASH' ? {$value->%*} : $value }

sub _hash_or_undef ($name, $value) {
   fail 400, qq{"$name" must be a hash reference}
      unless !defined $value || ref $value eq 'HASH';
}

# arguments of sign/presign as a hash: name => value pairs or a hash
# reference; undefined values are like missing ones, unknown names an error
sub _args ($what, @args) {
   @args = $args[0]->%* if @args == 1 && ref $args[0] eq 'HASH';
   fail 400, "$what takes name => value pairs or a hash reference" if @args % 2;
   my %args = @args;
   defined $args{$_} or delete $args{$_} for keys %args;

   # go looking for argument names that are outside the allowed ones
   my $allowed = ALLOWED_ARGS->{$what}
      or die "ALLOWED_ARGS does not support <$what>";
   if (my @l = grep { ! $allowed->{$_} } keys(%args)) {
      fail 400, "unsupported for $what: " . _shown_list(@l);
   }
   return %args;
}

sub _check_url ($url) {
   defined $url or fail 400, 'missing parameter "url"';
   fail 400, 'url must be a string' if ref $url;
   fail 400, 'url must be ASCII: percent-encode non-ASCII characters'
      if $url =~ m{[^\x00-\x7F]};
   fail 400, 'url must not contain control characters: percent-encode them'
      if $url =~ m{[\x00-\x1F\x7F]};
   return $url;
}

# an HTTP token (RFC 9110), like header names and methods
sub _is_token ($s) {
   defined $s && !ref $s && $s =~ m{\A[!#\$%&'*+.^_`|~0-9A-Za-z-]+\z};
}

sub _method ($method) {
   fail 400, 'invalid method ' . shown($method) . ': it must be an HTTP token'
      unless _is_token($method);
   return uc $method;
}

sub _is_count ($n) {
   defined $n && !ref $n && $n =~ m{\A (?: 0 | [1-9][0-9]* ) \z}mxs;
}

# headers as a hash or array of pairs, to a hash with lowercase names;
# undefined values are skipped, like missing headers
sub _headers_hash ($in) {
   my @pairs;
   if (ref $in eq 'HASH') {
      @pairs = map { $_ => $in->{$_} } sort keys $in->%*;    # repeatable order
   }
   elsif (ref $in eq 'ARRAY') {
      fail 400, '"headers" as an array reference must hold name => value pairs'
         if $in->@* % 2;
      @pairs = $in->@*;
   }
   elsif (defined $in) {
      fail 400, '"headers" must be a hash or array reference';
   }
   my %h;
   while (my ($k, $v) = splice @pairs, 0, 2) {
      _check_header_name($k);
      my @values = grep { defined } ref $v eq 'ARRAY' ? $v->@* : $v;
      _check_header_value($k, $_) for @values;