PUT results from the CPAN

Amazon-S3

########################################################################
  my ($self) = @_;

  my $region = $ENV{AWS_REGION} || $ENV{AWS_DEFAULT_REGION};

  return $region
    if $region;

  my $url = $AWS_METADATA_BASE_URL . 'placement/availability-zone';

  my $request = HTTP::Request->new( 'GET', $url );

  my $ua = LWP::UserAgent->new;
  $ua->timeout(0);

  my $response = eval { return $ua->request($request); };

  if ( $response && $response->is_success ) {
    if ( $response->content =~ /\A([[:lower:]]+[-][[:lower:]]+[-]\d+)/xsm ) {
      $region = $1;
    }
  }

  return $region || $DEFAULT_REGION;
}

# Amazon::Credentials compatibility methods
########################################################################
sub get_aws_access_key_id {
########################################################################
  my ($self) = @_;

  return _decrypt( $self->aws_access_key_id );
}

########################################################################
sub get_aws_secret_access_key {
########################################################################
  my ($self) = @_;

  return _decrypt( $self->aws_secret_access_key );
}

########################################################################
sub get_token {
########################################################################
  my ($self) = @_;

  return _decrypt( $self->token );
}

########################################################################
sub turn_on_special_retry {
########################################################################
  my ($self) = @_;

  return
    if !$self->retry;

  # In the field we are seeing issue of Amazon returning with a 400
  # code in the case of timeout.  From AWS S3 logs: REST.PUT.PART
  # Backups/2017-05-04/<account>.tar.gz "PUT
  # /Backups<path>?partNumber=27&uploadId=<id> - HTTP/1.1" 400
  # RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15"
  my $http_codes_hr = $self->ua->codes_to_determinate();
  $http_codes_hr->{$HTTP_BAD_REQUEST} = $TRUE;

  return;
}

########################################################################
sub turn_off_special_retry {
########################################################################
  my ($self) = @_;

  return
    if !$self->retry;

  # In the field we are seeing issue with Amazon returning a 400
  # code in the case of timeout.  From AWS S3 logs: REST.PUT.PART
  # Backups/2017-05-04/<account>.tar.gz "PUT
  # /Backups<path>?partNumber=27&uploadId=<id> - HTTP/1.1" 400
  # RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15"
  my $http_codes_hr = $self->ua->codes_to_determinate();
  delete $http_codes_hr->{$HTTP_BAD_REQUEST};

  return;
}

########################################################################
sub region {
########################################################################
  my ( $self, @args ) = @_;

  if (@args) {
    $self->_region( $args[0] );
  }

  $self->get_logger->debug(
    sub { return 'region: ' . ( $self->_region // $EMPTY ) } );

  if ( $self->_region ) {
    my $host = $self->host;
    $self->get_logger->debug( sub { return 'host: ' . $self->host } );

    if ( $host =~ /\As3[.](.*)?amazonaws/xsm ) {
      $self->host( sprintf 's3.%s.amazonaws.com', $self->_region );
    }
  }

  return $self->_region;
}

########################################################################
sub buckets {
########################################################################
  my ( $self, $verify_region ) = @_;

  # The "default" region for Amazon is us-east-1
  # This is the region to set it to for listing buckets
  # You may need to reset the signer's endpoint to 'us-east-1'

  # temporarily cache signer
  my $region = $self->_region;
  my $bucket_list;

  $self->reset_signer_region($DEFAULT_REGION); # default region for buckets op

  my $r = $self->_send_request(
    { method  => 'GET',
      path    => $EMPTY,
      headers => {},
      region  => $DEFAULT_REGION,
    },
  );

  return $bucket_list
    if !$r || $self->errstr;

  my $owner_id          = $r->{Owner}{ID};
  my $owner_displayname = $r->{Owner}{DisplayName};

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

    $headers->{'x-amz-object-ownership'} //= 'ObjectWriter';
  }

  my $region = $conf->{location_constraint} // $conf->{region};

  $region //= $self->region;

  if ( $region && $region eq $DEFAULT_REGION ) {
    undef $region;
  }

  return $self->_add_bucket(
    { headers           => $headers,
      bucket            => $conf->{bucket},
      region            => $region,
      availability_zone => $conf->{availability_zone},
    }
  );
}

########################################################################
sub _add_bucket {
########################################################################
  my ( $self, @args ) = @_;

  my $parameters = get_parameters(@args);

  my ( $bucket, $headers, $region, $availability_zone )
    = @{$parameters}{qw(bucket headers region availability_zone)};

  $region  //= $EMPTY;
  $headers //= {};

  my $request
    = { CreateBucketConfiguration => { LocationConstraint => $region, } };

  if ($availability_zone) {
    $request->{CreateBucketConfiguration}->{Location} = {
      Name => $availability_zone,
      Type => 'AvailabilityZone',
    };

    $request->{CreateBucketConfiguration}->{Bucket} = {
      DataRedundancy => 'SingleAvailabilityZone',
      Type           => 'Directory',
    };

    delete $request->{CreateBucketConfiguration}->{LocationConstraint};
  }

  $self->dns_bucket_names(0);

  my $data
    = ( $region || $availability_zone )
    ? create_xml_request($request)
    : $EMPTY;

  $headers->{'Content-Length'} = length $data;

  my $retval = $self->_send_request_expect_nothing(
    { method  => 'PUT',
      path    => "$bucket/",
      headers => $headers,
      data    => $data,
      region  => $region,
    },
  );

  my $bucket_obj = $retval ? $self->bucket($bucket) : undef;

  return $bucket_obj;
}

########################################################################
sub bucket {
########################################################################
  my ( $self, @args ) = @_;

  my ( $bucketname, $region, $verify_region );

  if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
    ( $bucketname, $region, $verify_region )
      = @{ $args[0] }{qw(bucket region verify_region)};
  }
  else {
    ( $bucketname, $region ) = @args;
  }

  # only set to default region if a region wasn't passed or region
  # verification not requested
  if ( !$region && !$verify_region ) {
    $region = $self->region;
  }

  return Amazon::S3::Bucket->new(
    { bucket        => $bucketname,
      account       => $self,
      region        => $region,
      verify_region => $verify_region,
    },
  );
}

########################################################################
sub delete_bucket {
########################################################################
  my ( $self, $conf ) = @_;

  my $bucket;
  my $region;
  my $headers;

  if ( eval { return $conf->isa('Amazon::S3::Bucket'); } ) {
    $bucket = $conf->bucket;
    $region = $conf->region;
  }
  else {
    $bucket  = $conf->{bucket};
    $region  = $conf->{region} || $self->get_bucket_location($bucket);
    $headers = $conf->{headers};
  }

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


    $self->get_logger->debug(
      sub {
        return { sprintf 'Redirecting to:  %s', $location };
      }
    );

    $request->uri($location);
    $response = $self->ua->request( $request, $filename );
  }

  $self->get_logger->debug( sub { return Dumper( [$response] ) } );

  $self->last_response($response);

  return $response;
}

# Call this if handling any temporary redirect issues
# (Like needing to probe with a HEAD request when file handle are involved)

########################################################################
sub _do_http_no_redirect {
########################################################################
  my ( $self, $request, $filename ) = @_;

  # convenient time to reset any error conditions
  $self->reset_errors;

  my $response = $self->ua->request( $request, $filename );

  $self->get_logger->debug( sub { return Dumper( [$response] ) } );

  $self->last_response($response);

  return $response;
}

########################################################################
sub _send_request_expect_nothing {
########################################################################
  my ( $self, @args ) = @_;

  my $request = $self->_make_request(@args);

  my $response = $self->_do_http($request);

  my $content = $response->content;

  return $TRUE
    if $response->code =~ /^2\d\d$/xsm;

  # anything else is a failure, and we save the parsed result
  $self->_remember_errors( $response->content, $TRUE );

  return $FALSE;
}

# Send a HEAD request first, to find out if we'll be hit with a 307 redirect.
# Since currently LWP does not have true support for 100 Continue, it simply
# slams the PUT body into the socket without waiting for any possible redirect.
# Thus when we're reading from a filehandle, when LWP goes to reissue the request
# having followed the redirect, the filehandle's already been closed from the
# first time we used it. Thus, we need to probe first to find out what's going on,
# before we start sending any actual data.
########################################################################
sub _send_request_expect_nothing_probed {
########################################################################
  my ( $self, @args ) = @_;

  my $parameters = get_parameters(@args);

  my ( $method, $path, $conf, $value, $region )
    = @{$parameters}{qw(method path headers data region)};

  $region = $region // $self->region;

  my $request = $self->_make_request(
    { method => 'HEAD',
      path   => $path,
      region => $region,
    },
  );

  my $override_uri;

  my $old_redirectable = $self->ua->requests_redirectable;
  $self->ua->requests_redirectable( [] );

  my $response = $self->_do_http_no_redirect($request);

  if ( $response->code =~ /^3/xsm ) {
    if ( defined $response->header('Location') ) {
      $override_uri = $response->header('Location');
    }
    else {
      $self->_croak_if_response_error($response);
    }

    $self->get_logger->debug(
      sub {
        return sprintf 'setting override URI: [%s]', $override_uri;
      }
    );
  }

  $request = $self->_make_request(
    { method  => $method,
      path    => $path,
      headers => $conf,
      data    => $value,
      region  => $region,
    },
  );

  if ( defined $override_uri ) {
    $request->uri($override_uri);
  }

  $response = $self->_do_http_no_redirect($request);

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

  # delete bucket
  $bucket->delete_bucket;

=head1 DESCRIPTION

This documentation refers to version 2.0.2.

C<Amazon::S3> provides a portable client interface to Amazon Simple
Storage System (S3).

This module is rather dated, however with some help from a few
contributors it has had some recent updates. Recent changes include
implementations of:

=over 5

=item ListObjectsV2

=item CopyObject

=item DeleteObjects

=item ListObjectVersions

=back

Additionally, this module now implements Signature Version 4 signing,
unit tests have been updated and more documentation has been added or
corrected. Credentials are encrypted if you have encryption modules installed.

I<NEW!>

The C<Amazon::S3> modules have been heavily refactored over the last
few releases to increase maintainability and to add new features. New
features include:

=over 5

=item L<Amazon::S3::BucketV2>

This new module implements a mechanism to invoke I<almost> all of the
S3 APIs using a standard calling method.

The module will format your Perl objects as XML payloads and enable
you to provide all of the parameters required to make an API
call. Headers and URI parameters can also be passed to the
methods. L<Amazon::S3::BucketV2> is a subclass of
L<Amazon::S3::Bucket>, meaning you can still invoke all of the same
methods found there.

See L<Amazon::S3::BucketV2> for more details.

=item Limited Support for Directory Buckets

This version include limited support for directory buckets.

You can create and list directory buckets.

I<Directory buckets use the S3 Express One Zone storage class, which
is recommended if your application is performance sensitive and
benefits from single-digit millisecond PUT and GET latencies.> -
L<https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html>

=over 10

=item list_directory_buckets

List the directory buckets. Note this only returns a list of you
directory buckets, not their contents. In order to list the contents
of a directory bucket you must first create a session that establishes
temporary credentials used to acces the Zonal endpoints. You then use
those credentials for signing requests using the ListObjectV2 API.

This process is currently B<not supported> by this class.

L<https://docs.aws.amazon.com/AmazonS3/latest/API/API_CreateSession.html>

<Lhttps://docs.aws.amazon.com/AmazonS3/latest/API/API_ListObjectsV2.html>

=item add_bucket

You can add a regin and availability zone to this call in order to
create a directory bucket.

 $bucket->add_bucket({ bucket => $bucket_name, availability_zone => 'use1-az5' });

Note that your bucket name must conform to the naming conventions for
directory buckets. -
L<https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html#directory-buckets-name>
 
=back

=item Addition of version parameter for C<delete_key>

You can now delete a version of a key by including its verion ID.

 $bucket->delete_key($key, $version_id);

=item Methods that accept a hash reference can now accept a
C<headers> object that may contain any additional headers you might want
to send with a request. Some of the methods that now allow you to pass
a header object include:

=over 10

=item add_bucket

=item add_key

=item get_key

Can now be called with a hashref which may include both a C<headers>
and C<uri_params> object.

=item delete_bucket

=item list_bucket

=item list_object_versions

=item upload_multipart_object

( run in 1.439 second using v1.01-cache-2.11-cpan-13bb782fe5a )