File Coverage

lib/Amazon/S3.pm

Criterion	Covered	Total	%
statement	125	673	18.5
branch	21	246	8.5
condition	11	206	5.3
subroutine	27	90	30.0
pod	19	31	61.2
total	203	1246	16.2

package Amazon::S3;

use strict;
use warnings;

use Amazon::S3::Bucket;
use Amazon::S3::BucketV2;
use Amazon::S3::Constants qw(:all);

use Amazon::S3::Util qw(
  set_md5_header
  urlencode
  get_parameters
  create_xml_request
  create_api_uri
  create_query_string
);

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 LWP::UserAgent::Determined;
use List::Util   qw( any pairs none );
use MIME::Base64 qw(encode_base64 decode_base64);
use Scalar::Util qw( reftype blessed );
use URI;
use XML::Simple;

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

__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
    express
    host
    last_request
    last_response
    logger
    log_level
    retry
    _region
    secure
    _signer
    timeout
    ua
  ),
);

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

our @EXPORT_OK = qw(is_domain_bucket);

########################################################################
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{express}          //= $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 );
  }

  if ( $self->express ) {
    $self->use_express_one_zone();
  }

  $self->turn_on_special_retry();

  return $self;
}

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

  my $express = $self->express;

  $self->express($TRUE);

  $self->host( sprintf 's3express-control.%s.amazonaws.com', $self->region );
  $self->dns_bucket_names($FALSE);

  return $express;
}

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

      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/.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) = @_;

  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/.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 $bucket = $conf->{bucket};

  croak 'must specify bucket'
    if !$bucket;

  my $headers = $conf->{headers} // {};

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

    $headers->{'x-amz-acl'}              //= $conf->{acl_short};
    $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};
  }

  croak 'must specify bucket'
    if !$bucket;

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

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

  my $parameters = get_parameters(@args);

  my $express = $self->use_express_one_zone;

  my $result = $self->_send_request(
    { method     => 'GET',
      headers    => {},
      path       => $SLASH,
      uri_params => $parameters->{uri_params} // {},
      region     => $self->region,
    }
  );

  $self->express($express);

  return $result;
}

########################################################################
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 $headers = delete $conf->{headers};

  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 . 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 => $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;
}

########################################################################
# API: ListObjectVersions
#########################################################################
# Documentation:
#  https://docs.aws.amazon.com/AmazonS3/latest/API/API_ListObjectVersions.html
#
# Request:
#  GET /?versions
#  HOST: Bucket.s3.amazonaws.com
#  x-amz-expected-bucket-owner: ExpectedBucketOwner
#  x-amz-request-payer: RequestPayer
#  x-amz-optional-object-attributes: OptionalObjectAtttributes
#
# Parameters:
#   delimiter         => Delimiter
#   encoding-type     => EncodingType
#   key-marker        => KeyMarker
#   max-keys          => MaxKeys
#   prefix            => Prefix
#   version-id-marker => VersionIdMarker
#
# Response

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

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

  die 'no bucket'
    if !$bucket;

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

  croak 'must specify bucket'
    if !$bucket;

  $conf ||= {};

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

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

  if ( %{$conf} ) {

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

      delete $conf->{$_};
    }
  }

  my $path
    = create_api_uri( path => "$bucket/", api => 'versions', %{$conf} );

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

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

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

  return $r;
}

########################################################################
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 $express = $self->express;

  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        => $express ? 's3express' : 's3',
      security_token => $creds->get_token,
    },
  );

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

  return $signer;
}

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

  croak sprintf '%s is not a supported canned access policy', $policy_name
    if none { $policy_name eq $_ }
    qw(private public-read public-read-write authenticated-read);

  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 use it
# as a subdomain in the host name 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 is_domain_bucket { goto &_can_bucket_be_subdomain; }
########################################################################

########################################################################
sub _can_bucket_be_subdomain {
########################################################################
  my ($bucketname) = @_;

  return $FALSE
    if length $bucketname > $MAX_BUCKET_NAME_LENGTH - 1;

  return $FALSE
    if length $bucketname < $MIN_BUCKET_NAME_LENGTH;

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

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

  return $TRUE;
}

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

  my $parameters = get_parameters(@args);

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

  # 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;
  $headers->{'Content-Length'} //= length $data;

  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
      # 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, $TRUE );
    },
    AuthorizationHeaderMalformed => sub {
      # Set the signer to use the correct reader evermore
      $self->{signer}->{endpoint} = $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( sprintf 's3-%s-amazonaws.com', $region );
      }

      return $TRUE;
    },
    IllegalLocationConstraintException => sub {
      # This is hackish; but in this case the region name only appears in the message
      if ( $message =~ /The (\S+) location/xsm ) {
        my $new_region = $1;

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

        # Set the proper host for the region
        $self->host( sprintf 's3.%s.amazonaws.com', $new_region );

        return $TRUE;
      }
    },
    'Other' => sub {
      # Some other error
      $self->_remember_errors( $response->content, 1 );
      return $FALSE;
    },
  );

  return $error_handlers{$condition}->();
}

########################################################################
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
  my $location = $response->header('Location');

  if ( $response->code =~ /\A3/xsm and defined $location ) {

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

  $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{2}$/xsm ) {
    $self->err('network_error');

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

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

  my ( $code, $message ) = @{$r}{qw(Code Message)};

  return $FALSE
    if !$code;

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

  return $TRUE;
}

# 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(
    sub {
      return Dumper(
        [ headers          => $headers,
          canonincal_sring => $canonical_string,
        ]
      );
    }
  );

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

  $headers->header(
    Authorization => sprintf 'AWS %s:%s',
    $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 ? urlencode($b64) : return $b64;
}

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

  my $parameters = get_parameters(@args);

  my ( $bucketname, $region, $verify_region )
    = @{$parameters}{qw(bucket region verify_region)};

  # 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::BucketV2->new(
    { bucket        => $bucketname,
      account       => $self,
      region        => $region,
      verify_region => $verify_region,
    },
  );
}

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

  my $bucketv2 = bless $bucket, 'Amazon::S3::BucketV2';

  return $bucketv2->DeletePublicAccessBlock;
}

1;

__END__