The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use t::TestHTTP;

use IO::Async::Test;
use IO::Async::Loop;

use HTTP::Response;

use Net::Async::Webservice::S3;

my $loop = IO::Async::Loop->new;
testing_loop( $loop );

my $s3 = Net::Async::Webservice::S3->new(
   max_retries => 1,
   http => my $http = TestHTTP->new,
   access_key => 'K'x20,
   secret_key => 's'x40,
);

$loop->add( $s3 );

# Delete
{
   my $f = $s3->delete_object(
      bucket => "bucket",
      key    => "three",
   );

   my $req;
   wait_for { $req = $http->pending_request or $f->is_ready };
   $f->get if $f->is_ready and $f->failure;

   is( $req->method,         "DELETE",                  'Request method' );
   is( $req->uri->authority, "bucket.s3.amazonaws.com", 'Request URI authority' );
   is( $req->uri->path,      "/three",                  'Request URI path' );

   $http->respond(
      HTTP::Response->new( 200, "OK", [], "" )
   );

   wait_for { $f->is_ready };

   ok( !$f->failure, '$f succeeds' );
}

# Test that timeout argument is set
{
   my $f;
   my $req;

   $s3->configure( timeout => 10 );
   $f = $s3->delete_object(
      bucket => "bucket",
      key    => "-four-",
   );

   wait_for { $req = $http->pending_request or $f->is_ready };
   $f->get if $f->is_ready and $f->failure;

   is( $req->header( "X-NaHTTP-Timeout" ), 10, 'Request has timeout set for configured' );
   $http->respond( 200, "OK", [] );

   $f = $s3->delete_object(
      bucket => "bucket",
      key    => "-four-",
      timeout => 20,
   );

   wait_for { $req = $http->pending_request or $f->is_ready };
   $f->get if $f->is_ready and $f->failure;

   is( $req->header( "X-NaHTTP-Timeout" ), 20, 'Request has timeout set for immediate' );
   $http->respond( 200, "OK", [] );
}

done_testing;