The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Furl::HTTP;
use Test::TCP;
use Test::Requires qw(Plack::Request HTTP::Body), 'Plack';
use Plack::Loader;
use Test::More;
use Plack::Request;
use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Proxy';

plan tests => (10*2 + 8)*3;

my $verbose = 1;
{
    package Test::HTTP::Proxy;
    use parent qw(HTTP::Proxy);
    sub log {
        my($self, $level, $prefix, $msg) = @_;
        ::note "$prefix: $msg" if $verbose;
    }
}

{
    package Test::UserAgent;
    use parent qw(LWP::UserAgent);
    use Test::More;

    sub real_httpd_port {
        my ($self, $port) = @_;
        $self->{httpd_port} = $port if defined $port;
        return $self->{httpd_port};
    }

    sub simple_request {
        my ($self, $req, @args) = @_;
        my $uri = $req->uri;
        my $host = $req->header('Host');

        if ($self->real_httpd_port) {
            # test for URL with a default port
            like $uri.q(), qr!^http://[^:]+/!,
                'No port number in the request line';
            unlike $host, qr!:!,
                'No port number in Host header';

            # replace the port number to correctly connect to the test server
            $uri->port($self->real_httpd_port);
        } else {
            # test for URL with non-default port

            like $uri.q(), qr!^http://[^/]+:[0-9]+/!,
                'A port number in the request line';
            like $host, qr/:[0-9]+$/,
                'A port number in Host header';
        }

        return $self->SUPER::simple_request($req, @args);
    }
}

my $via = "VIA!VIA!VIA!";

my $httpd = Test::TCP->new(code => sub {
    my $httpd_port = shift;
    Plack::Loader->auto(port => $httpd_port)->run(sub {
        my $env = shift;

        my $req = Plack::Request->new($env);
        is $req->path, '/foo';
        is $req->header('X-Foo'), "ppp";
        like $req->header('User-Agent'), qr/\A Furl::HTTP /xms;
        my $content = "Hello, foo";
        return [ 200,
                 [ 'Content-Length' => length($content) ],
                 [ $content ]
             ];
    });
});

sub client (%) {
    my (%args) = @_;
    for (1..3) { # run some times for testing keep-alive.
        my $furl = Furl::HTTP->new(proxy => $args{proxy});
        my ( undef, $code, $msg, $headers, $content ) =
            $furl->request(
                url     => $args{request},
                headers => [ "X-Foo" => "ppp" ]
            );
        is $code, 200, "request()";
        is $msg, "OK";
        is Furl::HTTP::_header_get($headers, 'Content-Length'), 10;
        is Furl::HTTP::_header_get($headers, 'Via'), $args{via};
        is $content, 'Hello, foo'
            or do{ require Devel::Peek; Devel::Peek::Dump($content) };
    }
}

sub test_agent () {
    return Test::UserAgent->new(
        env_proxy  => 1,
        keep_alive => 2,
        parse_head => 0,
    );
}

local $ENV{'HTTP_PROXY'} = '';

# Request target with non-default port

test_tcp(
    client => sub {
        my $proxy_port = shift;
        my $httpd_port = $httpd->port;
        client(
            proxy   => "http://127.0.0.1:$proxy_port",
            request => "http://127.0.0.1:$httpd_port/foo",
            via     => '1.0 VIA!VIA!VIA!',
        );
    },
    server => sub { # proxy server
        my $proxy_port = shift;
        my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via);
        $proxy->agent(test_agent);
        $proxy->start();
    },
);

# Request target with default port

test_tcp(
    client => sub {
        my $proxy_port = shift;
        my $httpd_port = $httpd->port;
        client(
            proxy   => "http://127.0.0.1:$proxy_port",
            request => "http://127.0.0.1/foo", # default port
            via     => '1.0 VIA!VIA!VIA!',
        );
    },
    server => sub { # proxy server
        my $proxy_port = shift;
        my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via);
        $proxy->agent(test_agent);
        $proxy->agent->real_httpd_port($httpd->port);
        $proxy->start();
    },
);

# SSL over proxy

test_tcp(
    client => sub {
        # emulate CONNECT for SSL proxying without a real SSL connection
        no warnings 'redefine';
        local *Furl::HTTP::connect_ssl_over_proxy = sub {
            my ($self, $proxy_host, $proxy_port, $host, $port, $timeout_at, $proxy_authorization) = @_;
            my $sock = $self->connect($proxy_host, $proxy_port, $timeout_at);
            my $p = "CONNECT $host:$port HTTP/1.0\015\012Server: $host\015\012";
            $p .= "\015\012";
            $self->write_all($sock, $p, $timeout_at) or fail;

            # read the entire response of CONNECT method
            my $buf = '';
            while ($buf !~ qr!(?:\015\012){2}!) {
                my $read = $self->read_timeout(
                    $sock, \$buf, $self->{bufsize}, length($buf), $timeout_at
                );
                defined $read or fail;
                $read != 0 or fail;
            }

            $sock;
        };

        my $proxy_port = shift;
        my $httpd_port = $httpd->port;
        client(
            proxy   => "http://127.0.0.1:$proxy_port",
            request => "https://127.0.0.1:$httpd_port/foo",
            # no via since the request goes directly to the origin server
        );
    },
    server => sub { # proxy server
        my $proxy_port = shift;
        my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via);
        $proxy->start();
    },
);