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 Test::Identity;
use IO::Async::Test;
use IO::Async::Loop;

use Net::Async::HTTP;

my $CRLF = "\x0d\x0a"; # because \r\n isn't portable

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

my $http = Net::Async::HTTP->new(
   user_agent => "", # Don't put one in request headers
);

$loop->add( $http );

{
   my $redir_response;
   my $location;

   my $response;

   my $peersock;
   no warnings 'redefine';
   local *IO::Async::Handle::connect = sub {
      my $self = shift;
      my %args = @_;

      $args{host}    eq "host0" or die "Expected $args{host} eq host0";
      $args{service} eq "80"    or die "Expected $args{service} eq 80";

      ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!";
      $self->set_handle( $selfsock );

      return Future->new->done( $self );
   };

   my $future = $http->do_request(
      uri => URI->new( "http://host0/doc" ),

      timeout => 10,

      on_response => sub { $response = $_[0] },
      on_redirect => sub { ( $redir_response, $location ) = @_ },
      on_error    => sub { die "Test died early - $_[0]" },
   );

   ok( defined $future, '$future defined for redirect' );

   my $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $request_stream =~ s/^(.*)$CRLF//;
   my $req_firstline = $1;

   is( $req_firstline, "GET /doc HTTP/1.1", 'First line for request' );

   # Trim headers
   $request_stream =~ s/^(.*)$CRLF$CRLF//s;

   $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" .
                        "Content-Length: 0$CRLF" .
                        "Location: http://host0/get_doc?name=doc$CRLF" .
                        "Connection: Keep-Alive$CRLF" .
                        "$CRLF" );

   wait_for { defined $location };

   is( $location, "http://host0/get_doc?name=doc", 'Redirect happens' );

   ok( !$future->is_ready, '$future is not yet ready after redirect' );

   $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $request_stream =~ s/^(.*)$CRLF//;
   $req_firstline = $1;

   is( $req_firstline, "GET /get_doc?name=doc HTTP/1.1", 'First line for redirected request' );

   # Trim headers
   $request_stream =~ s/^(.*)$CRLF$CRLF//s;

   $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" .
                        "Content-Length: 8$CRLF".
                        "Content-Type: text/plain$CRLF" .
                        "Connection: Keep-Alive$CRLF" .
                        "$CRLF" .
                        "Document" );

   wait_for { defined $response };

   is( $response->content_type, "text/plain", 'Content type of final response' );
   is( $response->content, "Document", 'Content of final response' );

   isa_ok( $response->previous, "HTTP::Response", '$response->previous' );

   my $previous = $response->previous;
   isa_ok( $previous->request->uri, "URI", 'Previous request URI is a URI' );
   is( $previous->request->uri, "http://host0/doc", 'Previous request URI string' );

   ok( $future->is_ready, '$future is now ready for final response' );
   identical( scalar $future->get, $response, '$future->get yields final response' );
}

{
   my $redir_response;
   my $location;

   my $response;

   my $peersock;
   no warnings 'redefine';
   local *IO::Async::Handle::connect = sub {
      my $self = shift;
      my %args = @_;

      $args{host}    eq "host1" or die "Expected $args{host} eq host1";
      $args{service} eq "80"    or die "Expected $args{service} eq 80";

      ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!";
      $self->set_handle( $selfsock );

      return Future->new->done( $self );
   };

   $http->do_request(
      uri => URI->new( "http://host1/somedir" ),

      timeout => 10,

      on_response => sub { $response = $_[0] },
      on_redirect => sub { ( $redir_response, $location ) = @_ },
      on_error    => sub { die "Test died early - $_[0]" },
   );

   my $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $request_stream =~ s/^(.*)$CRLF//;
   my $req_firstline = $1;

   is( $req_firstline, "GET /somedir HTTP/1.1", 'First line for request for local redirect' );

   # Trim headers
   $request_stream =~ s/^(.*)$CRLF$CRLF//s;

   $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" .
                        "Content-Length: 0$CRLF" .
                        "Location: /somedir/$CRLF" .
                        "$CRLF" );

   undef $location;
   wait_for { defined $location };

   is( $location, "http://host1/somedir/", 'Local redirect happens' );

   $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $request_stream =~ s/^(.*)$CRLF//;
   $req_firstline = $1;

   is( $req_firstline, "GET /somedir/ HTTP/1.1", 'First line for locally redirected request' );

   # Trim headers
   $request_stream =~ s/^(.*)$CRLF$CRLF//s;

   $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" .
                        "Content-Length: 9$CRLF".
                        "Content-Type: text/plain$CRLF" .
                        "$CRLF" .
                        "Directory" );

   undef $response;
   wait_for { defined $response };

   is( $response->content_type, "text/plain", 'Content type of final response to local redirect' );
   is( $response->content, "Directory", 'Content of final response to local redirect' );
}

# 304 Not Modified should not redirect (RT98093)
{
   my $peersock;
   no warnings 'redefine';
   local *IO::Async::Handle::connect = sub {
      my $self = shift;
      my %args = @_;

      $args{host}    eq "host2" or die "Expected $args{host} eq host2";

      ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!";
      $self->set_handle( $selfsock );

      return Future->new->done( $self );
   };

   my $f = $http->do_request(
      uri => URI->new( "http://host2/unmod" ),

      on_redirect => sub { die "Should not be redirected" },
   );

   my $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $peersock->syswrite( "HTTP/1.1 304 Not Modified$CRLF" .
                        $CRLF ); # 304 has no body

   wait_for { $f->is_ready };

   my $response = $f->get;
   is( $response->code, 304, 'HTTP 304 response not redirected' );
}

# Methods other than GET and HEAD should not redirect
{
   my $peersock;
   no warnings 'redefine';
   local *IO::Async::Handle::connect = sub {
      my $self = shift;
      my %args = @_;

      $args{host}    eq "host3" or die "Expected $args{host} eq host3";

      ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!";
      $self->set_handle( $selfsock );

      return Future->new->done( $self );
   };

   my $f = $http->do_request(
      method => "PUT",
      uri    => URI->new( "http://host3/somewhere" ),
      content => "new content",
      content_type => "text/plain",

      on_redirect => sub { die "Should not be redirected" },
   );

   my $request_stream = "";
   wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream;

   $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" .
                        "Content-Length: 0$CRLF" .
                        "Location: /somewhere/else$CRLF" .
                        $CRLF );

   wait_for { $f->is_ready };

   my $response = $f->get;
   is( $response->code, 301, 'POST request not redirected' );
}

done_testing;