App-MtAws

 view release on metacpan or  search on metacpan

MANIFEST  view on Meta::CPAN

t/unit/queue_job/fetch_and_download_inventory.t
t/unit/queue_job/iterator.t
t/unit/queue_job/list_vaults.t
t/unit/queue_job/multipart_create.t
t/unit/queue_job/multipart_finish.t
t/unit/queue_job/multipart_part.t
t/unit/queue_job/retrieve.t
t/unit/queue_job/retrieve_inventory.t
t/unit/queue_job/upload.t
t/unit/queue_job/upload_multipart.t
t/unit/queue_job/verify.t
t/unit/queue_job/verify_and_upload.t
t/unit/queue_job_result.t
t/unit/shahash.t
t/unit/string_escape.t
t/unit/sysread_syswrite_unit.t
t/unit/test_test.t
t/unit/u_treehash.t
test.t

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

		my $r = $req->delete_vault($data->{name});
		confess unless $r;
		$result = { };
		$console_out = "Deleted vault $data->{name}";
	} elsif ($action eq 'list_vaults') {
		my $req = App::MtAws::GlacierRequest->new($self->{options});
		my $r = $req->list_vaults($data->{marker});
		confess unless $r;
		$result = { response => $r };
		$console_out = "Getting vault list (".($data->{marker} ? "next page: $data->{marker}" : "first page").")";
	} elsif ($action eq 'verify_file') {
		my $th = App::MtAws::TreeHash->new();
		my $binaryfilename = binaryfilename $data->{filename};
		die exception file_is_zero => "File size is zero (and it was not when we read directory listing). Filename: %string filename%",
			filename => $data->{filename}
				unless -s $binaryfilename;

		open_file(my $F, $data->{filename}, mode => '<', binary => 1) or
			die exception upload_file_open_error => "Unable to open task file %string filename% for reading, errno=%errno%",
				filename => $data->{filename}, 'ERRNO'; # TODO: test

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

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

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

				}
				$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')))) {

lib/App/MtAws/QueueJob/Verify.pm  view on Meta::CPAN

use App::MtAws::QueueJobResult;
use base 'App::MtAws::QueueJob';

sub init
{
	my ($self) = @_;
	defined($self->{filename}) || confess "no filename";
	defined($self->{relfilename}) || confess "no relfilename";
	$self->{treehash}||confess;
	$self->enter('verify');
}

sub on_verify
{
	my ($self) = @_;
	return state "wait", task "verify_file", { map { $_ => $self->{$_} } qw/filename relfilename treehash/ } => sub {
		my ($args) = @_;
		defined($self->{match} = $args->{match}) or confess;
		state("done")
	}
}

1;

lib/App/MtAws/QueueJob/VerifyAndUpload.pm  view on Meta::CPAN

	defined($self->{filename})||confess "no filename";
	defined($self->{relfilename}) || confess "no relfilename";
	defined($self->{delete_after_upload}) || confess "delete_after_upload must be defined";
	$self->{partsize}||confess;
	$self->{treehash}||confess;
	if ($self->{delete_after_upload}) {
		confess "archive_id must present if you're deleting" unless $self->{archive_id};
	} else {
		confess "archive_id not needed here" if $self->{archive_id};
	}
	$self->enter("verify");
	return $self;
}


sub on_verify
{
	my ($self) = @_;
	return
		state("wait"),
		job( App::MtAws::QueueJob::Verify->new( map { $_ => $self->{$_} } qw/filename relfilename treehash/ ), sub {
			my $j = shift;
			confess unless defined $j->{match};
			$j->{match} ? state("done") : state("upload");
		});
}

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

		my %args = (size => $size, archive_id => 'abc', jobid => 'somejob', file_downloads => { 'segment-size' => $segment_size},
			relfilename => 'def', filename => '/path/def', mtime => 456, treehash => 'wedontneedit');

		my $j = App::MtAws::QueueJob::Download->new(%args);

		$test_cb->($j, 0, { %args, tempfile => "sometempfilename" });
	}
}


sub verify_parts
{
	my ($parts, $size, $segment_size, $expected_sizes) = @_;

	my @expected = $expected_sizes ? @$expected_sizes : ();

	# auto check that position that we're got are correct
	my $expect_position = 0;
	my $odd_size_seen = 0;
	for my $part (@$parts) {
		is $part->{position}, $expect_position;

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

		if ($part->{download_size} != $segment_size * ONE_MB) {
			ok !$odd_size_seen, "current size down not match segment-size, but it's first time";
			$odd_size_seen = 1;
		}
	}
	is $expect_position, $size;
	is scalar @expected, 0;
}

sub verify_res
{
	my ($res, $args) = @_;
	cmp_deeply $res,
		App::MtAws::QueueJobResult->full_new(
			task => {
				args => {
					(map { $_ => $args->{$_} } qw/filename jobid relfilename archive_id tempfile/),
					download_size => code(sub{ shift > 0 }),
					position => code(sub{ defined shift }),
				},

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

			confess if $i++ > 1000; # protection
			my $res = $j->next;
			if ($res->{code} eq JOB_OK) {
				push @parts, { download_size => $res->{task}{args}{download_size}, position => $res->{task}{args}{position} };
			} elsif ($res->{code} eq JOB_WAIT) {
				last;
			} else {
				confess;
			}
		}
		verify_parts(\@parts, $size, $segment_size, $expected_sizes);
	});
}


sub test_case_late_finish
{
	my ($prepare_cb, $size, $segment_size, $expected_sizes) = @_;
	$prepare_cb->($size, $segment_size, sub {
		my ($j, $check_tmpfile, $args) = @_;

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

		my $i = 0;
		while() {
			confess if $i++ > 1000;

			my $res = $j->next;

			ok $j->{i_tmp}, "tempfile object is defined" if $check_tmpfile;

			if ($res->{code} eq JOB_OK) {
				verify_res($res, $args);
				push @parts, { download_size => $res->{task}{args}{download_size}, position => $res->{task}{args}{position}, cb => $res->{task}{cb_task_proxy} };
			} elsif ($res->{code} eq JOB_WAIT) {
				last;
			} else {
				confess;
			}
		}

		verify_parts(\@parts, $size, $segment_size, $expected_sizes);

		my $remember_tempfile;
		if ($check_tmpfile) {
			$remember_tempfile = $j->{i_tmp};
			ok $remember_tempfile, "tempfile object is defined";
		}
		expect_wait($j); # again, wait
		$_->{cb}->() for (@parts);
		expect_done($j);
		if ($check_tmpfile) {

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

			confess if $i++ > 1000;

			my $res = $j->next;

			if ($check_tmpfile && !$remember_tempfile) {
				ok $j->{i_tmp}, "tempfile object is defined";
				$remember_tempfile = $j->{i_tmp};
			}

			if ($res->{code} eq JOB_OK) {
				verify_res($res, $args);
				push @parts, { download_size => $res->{task}{args}{download_size}, position => $res->{task}{args}{position} };
				$res->{task}{cb_task_proxy}->();
			} elsif ($res->{code} eq JOB_DONE) {
				last;
			} else {
				confess;
			}
		}

		verify_parts(\@parts, $size, $segment_size, $expected_sizes);
		ok $remember_tempfile->{_mock_permanent}, "tempfile now permanent" if $check_tmpfile; # it's undef in $j, but we remembered it
		ok ! defined $j->{i_tmp}, "tempfile removed from job";
	});
}

{
	package QE;
	use MyQueueEngine;
	use base q{MyQueueEngine};

t/lib/DownloadSegmentsTest.pm  view on Meta::CPAN

	}
};

sub test_case_random_finish
{
	my ($prepare_cb, $size, $segment_size, $workers, $expected_sizes) = @_;
	$prepare_cb->($size, $segment_size, sub {
		my ($j, $args) = @_;
		my $q = QE->new(n => $workers);
		$q->process($j);
		verify_parts([ sort { $a->{position} <=> $b->{position} } @{ $q->{res} } ], $size, $segment_size, $expected_sizes);
	});
}



sub test_case_full
{
	my ($prepare_cb, $size, $segment_size, $expected_sizes) = @_;
	test_case_late_finish($prepare_cb, $size, $segment_size,  $expected_sizes);
	test_case_early_finish($prepare_cb, $size, $segment_size, $expected_sizes);

t/lib/VerifyTest.pm  view on Meta::CPAN

package VerifyTest;

use strict;
use warnings;
use Test::Deep;
use App::MtAws::QueueJobResult;
use App::MtAws::QueueJob::Verify;
use QueueHelpers;


sub expect_verify
{
	my ($j, $filename, $relfilename, $treehash, %args_opts) = @_;
	
	my %args = (verify_value => 42, %args_opts);
	
	
	cmp_deeply my $res = $j->next,
		App::MtAws::QueueJobResult->full_new(
			task => {
				args => {
					filename => $filename,
					relfilename => $relfilename,
					treehash => $treehash,
				},
				action => 'verify_file',
				cb => test_coderef,
				cb_task_proxy => test_coderef,
			},
			code => JOB_OK,
		);
	
	expect_wait($j);
	call_callback($res, match => $args{verify_value});
}


1;

t/unit/cmd_sync.t  view on Meta::CPAN

				my ($options, $j, $file, $toreturn) = @_;
				App::MtAws::Command::Sync->expects("should_upload")->returns(sub {
					my ($opt, $f, $absfilename) = @_;
					cmp_deeply $opt, $options;
					cmp_deeply $f, $file;
					is $absfilename, $j->absfilename($file->{relfilename});
					return $toreturn;
				})->once;
			}

			sub verify_create_job
			{
				my ($options, $j, $file, $rec) = @_;
				ok $rec->isa('App::MtAws::QueueJob::Upload');
				is $rec->{partsize}, $options->{partsize}*1024*1024;
				is $rec->{relfilename}, $file->{relfilename};
				is $rec->{filename}, $j->absfilename($file->{relfilename});
				ok $rec->{delete_after_upload};
				is $rec->{archive_id}, $file->{archive_id};
			}

			sub verify_treehash_job
			{
				my ($options, $j, $file, $rec) = @_;
				ok $rec->isa('App::MtAws::QueueJob::VerifyAndUpload');
				is $rec->{filename}, $j->absfilename($file->{relfilename});
				is $rec->{relfilename}, $file->{relfilename};
				ok $rec->{delete_after_upload};
				is $rec->{archive_id}, $file->{archive_id};
				is $rec->{treehash}, $file->{treehash};
				is $rec->{partsize}, $options->{partsize}*1024*1024;
			}

t/unit/cmd_sync.t  view on Meta::CPAN

				$j->{listing}{existing} = [];
				ok !defined App::MtAws::Command::Sync::next_modified($options, $j);
			};

			it "should work when should_upload returns SHOULD_CREATE" => sub {
				my $file = {relfilename => 'file1', archive_id => 'zz1'};
				$j->{listing}{existing} = [$file];
				$j->_add_filename($file);
				expect_should_upload($options, $j, $file, App::MtAws::Command::Sync::SHOULD_CREATE());
				my $rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_create_job($options, $j, $file, $rec);

				is scalar @{ $j->{listing}{existing} }, 0;
				ok !defined (App::MtAws::Command::Sync::next_modified($options, $j));
			};

			it "should work with two files" => sub {
				my $file1 = {relfilename => 'file1', archive_id => 'zz1'};
				my $file2 = {relfilename => 'file2', archive_id => 'zz2'};
				$j->{listing}{existing} = [$file1, $file2];
				$j->_add_filename($file1);
				$j->_add_filename($file2);
				expect_should_upload($options, $j, $file1, App::MtAws::Command::Sync::SHOULD_CREATE());
				my $rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_create_job($options, $j, $file1, $rec);

				is scalar @{ $j->{listing}{existing} }, 1;

				expect_should_upload($options, $j, $file2, App::MtAws::Command::Sync::SHOULD_CREATE());
				$rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_create_job($options, $j, $file2, $rec);
			};

			it "should work with latest version of file" => sub {
				my $file = {relfilename => 'file1', size => 123};
				$j->{listing}{existing} = [$file];
				$j->_add_filename({relfilename => 'file1', archive_id => 'zz1', size => 123, time => 42, mtime => 111, , treehash => 'abc0'});
				$j->_add_filename(my $r = {relfilename => 'file1', archive_id => 'zz2', size => 123, time => 42, mtime => 113, treehash => 'abc'});
				$j->_add_filename({relfilename => 'file1', archive_id => 'zz3', size => 123, time => 42, mtime => 112, , treehash => 'abc2'});
				expect_should_upload($options, $j, $r, App::MtAws::Command::Sync::SHOULD_TREEHASH());
				my $rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_treehash_job($options, $j, $r, $rec);
				is scalar @{ $j->{listing}{existing} }, 0;
			};

			it "should call latest() to get latest version of file" => sub {
				my $file = {relfilename => 'file1', size => 123};
				$j->{listing}{existing} = [$file];
				$j->_add_filename({relfilename => 'file1', archive_id => 'zz1', size => 123, time => 42, mtime => 111, , treehash => 'abc0'});
				$j->_add_filename(my $r = {relfilename => 'file1', archive_id => 'zz2', size => 123, time => 42, mtime => 113, treehash => 'abc'});
				$j->_add_filename({relfilename => 'file1', archive_id => 'zz3', size => 123, time => 42, mtime => 112, , treehash => 'abc2'});
				expect_should_upload($options, $j, $r, App::MtAws::Command::Sync::SHOULD_TREEHASH());
				App::MtAws::Journal->expects("latest")->returns(sub{ is $_[1], "file1"; $r})->once;
				App::MtAws::Command::Sync::next_modified($options, $j);
			};

			it "should work when should_upload returns SHOULD_TREEHASH" => sub {
				my $file = {relfilename => 'file1', archive_id => 'zz1', treehash => 'abcdef'};
				$j->{listing}{existing} = [$file];
				$j->_add_filename($file);
				expect_should_upload($options, $j, $file, App::MtAws::Command::Sync::SHOULD_TREEHASH());
				my $rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_treehash_job($options, $j, $file, $rec);

				is scalar @{ $j->{listing}{existing} }, 0;
				ok !defined (App::MtAws::Command::Sync::next_modified($options, $j));
			};

			it "should skip to next file when should_upload returns SHOULD_NOACTION" => sub {
				for (1..10) {
					my $file = {relfilename => "file$_", archive_id => "zz$_"};
					push @{ $j->{listing}{existing} }, $file;
					$j->_add_filename($file);
				}

				my $file;
				App::MtAws::Command::Sync->expects("should_upload")->returns(sub {
					my ($opt, $f, $absfilename) = @_;
					$file = $f;
					return $f->{relfilename} eq 'file7' ? App::MtAws::Command::Sync::SHOULD_CREATE() : App::MtAws::Command::Sync::SHOULD_NOACTION();
				})->exactly(10);

				my $rec = App::MtAws::Command::Sync::next_modified($options, $j);
				verify_create_job($options, $j, $file, $rec);

				is scalar @{ $j->{listing}{existing} }, 3;
				ok !defined App::MtAws::Command::Sync::next_modified($options, $j);
			};

			it "should confess when should_upload returns something else" => sub {
				my $file = {relfilename => 'file1', archive_id => 'zz1'};
				$j->{listing}{existing} = [$file];
				$j->_add_filename($file);
				expect_should_upload($options, $j, $file, 7656348);

t/unit/glacier_request.t  view on Meta::CPAN

					}
				}, exception 'http_unexpected_reply' => "Unexpected reply from remote server";
			}
		};
	};
	describe "should detect CA error" => sub {
		it "should raise exception if CA error found" => sub {
			my $g = App::MtAws::GlacierRequest->new({%common_options});
			($g->{method}, $g->{url}) = ('GET', 'test');
## no Test::Tabs
			LWP::UserAgent->expects('request')->returns(HTTP::Response->new(500, "Can't verify SSL peers without knowing which Certificate Authorities to trust", ["Client-Warning" => "Internal response"], <<"END"))->once;
Can't verify SSL peers without knowing which Certificate Authorities to trust

This problem can be fixed by either setting the PERL_LWP_SSL_CA_FILE
envirionment variable or by installing the Mozilla::CA module.

To disable verification of SSL peers set the PERL_LWP_SSL_VERIFY_HOSTNAME
envirionment variable to 0.  If you do this you can't be sure that you
communicate with the expected peer.
END
## use Test::Tabs
			assert_raises_exception sub {
				$g->perform_lwp();
			}, exception 'lwp_ssl_ca_exception' =>
				'Can\'t verify SSL peers without knowing which Certificate Authorities to trust. Probably "Mozilla::CA" module is missing';
		};
	};
};

sub header
{
	{ name => $_[0], value => $_[1] }
}

sub headers {

t/unit/queue_job/verify.t  view on Meta::CPAN

	ok !eval { App::MtAws::QueueJob::Verify->new( map { $_ => $opts{$_} } qw/relfilename treehash/); 1; };
	ok eval { App::MtAws::QueueJob::Verify->new((map { $_ => $opts{$_} } qw/relfilename treehash/), filename => 0); 1; };
	ok !eval { App::MtAws::QueueJob::Verify->new(map { $_ => $opts{$_} } qw/filename treehash/); 1; };
	ok eval { App::MtAws::QueueJob::Verify->new((map { $_ => $opts{$_} } qw/filename treehash/), relfilename => 0); 1; };
}

sub test_case
{
	my ($filename, $relfilename) = @_;
	my $j = App::MtAws::QueueJob::Verify->new( treehash => $opts{treehash}, filename => $filename, relfilename => $relfilename);
	VerifyTest::expect_verify($j, $filename, $relfilename, $opts{treehash}, verify_value => 42);
	expect_done($j);
	is $j->{match}, 42;
}

test_case $opts{filename}, $opts{relfilename};
test_case 0, 0;

1;

t/unit/queue_job/verify_and_upload.t  view on Meta::CPAN

	} else {
		$opts{filename} = '0';
		$opts{relfilename} = '0';
	}

	my @main_opts = (map { $_ => $opts{$_} } qw/filename relfilename treehash partsize/);
	{
		my @opts = (@main_opts, delete_after_upload => 1, archive_id => 'def');
		{
			my $j = App::MtAws::QueueJob::VerifyAndUpload->new(@opts);
			VerifyTest::expect_verify($j, $opts{filename}, $opts{relfilename}, $opts{treehash}, verify_value => 1);
			expect_done($j);
		}

		{
			my $j = App::MtAws::QueueJob::VerifyAndUpload->new(@opts);
			VerifyTest::expect_verify($j, $opts{filename}, $opts{relfilename}, $opts{treehash}, verify_value => 0);
			UploadMultipartTest::expect_upload_multipart($j, 123, $opts{partsize}, $opts{relfilename}, 'xyz');
			DeleteTest::expect_delete($j, $opts{relfilename}, $opts{archive_id});
			expect_done($j);
		}
	}
	{
		my @opts = (@main_opts, delete_after_upload => 0);
		{
			my $j = App::MtAws::QueueJob::VerifyAndUpload->new(@opts);
			VerifyTest::expect_verify($j, $opts{filename}, $opts{relfilename}, $opts{treehash}, verify_value => 1);
			expect_done($j);
		}

		{
			my $j = App::MtAws::QueueJob::VerifyAndUpload->new(@opts);
			VerifyTest::expect_verify($j, $opts{filename}, $opts{relfilename}, $opts{treehash}, verify_value => 0);
			UploadMultipartTest::expect_upload_multipart($j, 123, $opts{partsize}, $opts{relfilename}, 'xyz');
			expect_done($j);
		}
	}
}

# test dry-run

{
	my $j = App::MtAws::QueueJob::VerifyAndUpload->new( map { $_ => $opts{$_} } @all);