view release on metacpan or  search on metacpan

lib/Amazon/S3/Lite.pm  view on Meta::CPAN

# Called per-request so that rotating credentials (Lambda IAM roles)
# are always current.
########################################################################
sub _signer {
########################################################################
  my ( $self, $region ) = @_;

  my $creds = $self->credentials;

  my $access_key
    = $creds->can('get_aws_access_key_id')
    ? $creds->get_aws_access_key_id
    : $creds->aws_access_key_id;

  my $secret_key
    = $creds->can('get_aws_secret_access_key')
    ? $creds->get_aws_secret_access_key
    : $creds->aws_secret_access_key;

  my $token_sub = $creds->can('get_token') // $creds->can('token');
  my $token     = $token_sub ? $token_sub->($creds) : undef;

  return Amazon::Signature4::Lite->new(
    access_key    => $access_key,
    secret_key    => $secret_key,
    session_token => $token,
    region        => $region // $self->region,
    service       => 's3',
  );
}

########################################################################
# Build the endpoint URL for a bucket/key
########################################################################
sub _endpoint {
########################################################################
  my ( $self, $bucket, $key ) = @_;

  my $scheme = $self->{secure} ? 'https' : 'http';
  my $host   = $self->host;

  # Path-style URL: https://s3.amazonaws.com/bucket/key
  # (virtual-hosted style omitted for simplicity; path-style works
  # everywhere and avoids SSL cert issues with dotted bucket names)
  my $url = "$scheme://$host";

  $url .= "/$bucket"              if defined $bucket && length $bucket;
  $url .= '/' . _encode_key($key) if defined $key    && length $key;

  return $url;
}

########################################################################
# URI-encode an S3 key, preserving '/' separators
########################################################################
sub _encode_key {
########################################################################
  my ($key) = @_;

  return join '/', map { uri_escape_utf8( $_, '^A-Za-z0-9\-._~' ) }
    split m{/}, $key, -1;
}

########################################################################
sub _request {
########################################################################
  my ( $self, $method, $url, $headers, $content, $extra, $region ) = @_;

  $region  //= $self->region;
  $headers //= {};
  $content //= q{};
  $extra   //= {};

  my $content_is_coderef = ref $content eq 'CODE';

  # sign — returns merged headers ready for HTTP::Tiny
  my $signed = $self->_signer($region)->sign(
    method  => $method,
    url     => $url,
    headers => $headers,
    payload => $content_is_coderef ? q{} : $content,
  );

  # HTTP::Tiny sets Host itself — remove to avoid duplicate header error
  delete $signed->{host};

  $self->logger->debug("$method $url");

  my $options = { headers => $signed };

  if ( length $content || $content_is_coderef ) {
    $options->{content} = $content;
  }

  if ( $extra->{data_callback} ) {
    $options->{data_callback} = $extra->{data_callback};
  }

  my $response = $self->ua->request( $method, $url, $options );

  $self->logger->debug( sprintf 'Response: %s %s', $response->{status}, $response->{reason} );

  return $response;
}

########################################################################
# head_object( $bucket, $key )
#
# Fetches metadata for an object without retrieving the body.
# Returns undef if the key does not exist (404).
# Returns a hashref with content_type, content_length, etag,
# last_modified, and metadata (x-amz-meta-* headers).
########################################################################
sub head_object {
########################################################################
  my ( $self, $bucket, $key ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url      = $self->_endpoint( $bucket, $key );