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