HTTP::Request results from the CPAN

Amazon-S3

      return $text if $EVAL_ERROR;
    }

    return $text if !$encryption_key;

    my $cipher = Crypt::CBC->new(
      -pass        => $encryption_key,
      -key         => $encryption_key,
      -cipher      => 'Crypt::Blowfish',
      -nodeprecate => $TRUE,
    );

    return $cipher->encrypt($text);
  }

########################################################################
  sub _decrypt {
########################################################################
    my ($secret) = @_;

    return $secret
      if !$secret || !$encryption_key;

    my $cipher = Crypt::CBC->new(
      -pass   => $encryption_key,
      -key    => $encryption_key,
      -cipher => 'Crypt::Blowfish',
    );

    return $cipher->decrypt($secret);
  }

}

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

  my $region;

  if ( !ref $bucket || ref $bucket !~ /Amazon::S3::Bucket/xsm ) {
    $bucket = Amazon::S3::Bucket->new( bucket => $bucket, account => $self );
  }

  return $bucket->get_location_constraint // $DEFAULT_REGION;
}

########################################################################
sub get_default_region {
########################################################################
  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;
}

########################################################################

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

  my $http_headers = $self->_merge_meta( $headers, $metadata );

  my $protocol = $self->secure ? 'https' : 'http';

  my $host = $self->host;

  $path =~ s/\A\///xsm;
  my $url = sprintf '%s://%s/%s', $protocol, $host, $path;

  #  if ( $path =~ m{\A([^/?]+)([^?]+)(.*)}xsm
  if ( $path =~ /\A([^\/?]+)([^?]+)(.*)/xsm
    && $self->dns_bucket_names
    && is_domain_bucket($1) ) {

    my $bucket = $1;
    $path = $2;

    my $query_string = $3;

    $self->logger->debug(
      sub {
        return Dumper(
          [ bucket       => $bucket,
            path         => $path,
            query_string => $query_string,
          ]
        );
      }
    );

    if ( $host =~ /([^:]+):([^:]\d+)$/xsm ) {

      my $port;

      $url = eval {
        $port = $2;
        $host = $1;

        my $uri = URI->new;

        $uri->scheme('http');
        $uri->host("$bucket.$host");
        $uri->port($port);
        $uri->path($path);

        return $uri . $query_string;
      };

      die sprintf
        "error creating uri for bucket: [%s], host: [%s], path: [%s], port: [%s]\n%s",
        $bucket, $host, $path, $port, $EVAL_ERROR

        if !$url || $EVAL_ERROR;
    }
    else {
      $url = sprintf '%s://%s.%s%s%s', $protocol, $bucket, $host, $path,
        $query_string;
    }
  }

  my $request = HTTP::Request->new( $method, $url, $http_headers );

  $self->last_request($request);

  if ($data) {
    $request->content($data);
  }

  $self->signer->region($region); # always set regional endpoint for signing

  $self->signer->sign($request);

  return $request;
}

# $self->_send_request($HTTP::Request)
# $self->_send_request(@params_to_make_request)
# $self->_send_request($params_to_make_request)
########################################################################
sub _send_request {
########################################################################
  my ( $self, @args ) = @_;

  my $logger = $self->get_logger;

  $logger->trace(
    sub {
      return Dumper( [ args => \@args ] );
    },
  );

  my $keep_root = $FALSE;

  my $request = eval {
    return $args[0]
      if ref( $args[0] ) =~ /HTTP::Request/xsm;

    return {@args}
      if @args > 1 && !@args % 2;

    return $args[0]
      if ref $args[0];

    croak 'invalid argument to _send_request';
  };

  if ( ref($request) !~ /HTTP::Request/xsm ) {
    $keep_root = delete $request->{keep_root};

    $request = $self->_make_request($request);
  }

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

  $self->last_response($response);

  $logger->debug(
    sub {
      return Dumper( [ response => $response ] );
    }
  );

  return $self->_decode_response( $response, $keep_root );
}

########################################################################
sub _decode_response {
########################################################################
  my ( $self, $response, $keep_root ) = @_;

  my $content;

  if ( $response->code !~ /\A2\d{2}\z/xsm ) {
    $self->_remember_errors( $response->content, 1 );
    $content = undef;
  }
  elsif ( is_xml_response($response) ) {
    $content = $self->_xpc_of_content( $response->content, $keep_root );
  }

  return $content;
}

########################################################################
sub is_xml_response {
########################################################################
  my ($rsp) = @_;

  return $FALSE
    if !$rsp->content;

  return $TRUE
    if $rsp->content_type eq 'application/xml';

  return $TRUE
    if $rsp->content =~ /\A\s*<[?]xml/xsm;

  return $FALSE;
}

#
# This is the necessary to find the region for a specific bucket
# and set the signer object to use that region when signing requests
########################################################################
sub adjust_region {
########################################################################
  my ( $self, $bucket, $called_from_redirect ) = @_;

  my $url = sprintf 'https://%s.%s', $bucket, $self->host;

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

  $self->{'signer'}->sign($request);

  # We have to turn off our special retry since this will deliberately
  # trigger that code
  $self->turn_off_special_retry();

  # If the bucket name has a period in it, the certificate validation
  # will fail since it will expect a certificate for a subdomain.
  # Setting it to verify against the expected host guards against
  # that while still being secure since we will have verified
  # the response as coming from the expected server.
  $self->ua->ssl_opts( SSL_verifycn_name => $self->host );

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

  # Turn this off, since all other requests have the bucket after
  # the host in the URL, and the host may change depending on the region
  $self->ua->ssl_opts( SSL_verifycn_name => undef );

  $self->turn_on_special_retry();

  # If No error, then nothing to do
  return $TRUE
    if $response->is_success();

  # If the error is due to the wrong region, then we will get
  # back a block of XML with the details
  return $FALSE
    if !is_xml_response($response);

  my $error_hash = $self->_xpc_of_content( $response->content );

  my ( $endpoint, $code, $region, $message )
    = @{$error_hash}{qw(Endpoint Code Region Message)};

  my $condition = eval {
    return 'PermanentRedirect'
      if $code eq 'PermanentRedirect' && $endpoint;

    return 'AuthorizationHeaderMalformed'
      if $code eq 'AuthorizationHeaderMalformed' && $region;

    return 'IllegalLocationConstraintException'
      if $code eq 'IllegalLocationConstraintException';

    return 'Other';
  };

  my %error_handlers = (
    PermanentRedirect => sub {
      # Don't recurse through multiple redirects
      return $FALSE
        if $called_from_redirect;

      # With a permanent redirect error, they are telling us the explicit
      # host to use.  The endpoint will be in the form of bucket.host
      my $host = $endpoint;

      # Remove the bucket name from the front of the host name

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

A delimiter is a character that you specify to group keys. All keys
that contain the same string between the prefix and the first
occurrence of the delimiter are grouped under a single result element
in CommonPrefixes. These groups are counted as one result against the
max-keys limitation. These keys are not returned elsewhere in the
response.

=item encoding-type     

Requests Amazon S3 to encode the object keys in the response and
specifies the encoding method to use.

=item key-marker        

Specifies the key to start with when listing objects in a bucket.

=item max-keys          

Sets the maximum number of keys returned in the response. By default,
the action returns up to 1,000 key names. The response might contain
fewer keys but will never contain more. If additional keys satisfy the
search criteria, but were not returned because max-keys was exceeded,
the response contains <isTruncated>true</isTruncated>. To return the
additional keys, see key-marker and version-id-marker.

default: 1000

=item prefix            

Use this parameter to select only those keys that begin with the
specified prefix. You can use prefixes to separate a bucket into
different groupings of keys. (You can think of using prefix to make
groups in the same way that you'd use a folder in a file system.) You
can use prefix with delimiter to roll up numerous objects into a
single result under CommonPrefixes.

=item version-id-marker 

Specifies the object version you want to start listing from.

=back

=head2 err

The S3 error code for the last error encountered.

=head2 errstr

A human readable error string for the last error encountered.

=head2 error

The decoded XML string as a hash object of the last error.

=head2 last_response

Returns the last L<HTTP::Response> object.

=head2 last_request

Returns the last L<HTTP::Request> object.

=head2 level

Set the logging level.

default: error

=head2 turn_on_special_retry

Called to add extra retry codes if retry has been set

=head2 turn_off_special_retry

Called to turn off special retry codes when we are deliberately
triggering them

=head1 ABOUT

This module contains code modified from Amazon that contains the
following notice:

  #  This software code is made available "AS IS" without warranties of any
  #  kind.  You may copy, display, modify and redistribute the software
  #  code either by itself or as incorporated into your code; provided that
  #  you do not remove any proprietary notices.  Your use of this software
  #  code is at your own risk and you waive any claim against Amazon
  #  Digital Services, Inc. or its affiliates with respect to your use of
  #  this software code. (c) 2006 Amazon Digital Services, Inc. or its
  #  affiliates.

=head1 TESTING

Testing S3 is a tricky thing. Amazon wants to charge you a bit of
money each time you use their service. And yes, testing counts as
using.  Because of this, the application's test suite skips anything
approaching a real test unless you set certain environment variables.

For more on testing this module see
L<README-TESTING.md|https://github.com/rlauer6/perl-amazon-s3/blob/master/README-TESTING.md>

=over 

=item AMAZON_S3_EXPENSIVE_TESTS

Doesn't matter what you set it to. Just has to be set

=item AMAZON_S3_HOST

Sets the host to use for the API service.

default: s3.amazonaws.com

Note that if this value is set, DNS bucket name usage will be disabled
for testing. Most likely, if you set this variable, you are using a
mocking service and your bucket names are probably not resolvable. You
can override this behavior by setting C<AWS_S3_DNS_BUCKET_NAMES> to any
value.

=item AWS_S3_DNS_BUCKET_NAMES

( run in 0.668 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )