view release on metacpan or  search on metacpan

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

}

# the handle is hashed from where it is to its end, then put back there
sub _fh_hash ($fh) {
   openhandle($fh) or fail 400, '"body_fh" must be an open filehandle';
   fail 400, '"body_fh" must be a binary handle: binmode it'
      if grep { m{\A(?:encoding|utf8|crlf)} } PerlIO::get_layers($fh);
   my $pos = tell $fh;
   fail 400, '"body_fh" must be seekable (a file, not a pipe or a socket)'
      unless $pos >= 0 && seek $fh, $pos, 0;
   my $sha = Digest::SHA->new(256);
   eval { $sha->addfile($fh); 1 } or fail 400, qq{"body_fh" cannot be read: $!};
   seek $fh, $pos, 0 or fail 400, qq{"body_fh" cannot be put back where it was: $!};
   return $sha->hexdigest;
}

# names of the trailers: built-in checksum first, then the declared ones
sub _trailer_names ($args) {
   my @names;
   if (defined(my $algo = $args->{checksum})) {
      fail 400, 'unknown checksum ' . shown($algo) . ' (supported: '
         . join(', ', AWS::Signature::V4::Checksum->supported_algorithms) . ')'
         unless AWS::Signature::V4::Checksum->is_supported_algorithm($algo);
      push @names, "x-amz-checksum-$algo";
   }
   my $trailers = $args->{trailers} // [];
   fail 400, '"trailers" must be an array reference' unless ref $trailers eq 'ARRAY';
   for my $name (map { lc($_ // '') } $trailers->@*) {
      _check_trailer_name($name);
      fail 400, "trailer '$name' declared twice" if grep { $_ eq $name } @names;
      push @names, $name;
   }
   return @names;
}

sub _check_trailer_name ($name) {
   fail 400, 'invalid trailer name ' . shown($name) unless $name =~ m{\A[a-z0-9][a-z0-9-]*\z};
}

sub _canonical_query ($query) {
   return '' unless defined $query && length $query;
   my @pairs = map {
      my ($k, $v) = split /=/, $_, 2;
      [_uri_encode(_uri_decode($k)), _uri_encode(_uri_decode($v // ''))];
   } grep { length } split /&/, $query;
   return join '&', map { "$_->[0]=$_->[1]" }
      sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @pairs;
}

sub _uri_encode ($s) {
   $s =~ s{([^A-Za-z0-9\-_.~])}{sprintf '%%%02X', ord $1}gmse;
   return $s;
}

sub _uri_decode ($s) {
   $s =~ s{%([0-9A-Fa-f]{2})}{chr hex $1}gse;
   return $s;
}

# body is either a plain scalar or a reference to one; only in the latter
# case the caller's data is not copied at all
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);

   my $expires = $args{expires} // 3600;
   fail 400, 'expires must be an integer between 1 and 604800 seconds'
      unless $expires =~ m{\A[0-9]+\z} && $expires >= 1 && $expires <= 604800;

   for my $pair (split m{&}, $query // '') {
      my ($name) = split m{=}, $pair, 2;
      my $known = AUTH_PARAM->{lc _uri_decode($name // '')} or next;
      fail 400, "url already carries $known: presign adds it";
   }

   # S3 takes UNSIGNED-PAYLOAD for granted in presigned URLs, the others the
   # hash of the body they get: anything else needs the header, signed
   my $given = _given_payload_hash($h);
   my $payload_hash = _agree(_payload_hash(\%args), $given,

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

   return (\%h, $path, $query, $amzdate, $scope);
}

# canonical request, string to sign and signature, as returned to the caller
sub _signed ($self, $method, $path, $canonical_query, $h, $signed, $payload_hash, $amzdate, $scope) {
   my $signed_headers = join ';', $signed->@*;
   my $canonical_request = join "\n",
      $method,
      $self->_canonical_path($path),
      $canonical_query,
      join('', map { "$_:" . _trim($h->{$_}) . "\n" } $signed->@*),    # ends with blank line
      $signed_headers,
      $payload_hash;
   my $string_to_sign = join "\n",
      $self->algorithm, $amzdate, $scope, sha256_hex($canonical_request);
   return {
      signature         => $self->_auth->signature($scope, $string_to_sign),
      signed_headers    => $signed_headers,
      scope             => $scope,
      canonical_request => $canonical_request,
      string_to_sign    => $string_to_sign,
   };
}

# size of an aws-chunked body: every chunk but the last one is $chunk_size
#   signed => 1 (default) or 0, checksum => $algo, trailers => {name => length}
sub encoded_length ($class, $decoded, $chunk_size, @args) {
   fail 400, 'the decoded size must be a non-negative integer'
      unless _is_count($decoded);
   fail 400, 'the chunk size must be a positive integer'
      unless _is_count($chunk_size) && $chunk_size > 0;

   fail 400, 'encoded_length named options must be name => value pairs' if @args % 2;
   my %opts = _args(encoded_length => @args);

   my $signed = exists($opts{signed}) ? ($opts{signed} || 0) : 1;
   fail 400, 'signed must be false, 1, "signed", or "unsigned"'
      if ref $signed || $signed !~ m{\A(?:1|0|signed|unsigned|)\z}mxs;
   $signed = $signed eq '1' || $signed eq 'signed';

   my $trailer = 0;  # sum of length of each trailer line "name:value\r\n"
   my %seen; # catch duplicates
   if (defined(my $algo = $opts{checksum})) {
      my ($name) = _trailer_names({checksum => $algo});
      $seen{$name} = 1;
      $trailer += length($name) + 1 + AWS::Signature::V4::Checksum->encoded_size($algo) + 2;
   }
   my $declared = $opts{trailers} // {};
   fail 400, '"trailers" must be a hash reference from names to lengths'
      unless ref $declared eq 'HASH';
   for my $given (sort keys $declared->%*) {
      my $name = lc $given;
      _check_trailer_name($name);
      # sign() refuses the same repetition, so do not count a line twice
      fail 400, "trailer '$name' declared twice" if $seen{$name}++;
      fail 400, 'the length of trailer ' . shown($given) . ' must be a non-negative integer'
         unless _is_count($declared->{$given});
      $trailer += length($name) + 1 + $declared->{$given} + 2;
   }

   my $chunk = sub ($size) {    # everything around the data of a chunk
      length(sprintf '%x', $size) + ($signed ? 17 + 64 : 0) + 2 + 2;
   };
   my $total = 0;
   my $full = int($decoded / $chunk_size);
   $total += $full * ($chunk->($chunk_size) + $chunk_size);
   my $rest = $decoded - $full * $chunk_size;
   $total += $chunk->($rest) + $rest if $rest;

   # final chunk: "0[;chunk-signature=..]\r\n", trailers, [signature line,] "\r\n"
   $total += 1 + ($signed ? 17 + 64 : 0) + 2 + $trailer + 2;
   $total += length('x-amz-trailer-signature') + 1 + 64 + 2 if $signed && $trailer;
   return $total;
}

# the path is empty or starts with "/", see _split_url
sub _canonical_path ($self, $path) {
   $path = '/' unless length $path;
   my $trailing = $path =~ m{/\z} && $path ne '/';
   my @parts = split m{/}, $path, -1;
   shift @parts;    # leading empty item, before the first /
   pop @parts if @parts && $parts[-1] eq '';    # trailing, re-added below

   if ($self->normalize_path) {
      my @out;
      for my $p (@parts) {
         next if $p eq '' || $p eq '.';
         if ($p eq '..') { pop @out; next }
         # AWS might or might not take them as dot segments: refuse them
         fail 400, 'url path has a percent-encoded dot segment ' . shown($p)
            . ': write it as it is, or remove it'
            if _uri_decode($p) =~ m{\A\.\.?\z};
         push @out, $p;
      }
      @parts = @out;
   }

   # incoming path is percent-encoded already: decode then encode once,
   # and a second time for everything but S3
   @parts = map {
      my $e = _uri_encode(_uri_decode($_));
      $e = _uri_encode($e) if $self->double_encode;
      $e;
   } @parts;
   my $out = '/' . join '/', @parts;
   $out .= '/' if $trailing && @parts;
   return $out;
}

1;