view release on metacpan or  search on metacpan

lib/App/MtAws/GlacierRequest.pm  view on Meta::CPAN

	$self->{method} = 'DELETE';

	my $resp = $self->perform_lwp();
	return $resp ? $resp->header('x-amzn-RequestId') : undef;
}

sub list_vaults
{
	my ($self, $marker) = @_;

	$self->{url} = "/$self->{account_id}/vaults";
	$self->{params}->{marker} = $marker if defined($marker);
	$self->{method} = 'GET';

	my $resp = $self->perform_lwp();
	return $resp->decoded_content; # TODO: return reference?
}


sub _calc_data_hash
{
	my ($self) = @_;

	if (length(${$self->{dataref}}) <= 1048576) {
		$self->{data_sha256} = $self->{part_final_hash};
	} else {
		$self->{data_sha256} = large_sha256_hex(${$self->{dataref}});
	}
}


sub _sign
{
	my ($self) = @_;

	my $now = time();

	$self->{last_request_time} = $now;  # we use same timestamp when writing to journal

	my $date8601 = strftime("%Y%m%dT%H%M%SZ", gmtime($now));
	my $datestr = strftime("%Y%m%d", gmtime($now));


	$self->{req_headers} = [
		{ name => 'x-amz-date', value => $date8601 },
	];


	# getting canonical URL

	my @all_headers = sort { $a->{name} cmp $b->{name} } (@{$self->{headers}}, @{$self->{req_headers}});


	my $canonical_headers = join ("\n", map { lc($_->{name}).":".trim($_->{value}) } @all_headers);
	my $signed_headers = join (';', map { lc($_->{name}) } @all_headers);

	my $bodyhash = $self->{data_sha256} ?
		$self->{data_sha256} :
		( $self->{dataref} ? large_sha256_hex(${$self->{dataref}}) : sha256_hex('') );

	$self->{params_s} = $self->{params} ? join ('&', map { "$_=".uri_escape($self->{params}->{$_}) } sort keys %{$self->{params}}) : "";
	my $canonical_query_string = $self->{params_s};

	my $canonical_url = join("\n", $self->{method}, $self->{url}, $canonical_query_string, $canonical_headers, "", $signed_headers, $bodyhash);
	my $canonical_url_hash = sha256_hex($canonical_url);


	# /getting canonical URL

	my $credentials = "$datestr/$self->{region}/$self->{service}/aws4_request";

	my $string_to_sign = join("\n", "AWS4-HMAC-SHA256", $date8601, $credentials, $canonical_url_hash);

	my ($kSigning, $kSigning_hex) = get_signature_key($self->{secret}, $datestr, $self->{region}, $self->{service});
	my $signature = hmac_sha256_hex($string_to_sign, $kSigning);



	my $auth = "AWS4-HMAC-SHA256 Credential=$self->{key}/$credentials, SignedHeaders=$signed_headers, Signature=$signature";

	push @{$self->{req_headers}}, { name => 'Authorization', value => $auth};
}


sub _max_retries { 100 }
sub _sleep($) { sleep shift }

sub throttle
{
	my ($i) = @_;
	if ($i <= 5) {
		_sleep 1;
	} elsif ($i <= 10) {
		_sleep 5;
	} elsif ($i <= 20) {
		_sleep 15;
	} elsif ($i <= 50) {
		_sleep 60
	} else {
		_sleep 180;
	}
}

sub perform_lwp
{
	my ($self) = @_;

	for my $i (1.._max_retries) {
		undef $self->{last_retry_reason};
		$self->_sign();

		my $ua = LWP::UserAgent->new(timeout => $self->{timeout});
		$ua->protocols_allowed ( [ 'https' ] ) if $self->{protocol} eq 'https'; # Lets hard code this.
		$ua->agent("mt-aws-glacier/${App::MtAws::VERSION} (http://mt-aws.com/) "); # use of App::MtAws::VERSION_MATURITY produce warning
		my $req = undef;
		my $url = $self->{protocol} ."://$self->{host}$self->{url}";
		$url = $self->{protocol} ."://$ENV{MTGLACIER_FAKE_HOST}$self->{url}" if $ENV{MTGLACIER_FAKE_HOST};
		if ($self->{protocol} eq 'https') {
			if ($ENV{MTGLACIER_FAKE_HOST}) {
				$ua->ssl_opts( verify_hostname => 0, SSL_verify_mode=>0); #Hostname mismatch causes LWP to error.
			} else {