1package Shared::Examples::Net::Amazon::S3;
2# ABSTRACT: used for testing and as example
3$Shared::Examples::Net::Amazon::S3::VERSION = '0.99';
4use strict;
5use warnings;
6
7use parent qw[ Exporter::Tiny ];
8
9use Hash::Util;
10use Ref::Util (
11	qw[ is_regexpref ],
12);
13
14use Test::Deep;
15use Test::More;
16use Test::LWP::UserAgent;
17
18use Net::Amazon::S3;
19
20use Shared::Examples::Net::Amazon::S3::API;
21use Shared::Examples::Net::Amazon::S3::Client;
22use Shared::Examples::Net::Amazon::S3::Request;
23
24our @EXPORT_OK = (
25	qw[ s3_api_with_signature_4 ],
26	qw[ s3_api_with_signature_2 ],
27	qw[ expect_net_amazon_s3_feature ],
28	qw[ expect_net_amazon_s3_operation ],
29	qw[ expect_operation_list_all_my_buckets ],
30	qw[ expect_operation_bucket_create ],
31	qw[ expect_operation_bucket_delete ],
32	qw[ with_fixture ],
33	qw[ fixture ],
34	qw[ with_response_fixture ],
35);
36
37my %fixtures;
38sub fixture {
39	my ($name) = @_;
40
41	$fixtures{$name} = eval "require Shared::Examples::Net::Amazon::S3::Fixture::$name"
42		unless defined $fixtures{$name};
43
44	die "Fixture $name not found: $@"
45		unless defined $fixtures{$name};
46
47	return +{ %{ $fixtures{$name} } };
48}
49
50sub with_fixture {
51	my ($name) = @_;
52
53	my $fixture = fixture ($name);
54	return wantarray
55		? %$fixture
56		: $fixture
57		;
58}
59
60sub with_response_fixture {
61	my ($name) = @_;
62
63	my $fixture = fixture ($name);
64	my $response_fixture = {};
65
66	for my $key (keys %$fixture) {
67		my $new_key;
68		$new_key ||= "with_response_data" if $key eq 'content';
69		$new_key ||= "with_$key" if $key =~ m/^response/;
70		$new_key ||= "with_response_header_$key";
71
72		$response_fixture->{$new_key} = $fixture->{$key};
73	}
74
75	return wantarray
76		? %$response_fixture
77		: $response_fixture
78		;
79}
80
81
82sub s3_api {
83	my $api = Net::Amazon::S3->new (@_);
84
85	$api->ua (Test::LWP::UserAgent->new (network_fallback => 0));
86
87	$api;
88}
89
90sub s3_api_mock_http_response {
91	my ($self, $api, %params) = @_;
92
93	$params{with_response_code} ||= HTTP::Status::HTTP_OK;
94
95	my %headers = (
96		content_type => 'application/xml',
97		(
98			map {
99				m/^with_response_header_(.*)/;
100				defined $1 && length $1
101					? ($1 => $params{$_})
102					: ()
103			} keys %params
104		),
105		%{ $params{with_response_headers} || {} },
106	);
107
108	$api->ua->map_response (
109		sub {
110			${ $params{into} } = $_[0];
111			1;
112		},
113		HTTP::Response->new (
114			$params{with_response_code},
115			HTTP::Status::status_message ($params{with_response_code}),
116			[ %headers ],
117			$params{with_response_data},
118		),
119	);
120}
121
122sub s3_api_with_signature_4 {
123	s3_api (
124		@_,
125		aws_access_key_id     => 'AKIDEXAMPLE',
126		aws_secret_access_key => 'wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY',
127		authorization_method  => 'Net::Amazon::S3::Signature::V4',
128		secure                => 1,
129		use_virtual_host      => 1,
130	);
131}
132
133sub s3_api_with_signature_2 {
134	s3_api (
135		@_,
136		aws_access_key_id     => 'AKIDEXAMPLE',
137		aws_secret_access_key => 'wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY',
138		authorization_method  => 'Net::Amazon::S3::Signature::V2',
139		secure                => 1,
140		use_virtual_host      => 1,
141	);
142}
143
144sub expect_net_amazon_s3_feature {
145	my ($title, %params) = @_;
146
147	my $s3 = delete $params{with_s3};
148	my $feature = delete $params{feature};
149	my $expectation = "expect_$feature";
150
151	local $Test::Builder::Level = $Test::Builder::Level + 1;
152
153	subtest $title => sub {
154		plan tests => 2;
155
156		if (my $code = Shared::Examples::Net::Amazon::S3::API->can ($expectation)) {
157			$code->( "using S3 API" => (
158				with_s3 => $s3,
159				%params
160			));
161		} else {
162			fail "Net::Amazon::S3 feature expectation $expectation not found";
163		}
164
165		if (my $code = Shared::Examples::Net::Amazon::S3::Client->can ($expectation)) {
166			$code->( "using S3 Client" => (
167				with_client => Net::Amazon::S3::Client->new (s3 => $s3),
168				%params
169			));
170		} else {
171			fail "Net::Amazon::S3::Client feature expectation $expectation not found";
172		}
173	};
174}
175
176sub _operation_parameters {
177	my ($params, @names) = @_;
178	my $map = {};
179	$map = shift @names if Ref::Util::is_plain_hashref ($names[0]);
180
181	return
182		map +( ($map->{$_} || $_) => $params->{"with_$_"} ),
183		grep exists $params->{"with_$_"},
184		@names
185		;
186}
187
188sub _with_keys {
189	map "with_$_", @_;
190}
191
192sub _keys_operation () {
193	return (
194		qw[ -shared_examples ],
195		qw[ -method ],
196		qw[ with_s3 ],
197		qw[ with_client ],
198		qw[ shared_examples ],
199		qw[ with_response_code ],
200		qw[ with_response_data ],
201		qw[ with_response_headers ],
202		qw[ with_response_header_content_type ],
203		qw[ with_response_header_content_length ],
204		qw[ expect_s3_err ],
205		qw[ expect_s3_errstr ],
206		qw[ expect_data ],
207		qw[ expect_request ],
208		qw[ expect_request_content ],
209		qw[ expect_request_headers ],
210		qw[ throws ],
211	);
212}
213
214sub _expect_request {
215	my ($request, $expect, $title) = @_;
216
217	local $Test::Builder::Level = $Test::Builder::Level + 1;
218
219	my ($method, $uri) = %$expect;
220	cmp_deeply
221		$request,
222		all (
223			methods (method => $method),
224			methods (uri => methods (as_string => $uri)),
225		),
226		$title || 'expect request'
227		;
228}
229
230sub _expect_request_content {
231	my ($request, $expected, $title) = @_;
232
233	local $Test::Builder::Level = $Test::Builder::Level + 1;
234
235	my $got = Shared::Examples::Net::Amazon::S3::Request::_canonical_xml ($request->content);
236	$expected = Shared::Examples::Net::Amazon::S3::Request::_canonical_xml ($expected);
237
238	cmp_deeply $got, $expected, $title || "expect request content";
239}
240
241sub _expect_request_headers {
242	my ($request, $expected, $title) = @_;
243
244	local $Test::Builder::Level = $Test::Builder::Level + 1;
245
246	my %got = map +($_ => scalar $request->header ($_)), keys %$expected;
247
248	cmp_deeply
249		\ %got,
250		$expected,
251		$title || "expect request headers"
252		;
253}
254
255sub _expect_s3_err {
256	my ($got, $expected, $title) = @_;
257
258	SKIP: {
259		skip "Net::Amazon::S3->err test irrelevant for Client", 1
260			if eq_deeply $got, obj_isa ('Net::Amazon::S3::Client');
261
262		cmp_deeply $got, methods (err => $expected), $title || 'expect S3->err';
263	}
264}
265
266sub _expect_s3_errstr {
267	my ($got, $expected, $title) = @_;
268
269	SKIP: {
270		skip "Net::Amazon::S3->errstr test irrelevant for Client", 1
271			if eq_deeply $got, obj_isa ('Net::Amazon::S3::Client');
272
273		cmp_deeply $got, methods (errstr => $expected), $title || 'expect S3->errstr';
274	}
275}
276
277sub _expect_operation {
278	my ($title, %params) = @_;
279
280	local $Test::Builder::Level = $Test::Builder::Level + 1;
281
282	my $class = delete $params{-shared_examples};
283	my $operation = delete $params{-operation};
284
285	my $api = $class->_default_with_api (\%params);
286	$class->_mock_http_response ($api, %params, into => \ (my $request));
287
288	if (my $code = $class->can ($operation)) {
289		subtest $title => sub {
290			plan tests => 1
291				+ int (!! exists $params{expect_request})
292				+ int (!! exists $params{expect_request_content})
293				+ int (!! exists $params{expect_request_headers})
294				+ int (!! exists $params{expect_s3_err})
295				+ int (!! exists $params{expect_s3_errstr})
296				;
297
298			my $got;
299			my $lives = eval { $got = $api->$code (%params); 1 };
300			my $error = $@;
301
302			if ($lives) {
303				exists $params{throws}
304					? fail "operation expected to throw but lives"
305					: cmp_deeply $got, $params{expect_data}, "expect operation return data"
306					;
307			}
308			else {
309				$params{throws} = re $params{throws}
310					if is_regexpref $params{throws};
311				$params{throws} = obj_isa $params{throws}
312					if defined $params{throws} && ! ref $params{throws};
313
314				defined $params{throws}
315					? cmp_deeply $error, $params{throws}, "it should throw"
316					: do { fail "operation expected to live but died" ; diag $error }
317					;
318			}
319
320			_expect_request $request, $params{expect_request}
321				if exists $params{expect_request};
322			_expect_request_content $request, $params{expect_request_content}
323				if exists $params{expect_request_content};
324			_expect_request_headers ($request, $params{expect_request_headers})
325				if exists $params{expect_request_headers};
326
327			_expect_s3_err $api, $params{expect_s3_err}
328				if exists $params{expect_s3_err};
329			_expect_s3_errstr $api, $params{expect_s3_errstr}
330				if exists $params{expect_s3_errstr};
331		};
332	} else {
333		fail $title or diag "Operation ${class}::$operation not found";
334	}
335}
336
337sub _generate_operation_expectation {
338	my ($name, @parameters) = @_;
339
340	my @on = (
341		('bucket') x!! ($name =~ m/^ ( bucket | object )/x),
342		('key')    x!! ($name =~ m/^ ( object )/x),
343	);
344
345	my $on = "qw[ ${ \ join ' ', @on } ]";
346
347	eval <<"OPERATION_DECLARATION";
348		sub parameters_$name {
349			qw[ ${ \ join ' ', @parameters } ]
350		}
351
352		sub expect_operation_$name {
353			my (\$title, \%params) = \@_;
354			local \$Test::Builder::Level = \$Test::Builder::Level + 1;
355			Hash::Util::lock_keys \%params, _with_keys ($on, parameters_$name), _keys_operation;
356			_expect_operation \$title, \%params, -operation => 'operation_$name';
357		}
358OPERATION_DECLARATION
359}
360
361_generate_operation_expectation list_all_my_buckets =>
362	;
363
364_generate_operation_expectation bucket_acl_get =>
365	;
366
367_generate_operation_expectation bucket_acl_set =>
368	qw[ acl ],
369	qw[ acl_xml ],
370	qw[ acl_short ],
371	;
372
373_generate_operation_expectation bucket_create =>
374	qw[ acl ],
375	qw[ acl_short ],
376	qw[ region ],
377	;
378
379_generate_operation_expectation bucket_delete =>
380	;
381
382_generate_operation_expectation bucket_objects_list =>
383	qw[ delimiter ],
384	qw[ max_keys ],
385	qw[ marker ],
386	qw[ prefix ],
387	;
388
389_generate_operation_expectation bucket_objects_delete =>
390	qw[ keys ],
391	;
392
393_generate_operation_expectation object_acl_get =>
394	;
395
396_generate_operation_expectation object_acl_set =>
397	qw[ acl ],
398	qw[ acl_xml ],
399	qw[ acl_short ],
400	;
401
402_generate_operation_expectation object_create =>
403	qw[ headers ],
404	qw[ value ],
405	qw[ cache_control  ],
406	qw[ content_disposition  ],
407	qw[ content_encoding  ],
408	qw[ content_type  ],
409	qw[ encryption ],
410	qw[ expires ],
411	qw[ storage_class  ],
412	qw[ user_metadata ],
413	qw[ acl ],
414	qw[ acl_short ],
415	;
416
417_generate_operation_expectation object_delete =>
418	;
419
420_generate_operation_expectation object_fetch =>
421	qw[ range ],
422	;
423
424_generate_operation_expectation object_head =>
425	;
426
427_generate_operation_expectation bucket_tags_add =>
428	qw[ tags ],
429	;
430
431_generate_operation_expectation object_tags_add =>
432	qw[ tags ],
433	qw[ version_id ],
434	;
435
436_generate_operation_expectation bucket_tags_delete =>
437	;
438
439_generate_operation_expectation object_tags_delete =>
440	qw[ version_id ],
441	;
442
443
4441;
445
446__END__
447
448=pod
449
450=encoding UTF-8
451
452=head1 NAME
453
454Shared::Examples::Net::Amazon::S3 - used for testing and as example
455
456=head1 VERSION
457
458version 0.99
459
460=head1 AUTHOR
461
462Branislav Zahradník <barney@cpan.org>
463
464=head1 COPYRIGHT AND LICENSE
465
466This software is copyright (c) 2021 by Amazon Digital Services, Leon Brocard, Brad Fitzpatrick, Pedro Figueiredo, Rusty Conover, Branislav Zahradník.
467
468This is free software; you can redistribute it and/or modify it under
469the same terms as the Perl 5 programming language system itself.
470
471=cut
472