view release on metacpan or  search on metacpan

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

sub _body_ref ($args) {
   my $body = $args->{body};
   return \$args->{body} unless ref $body;
   fail 400, 'body must be a scalar or a reference to a scalar'
      unless ref($body) eq 'SCALAR';
   return $body;
}

# AWS trims and collapses spaces, so ASCII whitespace only (/a): with
# unicode_strings, \s would also take the bytes 0xA0 and 0x85 of UTF-8 text
sub _trim ($v) {
   $v =~ s{\A\s+|\s+\z}{}gmxa;  # remove leading/trailing whitespaces
   $v =~ s{\s+}{ }gas;          # normalize internal whitespaces
   return $v;
}

# (host, path, query) of a url; the host is lowercased and the port is
# removed if it is the default one, as user agents do before sending it
sub _split_url ($url) {
   # every part is optional, so this always matches
   my ($scheme, $auth, $path, $query) =
      $url =~ m{\A (?: ([A-Za-z][A-Za-z0-9+.-]*) :// ([^/?\#]*) )?
                   ([^?\#]*) (?: \? ([^\#]*) )? }x;
   fail 400, 'url path must start with "/": give an absolute url, or a path with a Host header'
      if length $path && $path !~ m{\A/};
   fail 400, 'url query must not contain "+": write %20 for a space, %2B for a plus sign'
      if defined $query && $query =~ m{\+};
   return (undef, $path, $query) unless defined $auth && length $auth;

   fail 400, 'url must not have user information (user@host)' if $auth =~ m{@};
   my ($host, $port) = $auth =~ m{\A
         (\[[0-9A-Fa-f:.]+\] | [A-Za-z0-9._~-]+)  # host
         (?: : ([0-9]*) )?   # optional port
      \z}x or fail 400, 'invalid url: ' . shown($auth);
   $host = lc $host;
   if (length($port // '')) {
      $port += 0;
      fail 400, "invalid port: $port" if $port < 1 || $port > 65535;
      my $lcscheme = lc($scheme);
      my $default = $lcscheme eq 'https' ? 443
         : $lcscheme eq 'http'           ? 80
         :                                 0;
      $host .= ':' . $port if $port != $default;
   }
   return ($host, $path, $query);
}

sub _shown_list (@list) {
   return join ', ',
      map { join '', q{"}, shown($_), q{"} }
      sort { $a cmp $b } @list;
}


use namespace::clean;    # imported or plain functions must not become methods


has service => (is => 'ro');
has region  => (is => 'ro');

# credentials: {access_key_id, secret_access_key, session_token?}
has credentials => (is => 'ro', coerce => \&_copy, isa => sub { _hash_or_undef(credentials => @_) });

# Certificate-based variant, as used by IAM Roles Anywhere.
#   certificate / certificate_file: PEM or DER text, or path of a file with it
#   chain / chain_files: optional arrayref of PEM/DER intermediate certificates,
#                or of paths of files with them; a PEM item can be a bundle.
#                chain can also be a plain string: a PEM-encoded bundle, and
#                chain_files a plain string: the path of one file
#   key_type:    'RSA' or 'ECDSA'
#   signer:      sub ($bytes_to_sign) -> signature (DER for ECDSA, PKCS#1 v1.5
#                for RSA), computed with SHA-256; or, alternatively,
#   private_key_file / private_key: PEM or DER key (path or content), signed
#                with CryptX; private_key_password if it is encrypted
has x509 => (is => 'ro', coerce => \&_copy, isa => sub { _hash_or_undef(x509 => @_) });

# S3 is the odd one out: this is the only place that knows how to tell. S3
# Object Lambda, S3 on Outposts and S3 Express sign with names of their own,
# under the same rules.
has _is_s3 => (is => 'lazy', init_arg => undef);
sub _build__is_s3 ($self) { $self->service =~ m{\As3(?:-object-lambda|-outposts|express)?\z} }

has double_encode  => (is => 'ro', lazy => 1, default => sub ($self) { !$self->_is_s3 });
has normalize_path => (is => 'ro', lazy => 1, default => sub ($self) { !$self->_is_s3 });
has payload_header => (is => 'ro', lazy => 1, default => sub ($self) { $self->_is_s3 });

# FIXME review this decision: "undef" in Perl has a history of meaning
# "false" but here we're saying that it means "do the default".
# an undefined option is like a missing one: the default applies
around BUILDARGS => sub ($orig, $class, @args) {
   my $args = $class->$orig(@args);
   defined $args->{$_} or delete $args->{$_}
      for qw< double_encode normalize_path payload_header >;
   return $args;
};

# The variant in use, credentials or x509, which knows how to sign and what
# goes with the request: see AWS::Signature::V4::Credentials and ::X509
has _auth => (is => 'lazy', init_arg => undef);

sub BUILD ($self, $args) {
   for my $name (qw< service region >) {
      my $value = $self->$name;
      defined($value) || fail 400, qq{missing parameter "$name"};
      fail 400, qq{invalid "$name" } . shown($value)
         . ': only letters, digits, ".", "_" and "-" are allowed'
         unless $value =~ m{\A[-A-Za-z0-9._]+\z};
   }

   # make sure the caller provides us *exactly* one of credentials/X509
   my $x509_params = $self->x509;
   my $credentials_params = $self->credentials;
   fail 400, 'provide either "credentials" or "x509", not both'
      if $credentials_params && $x509_params;
   fail 400, 'provide (exactly) one of "credentials" or "x509"'
      unless $credentials_params || $x509_params;

   $self->_auth;    # force building and fail fast

   # after using the parameters, we get rid of sensitive data in the input
   # hash for X509
   delete($x509_params->{$_}) for qw< private_key private_key_password >;

   return;
}

sub _build__auth ($self) {
   return $self->credentials
      ? AWS::Signature::V4::Credentials->new($self->credentials->%*)
      : AWS::Signature::V4::X509->new($self->x509->%*);
}

sub algorithm ($self) { $self->_auth->algorithm }

# sign(method => ..., url => ..., headers => ..., body => ..., time => ...)
# Returns a hashref:
#   headers:        all headers to set on the request (name => value)
#                   including Authorization, X-Amz-Date, Host if missing...
#   authorization:  value of the Authorization header
#   signature, canonical_request, string_to_sign, signed_headers, scope
sub sign ($self, @args) {
   my %args = _args(sign => @args);

   # some arguments apply to the "payload" variant and some to the
   # "streaming" variant only, we need some more input validation.
   # $not_allowed below collects the name of the parameter that are not
   # allowed for the variant that is requested.
   my $streaming = $args{streaming};
   my $not_allowed = ALLOWED_ARGS->{$streaming ? 'payload' : 'streaming'};
   my @misplaced = grep { exists $args{$_} } $not_allowed->@*;
   fail 400, qq{"$misplaced[0]" }
         . ($streaming ? 'does not apply to streaming' : 'needs streaming')
      if @misplaced;

   my $method = _method($args{method} // fail 400, 'missing parameter "method"');
   my ($h, $path, $query, $amzdate, $scope) = $self->_request(\%args);
   $h->{'x-amz-date'} = $amzdate;
   my $given = _given_payload_hash($h);

   my ($unsigned_chunks, @trailer_names);
   my $payload_hash;
   if ($streaming) {
      fail 400, 'streaming must be false, 1, "signed", or "unsigned"'
         unless $streaming =~ m{\A(?:1|signed|unsigned)\z};
      $unsigned_chunks = $streaming eq 'unsigned';
      @trailer_names = _trailer_names(\%args);
      fail 400, 'unsigned streaming needs "checksum" or "trailers"'
         if $unsigned_chunks && !@trailer_names;
      fail 400, 'signed streaming needs the credentials variant, not x509'
         if !$unsigned_chunks && !$self->_auth->can_sign_chunks;
      my $len = $args{decoded_content_length}
         // fail 400, 'streaming needs "decoded_content_length"';
      fail 400, 'decoded_content_length must be a non-negative integer'
         unless $len =~ m{\A[0-9]+\z};
      $payload_hash =
           $unsigned_chunks ? 'STREAMING-UNSIGNED-PAYLOAD-TRAILER'
         : @trailer_names   ? 'STREAMING-AWS4-HMAC-SHA256-PAYLOAD-TRAILER'
         :                    'STREAMING-AWS4-HMAC-SHA256-PAYLOAD';
      $h->{'x-amz-decoded-content-length'} = $len;
      $h->{'x-amz-trailer'} = join ',', @trailer_names if @trailer_names;

      # whatever the caller has, e.g. gzip, then aws-chunked: RFC 9110 wants
      # the encodings in the order they were applied, and this one is the
      # outermost, applied to the already-gzipped data (as botocore does)
      my @encodings = grep { length && lc($_) ne 'aws-chunked' }
         map { _trim($_) } split m{,}, $h->{'content-encoding'} // '';
      $h->{'content-encoding'} = join ',', @encodings, 'aws-chunked';
   }
   else {
      $payload_hash = _payload_hash(\%args);
   }
   $payload_hash = _agree($payload_hash, $given, sha256_hex(''));
   $h->{'x-amz-content-sha256'} = $payload_hash
      if $self->payload_header || $streaming || defined $given || !_is_sha256($payload_hash);

   my %extra = $self->_auth->extra_fields;
   $h->{lc $_} = $extra{$_} for keys %extra;
   _check_header_values($h);    # before they end up in the canonical request

   my @signed = _signed_headers($h, $args{signed_headers}
      // [grep { ! UNSIGNED->{$_} } keys $h->%*], $streaming ? 'content-encoding' : ());
   my $r = $self->_signed($method, $path, _canonical_query($query), $h,
      \@signed, $payload_hash, $amzdate, $scope);

   my $credential = $self->_auth->credential_id . "/$scope";
   $r->{authorization} = $self->algorithm . " Credential=$credential, "
      . "SignedHeaders=$r->{signed_headers}, Signature=$r->{signature}";
   _check_header_value(authorization => $r->{authorization});
   $r->{headers} = {$h->%*, authorization => $r->{authorization}};

   $r->{chunker} = AWS::Signature::V4::Chunker->new(
      ($unsigned_chunks ? () : (key => $self->_auth->signing_key($scope))),
      signed => !$unsigned_chunks, amzdate => $amzdate,
      scope => $scope, previous => $r->{signature},
      expected => $args{decoded_content_length},
      checksum => $args{checksum}, trailer_names => \@trailer_names,
   ) if $streaming;
   return $r;
}

# presign(method => 'GET', url => ..., expires => 3600, time => ...)
# Returns a hashref:
#   url:            the URL, with the signature in its query string
#   headers:        headers that the client must send with it (Host, ...)
#   signature, canonical_request, string_to_sign, signed_headers, scope
sub presign ($self, @args) {
   my %args = _args(presign => @args);
   my $method = _method($args{method} // 'GET');
   my ($h, $path, $query, $amzdate, $scope) = $self->_request(\%args);