view release on metacpan or  search on metacpan

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

	$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 {
				$ua->ssl_opts( verify_hostname => 1, SSL_verify_mode=>1);
			}
		}
		$url .= "?$self->{params_s}" if $self->{params_s};
		if ($self->{method} eq 'PUT') {
			$req = HTTP::Request->new(PUT => $url, undef, $self->{dataref});
		} elsif ($self->{method} eq 'POST') {
			if ($self->{dataref}) {
				$req = HTTP::Request->new(POST => $url, [Content_Type => 'form-data'], ${$self->{dataref}});
			} else {
				$req = HTTP::Request->new(POST => $url );
			}
		} elsif ($self->{method} eq 'DELETE') {
			$req = HTTP::Request->new(DELETE => $url);
		} elsif ($self->{method} eq 'GET') {
			$req = HTTP::Request->new(GET => $url);
		} else {
			confess;
		}
		for ( @{$self->{headers}}, @{$self->{req_headers}} ) {
			$req->header( $_->{name}, $_->{value} );
		}
		my $resp = undef;

		my $t0 = time();
		if ($self->{content_file} && $self->{writer}) {
			confess "content_file and writer at same time";
		} elsif ($self->{content_file}) {
			$resp = $ua->request($req, $self->{content_file});
		} elsif ($self->{writer}) {
			my $size = undef;
			$resp = $ua->request($req, sub {
				unless (defined($size)) {
					if ($_[1] && $_[1]->isa('HTTP::Response')) {
						$size = $_[1]->content_length;
						if (!$size || ($self->{expected_size} && $size != $self->{expected_size})) {
							die exception
								wrong_file_size_in_journal =>
									'Wrong Content-Length received from server, probably wrong file size in Journal or wrong server';
						}
						$self->{writer}->reinit($size);
					} else {
						# we should "confess" here, but we cant, only exceptions propogated
						die exception "unknow_error" => "Unknown error, probably LWP version is too old";
					}
				}
				$self->{writer}->add_data($_[0]);
				1;
			});
		} else {
			$resp = $ua->request($req);
		}
		my $dt = time()-$t0;

		if (($resp->code eq '500') && $resp->header('Client-Warning') && ($resp->header('Client-Warning') eq 'Internal response')) {
			if ($resp->content =~ /Can't verify SSL peers without knowing which Certificate Authorities to trust/i) {
				die exception 'lwp_ssl_ca_exception' =>
					'Can\'t verify SSL peers without knowing which Certificate Authorities to trust. Probably "Mozilla::CA" module is missing';
			} else {
				print "PID $$ HTTP connection problem (timeout?). Will retry ($dt seconds spent for request)\n";
				$self->{last_retry_reason} = 'Internal response';
				throttle($i);
			}
		} elsif ($resp->code =~ /^(500|408)$/) {
			print "PID $$ HTTP ".$resp->code." This might be normal. Will retry ($dt seconds spent for request)\n";
			$self->{last_retry_reason} = $resp->code;
			throttle($i);
		} elsif (defined($resp->header('X-Died')) && (get_exception($resp->header('X-Died')))) {
			die $resp->header('X-Died'); # propogate our own exceptions
		} elsif (defined($resp->header('X-Died')) && length($resp->header('X-Died'))) {
			print "PID $$ HTTP connection problem. Will retry ($dt seconds spent for request)\n";
			$self->{last_retry_reason} = 'X-Died';
			throttle($i);
		} elsif ($resp->code =~ /^2\d\d$/) {
			if ($self->{writer}) {
				my ($c, $reason) = $self->{writer}->finish();
				if ($c eq 'retry') {
					print "PID $$ HTTP $reason. Will retry ($dt seconds spent for request)\n";
					$self->{last_retry_reason} = $reason;
					throttle($i);
				} elsif ($c ne 'ok') {
					confess;
				} else {
					return $resp;
				}
			} elsif (defined($resp->content_length) && $resp->content_length != length($resp->content)){
				print "PID $$ HTTP Unexpected end of data. Will retry ($dt seconds spent for request)\n";
				$self->{last_retry_reason}='Unexpected end of data';
				throttle($i);
			} else {
				return $resp;
			}
		} else {
			if ($resp->code =~ /^40[03]$/) {
				if ($resp->content_type && $resp->content_type eq 'application/json') {
					my $json = JSON::XS->new->allow_nonref;
					my $scalar = eval { $json->decode( $resp->content ); }; # we assume content always in utf8
					if (defined $scalar) {
						my $code = $scalar->{code};
						my $type = $scalar->{type};
						my $message = $scalar->{message};
						if ($code eq 'ThrottlingException') {
							print "PID $$ ThrottlingException. Will retry ($dt seconds spent for request)\n";
							$self->{last_retry_reason} = 'ThrottlingException';
							throttle($i);
							next;
						}
					}
				}
			}
			print STDERR "Error:\n";
			print STDERR dump_request_response($req, $resp);
			die exception 'http_unexpected_reply' => 'Unexpected reply from remote server';
		}
	}
	die exception 'too_many_tries' => "Request was not successful after "._max_retries." retries";
}