File Coverage

lib/Amazon/S3.pm

Criterion	Covered	Total	%
statement	122	587	20.7
branch	20	218	9.1
condition	11	184	5.9
subroutine	26	70	37.1
pod	16	24	66.6
total	195	1083	18.0

package Amazon::S3;

use strict;
use warnings;

use Amazon::S3::Bucket;
use Amazon::S3::Constants qw(:all);
use Amazon::S3::Logger;
use Amazon::S3::Signature::V4;

use Carp;
use Data::Dumper;
use Digest::HMAC_SHA1;
use Digest::MD5 qw(md5_hex);
use English     qw(-no_match_vars);
use HTTP::Date;
use URI;
use LWP::UserAgent::Determined;
use MIME::Base64 qw(encode_base64 decode_base64);
use Scalar::Util qw( reftype blessed );
use List::Util   qw( any pairs );
use URI::Escape  qw(uri_escape_utf8);
use XML::Simple  qw(XMLin);                      ## no critic (Community::DiscouragedModules)

use parent qw(Class::Accessor::Fast);

__PACKAGE__->mk_accessors(
  qw(
    aws_access_key_id
    aws_secret_access_key
    token
    buffer_size
    cache_signer
    credentials
    dns_bucket_names
    digest
    err
    errstr
    error
    host
    last_request
    last_response
    logger
    log_level
    retry
    _region
    secure
    _signer
    timeout
    ua
  ),
);

our $VERSION = '0.64'; ## no critic (RequireInterpolation)

########################################################################
sub new {
########################################################################
  my ( $class, @args ) = @_;

  my %options = ref $args[0] ? %{ $args[0] } : @args;

  $options{timeout}          //= $DEFAULT_TIMEOUT;
  $options{secure}           //= $TRUE;
  $options{host}             //= $DEFAULT_HOST;
  $options{dns_bucket_names} //= $TRUE;
  $options{cache_signer}     //= $FALSE;
  $options{retry}            //= $FALSE;

  $options{_region} = delete $options{region};
  $options{_signer} = delete $options{signer};

  # convenience for level => 'debug' & for consistency with
  # Amazon::Credentials only do this if we are using internal logger,
  # call should NOT use debug flag but rather use their own logger's
  # level to turn on higher levels of logging...

  if ( !$options{logger} ) {
    if ( delete $options{debug} ) {
      $options{level} = 'debug';
    }

    $options{log_level} = delete $options{level};
    $options{log_level} //= $DEFAULT_LOG_LEVEL;

    $options{logger}
      = Amazon::S3::Logger->new( log_level => $options{log_level} );
  }

  my $self = $class->SUPER::new( \%options );

  # setup logger internal logging

  $self->get_logger->debug(
    sub {
      my %safe_options = %options;

      if ( $safe_options{aws_secret_access_key} ) {
        $safe_options{aws_secret_access_key} = '****';
        $safe_options{aws_access_key_id}     = '****';
      }

      return Dumper( [ options => \%safe_options ] );
    },
  );

  if ( !$self->credentials ) {

    croak 'No aws_access_key_id'
      if !$self->aws_access_key_id;

    croak 'No aws_secret_access_key'
      if !$self->aws_secret_access_key;

    # encrypt credentials
    $self->aws_access_key_id( _encrypt( $self->aws_access_key_id ) );
    $self->aws_secret_access_key( _encrypt( $self->aws_secret_access_key ) );
    $self->token( _encrypt( $self->token ) );
  }

  my $ua;

  if ( $self->retry ) {
    $ua = LWP::UserAgent::Determined->new(
      keep_alive            => $KEEP_ALIVE_CACHESIZE,
      requests_redirectable => [qw(GET HEAD DELETE)],
    );

    $ua->timing( join $COMMA, map { 2**$_ } 0 .. $MAX_RETRIES );
  }
  else {
    $ua = LWP::UserAgent->new(
      keep_alive            => $KEEP_ALIVE_CACHESIZE,
      requests_redirectable => [qw(GET HEAD DELETE)],
    );
  }

  $ua->timeout( $self->timeout );
  $ua->env_proxy;
  $self->ua($ua);

  $self->region( $self->_region // $DEFAULT_REGION );

  if ( !$self->_signer && $self->cache_signer ) {
    $self->_signer( $self->signer );
  }

  $self->turn_on_special_retry();

  return $self;
}

########################################################################
{
  my $encryption_key;

########################################################################
  sub _encrypt {
########################################################################
    my ($text) = @_;

    return $text if !$text;

    if ( !defined $encryption_key ) {
      $encryption_key = eval {
        if ( !defined $encryption_key ) {
          require Crypt::Blowfish;
          require Crypt::CBC;

          return md5_hex( rand $PID );
        }
      };
    }

    if ( !$encryption_key || $EVAL_ERROR ) {
      return $text;
    }

    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
    = 'http://169.254.169.254/latest/meta-data/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) = @_;

  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/.tar.gz "PUT
    # /Backups?partNumber=27&uploadId= - 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) = @_;

  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/.tar.gz "PUT
    # /Backups?partNumber=27&uploadId= - 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};

  my @buckets;

  if ( ref $r->{Buckets} ) {
    my $buckets = $r->{Buckets}{Bucket};

    if ( !ref $buckets || reftype($buckets) ne 'ARRAY' ) {
      $buckets = [$buckets];
    }

    foreach my $node ( @{$buckets} ) {
      push @buckets,
        Amazon::S3::Bucket->new(
        { bucket        => $node->{Name},
          creation_date => $node->{CreationDate},
          account       => $self,
          buffer_size   => $self->buffer_size,
          verify_region => $verify_region // $FALSE,
        },
        );

    }
  }

  $self->reset_signer_region($region); # restore original region

  $bucket_list = {
    owner_id          => $owner_id,
    owner_displayname => $owner_displayname,
    buckets           => \@buckets,
  };

  return $bucket_list;
}

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

  # reset signer's region, if the region wasn't us-east-1...note this
  # is probably not needed anymore since bucket operations now send
  # the region of the bucket to the signer
  if ( $self->cache_signer ) {
    if ( $self->region && $self->region ne $DEFAULT_REGION ) {
      if ( $self->signer->can('region') ) {
        $self->signer->region($region);
      }
    }
  }
  else {
    $self->region($region);
  }

  return $self->region;
}

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

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

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

  my $bucket = $conf->{bucket};

  croak 'must specify bucket'
    if !$bucket;

  my %header_ref;

  if ( $conf->{acl_short} ) {
    $self->_validate_acl_short( $conf->{acl_short} );

    $header_ref{'x-amz-acl'} = $conf->{acl_short};
  }

  my $xml = <<'XML';

  %s

XML

  my $data = defined $region ? sprintf $xml, $region : $EMPTY;

  my $retval = $self->_send_request_expect_nothing(
    { method  => 'PUT',
      path    => "$bucket/",
      headers => { %header_ref, 'Content-Length' => length $data },
      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;

  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);
  }

  croak 'must specify bucket'
    if !$bucket;

  return $self->_send_request_expect_nothing(
    { method  => 'DELETE',
      path    => $bucket . $SLASH,
      headers => {},
      region  => $region,
    },
  );
}

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

  $conf->{'list-type'} = '2';

  goto &list_bucket;
}

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

  my $bucket = delete $conf->{bucket};

  croak 'must specify bucket' if !$bucket;

  $conf ||= {};

  my $bucket_list; # return this
  my $path = $bucket . $SLASH;

  my $list_type = $conf->{'list-type'} // '1';

  my ( $marker, $next_marker, $query_next )
    = @{ $LIST_OBJECT_MARKERS{$list_type} };

  if ( $conf->{marker} ) {
    $conf->{$query_next} = delete $conf->{marker};
  }

  if ( %{$conf} ) {

    my @vars = keys %{$conf};

    # remove undefined elements
    foreach (@vars) {
      next if defined $conf->{$_};

      delete $conf->{$_};
    }

    my $query_string = $QUESTION_MARK . join $AMPERSAND,
      map { $_ . $EQUAL_SIGN . $self->_urlencode( $conf->{$_} ) }
      keys %{$conf};

    $path .= $query_string;

  }

  $self->get_logger->debug( sprintf 'PATH: %s', $path );

  my $r = $self->_send_request(
    { method  => 'GET',
      path    => $path,
      headers => {},           # { 'Content-Length' => 0 },
      region  => $self->region,
    },
  );

  $self->get_logger->trace(
    Dumper(
      [ r      => $r,
        errstr => $self->errstr,
      ]
    )
  );

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

  $self->get_logger->trace(
    sub {
      return Dumper(
        [ marker      => $marker,
          next_marker => $next_marker,
          response    => $r,
        ],
      );
    },
  );

  $bucket_list = {
    bucket       => $r->{Name},
    prefix       => $r->{Prefix}       // $EMPTY,
    marker       => $r->{$marker}      // $EMPTY,
    next_marker  => $r->{$next_marker} // $EMPTY,
    max_keys     => $r->{MaxKeys},
    is_truncated => (
      ( defined $r->{IsTruncated} && scalar $r->{IsTruncated} eq 'true' )
      ? $TRUE
      : $FALSE
    ),
  };

  my @keys;

  foreach my $node ( @{ $r->{Contents} } ) {
    my $etag = $node->{ETag};

    if ( defined $etag ) {
      $etag =~ s{(^"|"$)}{}gxsm;
    }

    push @keys,
      {
      key               => $node->{Key},
      last_modified     => $node->{LastModified},
      etag              => $etag,
      size              => $node->{Size},
      storage_class     => $node->{StorageClass},
      owner_id          => $node->{Owner}{ID},
      owner_displayname => $node->{Owner}{DisplayName},
      };
  }

  $bucket_list->{keys} = \@keys;

  if ( $conf->{delimiter} ) {
    my @common_prefixes;
    my $strip_delim = qr/$conf->{delimiter}$/xsm;

    foreach my $node ( $r->{CommonPrefixes} ) {
      if ( ref $node ne 'ARRAY' ) {
        $node = [$node];
      }

      foreach my $n ( @{$node} ) {
        next if !exists $n->{Prefix};
        my $prefix = $n->{Prefix};

        # strip delimiter from end of prefix
        if ($prefix) {
          $prefix =~ s/$strip_delim//xsm;
        }

        push @common_prefixes, $prefix;
      }
    }

    $bucket_list->{common_prefixes} = \@common_prefixes;
  }

  $self->get_logger->trace( Dumper( [ bucket_list => $bucket_list ] ) );

  return $bucket_list;
}

########################################################################
sub list_bucket_all_v2 {
########################################################################
  my ( $self, $conf ) = @_;
  $conf ||= {};

  $conf->{'list-type'} = '2';

  return $self->list_bucket_all($conf);
}

########################################################################
sub list_bucket_all {
########################################################################
  my ( $self, $conf ) = @_;
  $conf ||= {};

  my $bucket = $conf->{bucket};

  croak 'must specify bucket'
    if !$bucket;

  my $response = $self->list_bucket($conf);

  croak $EVAL_ERROR
    if !$response;

  return $response
    if !$response->{is_truncated};

  my $all = $response;

  while ($TRUE) {
    my $next_marker = $response->{next_marker}
      || $response->{keys}->[-1]->{key};

    $conf->{marker} = $next_marker;
    $conf->{bucket} = $bucket;

    $response = $self->list_bucket($conf);

    croak $EVAL_ERROR
      if !$response;

    push @{ $all->{keys} }, @{ $response->{keys} };

    last if !$response->{is_truncated};
  }

  delete $all->{is_truncated};
  delete $all->{next_marker};

  return $all;
}

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

  my $aws_access_key_id;
  my $aws_secret_access_key;
  my $token;

  if ( $self->credentials ) {
    $aws_access_key_id     = $self->credentials->get_aws_access_key_id;
    $aws_secret_access_key = $self->credentials->get_aws_secret_access_key;
    $token                 = $self->credentials->get_token;
  }
  else {
    $aws_access_key_id     = $self->aws_access_key_id;
    $aws_secret_access_key = $self->aws_secret_access_key;
    $token                 = $self->token;
  }

  return ( $aws_access_key_id, $aws_secret_access_key, $token );
}

# Log::Log4perl compatibility routines
########################################################################
sub get_logger {
########################################################################
  my ($self) = @_;

  return $self->logger;
}

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

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

    $self->get_logger->level( uc $args[0] );
  }

  return $self->get_logger->level;
}

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

  return $self->_signer
    if $self->_signer;

  my $creds = $self->credentials ? $self->credentials : $self;

  my $signer = Amazon::S3::Signature::V4->new(
    { access_key_id => $creds->get_aws_access_key_id,
      secret        => $creds->get_aws_secret_access_key,
      region        => $self->region || $self->get_default_region,
      service       => 's3',
      $self->get_token ? ( security_token => $creds->get_token ) : (),
    },
  );

  if ( $self->cache_signer ) {
    $self->_signer($signer);
  }

  return $signer;
}

########################################################################
sub _validate_acl_short {
########################################################################
  my ( $self, $policy_name ) = @_;

  if ( !any { $policy_name eq $_ }
    qw(private public-read public-read-write authenticated-read) ) {
    croak "$policy_name is not a supported canned access policy";
  }

  return;
}

# Determine if a bucket can used as subdomain for the host
# Specifying the bucket in the URL path is being deprecated
# So, if the bucket name is suitable, we need to put it
# as a subdomain to the host, instead. Currently buckets with
# periods in their names cannot be handled in that manner
# due to SSL certificate issues, they will have to remain in
# the url path instead
sub _can_bucket_be_subdomain {
  my ($bucketname) = @_;

  if ( length $bucketname > $MAX_BUCKET_NAME_LENGTH - 1 ) {
    return $FALSE;
  }

  if ( length $bucketname < $MIN_BUCKET_NAME_LENGTH ) {
    return $FALSE;
  }

  return $FALSE if $bucketname !~ m{\A[[:lower:]][[:lower:]\d-]*\z}xsm;
  return $FALSE if $bucketname !~ m{[[:lower:]\d]\z}xsm;

  return $TRUE;
}

# make the HTTP::Request object

########################################################################
sub _make_request {
########################################################################
  my ( $self, @args ) = @_;
  my ( $method, $path, $headers, $data, $metadata, $region );

  if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
    ( $method, $path, $headers, $data, $metadata, $region )
      = @{ $args[0] }{qw(method path headers data metadata region)};
  }
  else {
    ( $method, $path, $headers, $data, $metadata, $region ) = @args;
  }

  # reset region on every call...every bucket can have it's own region
  $self->region( $region // $self->_region );

  croak 'must specify method'
    if !$method;

  croak 'must specify path'
    if !defined $path;

  $headers ||= {};

  $metadata ||= {};

  $data //= $EMPTY;

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

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

  my $host = $self->host;

  $path =~ s/\A\///xsm;
  my $url = "$protocol://$host/$path";

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

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

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

      $url = eval {
        my $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 "could not a uri for bucket: $bucket, host: $host, path: $path\n"
        if !$url || $EVAL_ERROR;
    }
    else {
      $url = "$protocol://$bucket.$host$path$query_string";
    }
  }

  $self->get_logger->debug( sprintf 'URL (uri): %s', $url );

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

  $self->last_request($request);

  $request->content($data);

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

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

  $self->get_logger->trace( sub { return Dumper( [$request] ); } );

  return $request;
}

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

  $self->get_logger->trace(
    sub {
      return Dumper( [ 'REQUEST' => \@args ] );
    },
  );

  my $request;
  my $keep_root = $FALSE;

  if ( @args == 1 && ref( $args[0] ) =~ /HTTP::Request/xsm ) {
    $request = $args[0];
  }
  else {
    if ( ref $args[0] ) {
      $keep_root = delete $args[0]->{keep_root};
    }

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

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

  $self->get_logger->debug( Dumper( [$response] ) );

  $self->last_response($response);

  my $content = $response->content;

  if ( $response->code !~ /\A2\d\d\z/xsm ) {
    $self->_remember_errors( $response->content, 1 );
    $content = undef;
  }
  elsif ( $content && $response->content_type eq 'application/xml' ) {
    $content = $self->_xpc_of_content( $content, $keep_root );
  }

  return $content;
}

#
# 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 $request
    = HTTP::Request->new( 'GET', 'https://' . $bucket . $DOT . $self->host );
  $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
  if ( $response->content_type eq 'application/xml' and $response->content ) {

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

    if (  $error_hash->{'Code'} eq 'PermanentRedirect'
      and $error_hash->{'Endpoint'} ) {

      # 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 = $error_hash->{'Endpoint'};

      # Remove the bucket name from the front of the host name
      # All the requests will need to be of the form https://host/bucket
      $host =~ s/\A$bucket[.]//xsm;
      $self->host($host);

      # We will need to call ourselves again in order to trigger the
      # AuthorizationHeaderMalformed error in order to get the region
      return $self->adjust_region( $bucket, 1 );
    }

    if (  $error_hash->{'Code'} eq 'AuthorizationHeaderMalformed'
      and $error_hash->{'Region'} ) {

      # Set the signer to use the correct reader evermore
      $self->{'signer'}{'endpoint'} = $error_hash->{'Region'};

      # Only change the host if we haven't been called as a redirect
      # where an exact host has been given
      if ( !$called_from_redirect ) {
        $self->host( 's3-' . $error_hash->{'Region'} . '.amazonaws.com' );
      }

      return $TRUE;
    }

    if ( $error_hash->{'Code'} eq 'IllegalLocationConstraintException' ) {

      # This is hackish; but in this case the region name only appears in the message
      if ( $error_hash->{'Message'} =~ /The (\S+) location/xsm ) {
        my $region = $1;

        # Correct the region for the signer
        $self->{'signer'}{'endpoint'} = $region;

        # Set the proper host for the region
        $self->host( 's3.' . $region . '.amazonaws.com' );

        return $TRUE;
      }
    }

  }

  # Some other error
  $self->_remember_errors( $response->content, 1 );
  return $FALSE;
}

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

  $self->err(undef);
  $self->errstr(undef);
  $self->error(undef);

  return $self;
}

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

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

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

  # For new buckets at non-standard locations, amazon will sometimes
  # respond with a temporary redirect.  In this case it is necessary
  # to try again with the new URL
  if ( $response->code =~ /\A3/xsm and defined $response->header('Location') )
  {

    $self->get_logger->debug(
      'Redirecting to:  ' . $response->header('Location') );

    $request->uri( $response->header('Location') );
    $response = $self->ua->request( $request, $filename );
  }

  $self->get_logger->debug( 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( 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);

  $self->get_logger->debug( Dumper( [$response] ) );

  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 { ## no critic (ProhibitUnusedPrivateSubroutines)
########################################################################
  my ( $self, @args ) = @_;

  my ( $method, $path, $conf, $value, $region );

  if ( @args == 1 && ref $args[0] ) {
    ( $method, $path, $conf, $value, $region )
      = @{ $args[0] }{qw(method path headers data region)};
  }
  else {
    ( $method, $path, $conf, $value, $region )
      = @{ $args[0] }{qw(method path headers data region)};
  }

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

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

  my $override_uri = undef;

  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( 'setting override URI to ', $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);

  $self->ua->requests_redirectable($old_redirectable);

  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;
}

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

  if ( $response->code !~ /^2\d\d$/xsm ) {
    $self->err('network_error');

    $self->errstr( $response->status_line );

    croak sprintf 'Amazon::S3: Amazon responded with %s ',
      $response->status_line;
  }

  return;
}

########################################################################
sub _xpc_of_content {
########################################################################
  my ( $self, $src, $keep_root ) = @_;

  my $xml_hr = eval {
    XMLin(
      $src,
      SuppressEmpty => $EMPTY,
      ForceArray    => ['Contents'],
      KeepRoot      => $keep_root,
      NoAttr        => $TRUE,
    );
  };

  if ( !$xml_hr && $EVAL_ERROR ) {
    confess "Error parsing $src:  $EVAL_ERROR";
  }

  return $xml_hr;
}

# returns 1 if errors were found
########################################################################
sub _remember_errors {
########################################################################
  my ( $self, $src, $keep_root ) = @_;

  return $src
    if !$src;

  if ( !ref $src && $src !~ /^[[:space:]]*
    ( my $code = $src ) =~ s/^[[:space:]]*[(][\d]*[)].*$/$1/xsm;

    $self->err($code);
    $self->errstr($src);

    return $TRUE;
  }

  my $r = ref $src ? $src : $self->_xpc_of_content( $src, $keep_root );

  $self->error($r);

  # apparently buckets() does not keep_root
  if ( $r->{Error} ) {
    $r = $r->{Error};
  }

  if ( $r->{Code} ) {
    $self->err( $r->{Code} );
    $self->errstr( $r->{Message} );

    return $TRUE;
  }

  return $FALSE;
}

#
# Deprecated - this adds a header for the old V2 auth signatures
#
########################################################################
sub _add_auth_header { ## no critic (ProhibitUnusedPrivateSubroutines)
########################################################################
  my ( $self, $headers, $method, $path ) = @_;

  my ( $aws_access_key_id, $aws_secret_access_key, $token )
    = $self->get_credentials;

  if ( not $headers->header('Date') ) {
    $headers->header( Date => time2str(time) );
  }

  if ($token) {
    $headers->header( $AMAZON_HEADER_PREFIX . 'security-token', $token );
  }

  my $canonical_string = $self->_canonical_string( $method, $path, $headers );
  $self->get_logger->trace( Dumper( [$headers] ) );
  $self->get_logger->trace("canonical string: $canonical_string\n");

  my $encoded_canonical
    = $self->_encode( $aws_secret_access_key, $canonical_string );

  $headers->header(
    Authorization => "AWS $aws_access_key_id:$encoded_canonical" );

  return;
}

# generates an HTTP::Headers objects given one hash that represents http
# headers to set and another hash that represents an object's metadata.
########################################################################
sub _merge_meta {
########################################################################
  my ( $self, $headers, $metadata ) = @_;

  $headers  ||= {};
  $metadata ||= {};

  my $http_header = HTTP::Headers->new;

  foreach my $p ( pairs %{$headers} ) {
    my ( $k, $v ) = @{$p};
    $http_header->header( $k => $v );
  }

  foreach my $p ( pairs %{$metadata} ) {
    my ( $k, $v ) = @{$p};
    $http_header->header( "$METADATA_PREFIX$k" => $v );
  }

  return $http_header;
}

# generate a canonical string for the given parameters.  expires is optional and is
# only used by query string authentication.
########################################################################
sub _canonical_string {
########################################################################
  my ( $self, $method, $path, $headers, $expires ) = @_;

  # initial / meant to force host/bucket-name instead of DNS based name
  $path =~ s/^\///xsm;

  my %interesting_headers = ();

  foreach my $p ( pairs %{$headers} ) {
    my ( $key, $value ) = @{$p};
    my $lk = lc $key;

    if ( $lk eq 'content-md5'
      or $lk eq 'content-type'
      or $lk eq 'date'
      or $lk =~ /^$AMAZON_HEADER_PREFIX/xsm ) {
      $interesting_headers{$lk} = $self->_trim($value);
    }
  }

  # these keys get empty strings if they don't exist
  $interesting_headers{'content-type'} ||= $EMPTY;
  $interesting_headers{'content-md5'}  ||= $EMPTY;

  # just in case someone used this.  it's not necessary in this lib.
  if ( $interesting_headers{'x-amz-date'} ) {
    $interesting_headers{'date'} = $EMPTY;
  }

  # if you're using expires for query string auth, then it trumps date
  # (and x-amz-date)
  if ($expires) {
    $interesting_headers{'date'} = $expires;
  }

  my $buf = "$method\n";

  foreach my $key ( sort keys %interesting_headers ) {
    if ( $key =~ /^$AMAZON_HEADER_PREFIX/xsm ) {
      $buf .= "$key:$interesting_headers{$key}\n";
    }
    else {
      $buf .= "$interesting_headers{$key}\n";
    }
  }

  # don't include anything after the first ? in the resource...
  #  $path =~ /^([^?]*)/xsm;
  #  $buf .= "/$1";
  $path =~ /\A([^?]*)/xsm;
  $buf .= "/$1";

  # ...unless there any parameters we're interested in...
  if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&]|$)/xsm ) {
    #  if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&])?/xsm ) {
    $buf .= "?$1";
  }
  elsif ( my %query_params = URI->new($path)->query_form ) {
    # see if the remaining parsed query string provides us with any
    # query string or upload id

    if ( $query_params{partNumber} && $query_params{uploadId} ) {
      # re-evaluate query string, the order of the params is important
      # for request signing, so we can't depend on URI to do the right
      # thing
      $buf .= sprintf '?partNumber=%s&uploadId=%s',
        $query_params{partNumber},
        $query_params{uploadId};
    }
    elsif ( $query_params{uploadId} ) {
      $buf .= sprintf '?uploadId=%s', $query_params{uploadId};
    }
  }

  return $buf;
}

########################################################################
sub _trim {
########################################################################
  my ( $self, $value ) = @_;

  $value =~ s/^\s+//xsm;
  $value =~ s/\s+$//xsm;

  return $value;
}

# finds the hmac-sha1 hash of the canonical string and the aws secret access key and then
# base64 encodes the result (optionally urlencoding after that).
########################################################################
sub _encode {
########################################################################
  my ( $self, $aws_secret_access_key, $str, $urlencode ) = @_;

  my $hmac = Digest::HMAC_SHA1->new($aws_secret_access_key);
  $hmac->add($str);

  my $b64 = encode_base64( $hmac->digest, $EMPTY );

  return $urlencode ? $self->_urlencode($b64) : return $b64;
}

########################################################################
sub _urlencode {
########################################################################
  my ( $self, $unencoded ) = @_;

  return uri_escape_utf8( $unencoded, '^A-Za-z0-9\-\._~\x2f' ); ## no critic (RequireInterpolation)
}

1;

__END__