view release on metacpan or  search on metacpan

t/https_proxy.t  view on Meta::CPAN

#!/usr/bin/perl

# to run test with Net::SSL as backend set environment
# PERL_NET_HTTPS_SSL_SOCKET_CLASS=Net::SSL

use strict;
use warnings;
use Test::More;
use File::Temp 'tempfile';
use IO::Socket::INET;
use IO::Select;
use Socket 'MSG_PEEK';
use LWP::UserAgent;
use LWP::Protocol::https;

plan skip_all => "fork not implemented on this platform" if
    grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos );

eval { require IO::Socket::SSL }
    and $IO::Socket::SSL::VERSION >= 1.953
    and eval { require IO::Socket::SSL::Utils }
    or plan skip_all => "no recent version of IO::Socket::SSL::Utils";
IO::Socket::SSL::Utils->import;

# create CA -------------------------------------------------------------
my ($cacert,$cakey) = CERT_create( CA => 1 );
my $cafile = do {
    my ($fh,$fname) = tempfile( CLEANUP => 1 );
    print $fh PEM_cert2string($cacert);
    $fname
};

# create two web servers ------------------------------------------------
my (@server,@saddr);
for my $i (0,1) {
    my $server = IO::Socket::INET->new(
	LocalAddr => '127.0.0.1',
	LocalPort => 0, # let system pick port
	Listen => 10
    ) or die "failed to create INET listener";
    my $saddr = $server->sockhost.':'.$server->sockport;
    $server[$i] = $server;
    $saddr[$i]  = $saddr;
}

my @childs;
END { kill 9,@childs if @childs };
defined( my $pid = fork()) or die "fork failed: $!";

# child process runs _server and exits
if ( ! $pid ) {
    @childs = ();
    exit( _server());
}

# parent continues with closed server sockets
push @childs,$pid;
@server = ();

# check which SSL implementation Net::HTTPS uses
# Net::SSL behaves different than the default IO::Socket::SSL
my $netssl = $Net::HTTPS::SSL_SOCKET_CLASS eq 'Net::SSL';

# do some tests ----------------------------------------------------------
my %ua;
$ua{noproxy} = LWP::UserAgent->new(
    keep_alive => 10, # size of connection cache
    # server does not know the expected name and returns generic certificate
    ssl_opts => {
	verify_hostname => 0,
	SSL_ca_file => $cafile,
    }
);

$ua{proxy} = LWP::UserAgent->new(
    keep_alive => 10, # size of connection cache
    ssl_opts => {
	# Net::SSL cannot verify hostnames :(
	verify_hostname => $netssl ? 0: 1,
	SSL_ca_file => $cafile
    }
);
$ua{proxy_nokeepalive} = LWP::UserAgent->new(
    keep_alive => 0,
    ssl_opts => {
	# Net::SSL cannot verify hostnames :(
	verify_hostname => $netssl ? 0: 1,
	SSL_ca_file => $cafile
    }
);

# both lower- and upper-case versions are accepted by `env_proxy`, and
# the user may have any of them set: override them all
$ENV{HTTP_PROXY} = $ENV{HTTPS_PROXY} =
$ENV{http_proxy} = $ENV{https_proxy} = "http://foo:bar\@$saddr[0]";
$ua{proxy}->env_proxy;
$ua{proxy_nokeepalive}->env_proxy;
if ($netssl) {
    # Net::SSL cannot get user/pass from proxy url
    $ENV{HTTPS_PROXY_USERNAME} = 'foo';
    $ENV{HTTPS_PROXY_PASSWORD} = 'bar';
}

my @tests = (
    # the expected ids are connid.reqid[tunnel_auth][req_auth]@sslhost
    # because we run different sets of test depending on the SSL class
    # used by Net::HTTPS we replace connid with a letter and later
    # match it to a number

    # keep-alive for non-proxy http
    # requests to same target use same connection, even if intermixed
    [ 'noproxy', "http://$saddr[0]/foo",'A.1@nossl' ],
    [ 'noproxy', "http://$saddr[0]/bar",'A.2@nossl' ], # reuse conn#1
    [ 'noproxy', "http://$saddr[1]/foo",'B.1@nossl' ],
    [ 'noproxy', "http://$saddr[1]/bar",'B.2@nossl' ], # reuse conn#2
    [ 'noproxy', "http://$saddr[0]/tor",'A.3@nossl' ], # reuse conn#1 again
    [ 'noproxy', "http://$saddr[1]/tor",'B.3@nossl' ], # reuse conn#2 again
    # keep-alive for proxy http
    # use the same proxy connection for all even if the target host differs
    [ 'proxy', "http://foo/foo",'C.1.auth@nossl' ],
    [ 'proxy', "http://foo/bar",'C.2.auth@nossl' ],

t/https_proxy.t  view on Meta::CPAN

}

# ------------------------------------------------------------------------
# simple web server with keep alive and SSL, which can also simulate proxy
# ------------------------------------------------------------------------
sub _server {
    my $connid = 0;
    my %certs; # generated certificates

    ACCEPT:
    my ($server) = IO::Select->new(@server)->can_read();
    my $cl = $server->accept or goto ACCEPT;

    # peek into socket to determine if this is direct SSL or not
    # minimal request is "GET / HTTP/1.1\n\n"
    my $buf = '';
    while (length($buf)<15) {
	my $lbuf;
	if ( ! IO::Select->new($cl)->can_read(30)
	    or ! defined recv($cl,$lbuf,20,MSG_PEEK)) {
	    warn "not enough data for request ($buf): $!";
	    goto ACCEPT;
	}
	$buf .= $lbuf;
    }
    my $ssl_host = '';
    if ( $buf !~m{\A[A-Z]{3,} } ) {
	# does not look like HTTP, assume direct SSL
	$ssl_host = "direct.ssl.access";
    }

    $connid++;

    defined( my $pid = fork()) or die "failed to fork: $!";
    if ( $pid ) {
	push @childs,$pid;
	goto ACCEPT; # wait for next connection
    }

    # child handles requests
    @server = ();
    my $reqid = 0;
    my $tunnel_auth = '';

    SSL_UPGRADE:
    if ( $ssl_host ) {
	my ($cert,$key) = @{
	    $certs{$ssl_host} ||= do {
		note("creating cert for $ssl_host");
		my ($c,$k) = CERT_create(
		    subject => { commonName => $ssl_host },
		    issuer_cert => $cacert,
		    issuer_key => $cakey,
		    # just reuse cakey as key for certificate
		    key => $cakey,
		);
		[ $c,$k ];
	    };
	};

	IO::Socket::SSL->start_SSL( $cl,
	    SSL_server => 1,
	    SSL_cert => $cert,
	    SSL_key  => $key,
	) or do {
	    diag("SSL handshake failed: ".IO::Socket::SSL->errstr);
	    exit(1);
	};
    }

    REQUEST:
    # read header
    my $req = '';
    while (<$cl>) {
	$_ eq "\r\n" and last;
	$req .= $_;
    }
    $reqid++;
    my $req_auth = $req =~m{^Proxy-Authorization:}mi ? '.auth':'';

    if ( $req =~m{\ACONNECT ([^\s:]+)} ) {
	if ( $ssl_host ) {
	    diag("CONNECT inside SSL tunnel");
	    exit(1);
	}
	$ssl_host = $1;
	$tunnel_auth = $req_auth ? '.Tauth':'';
	#diag($req);

	# simulate proxy and establish SSL tunnel
	print $cl "HTTP/1.0 200 ok\r\n\r\n";
	goto SSL_UPGRADE;
    }

    if ( $req =~m{^Content-length: *(\d+)}mi ) {
	read($cl,my $buf,$1) or die "eof while reading request body";
    }
    my $keep_alive =
	$req =~m{^(?:Proxy-)?Connection: *(?:(keep-alive)|close)}mi ? $1 :
	$req =~m{\A.*HTTP/1\.1} ? 1 :
	0;

    # just echo request back, including connid and reqid
    my $body = "ID: $connid.$reqid$tunnel_auth$req_auth\@"
	. ( $ssl_host || 'nossl' )."\n"
	. "---------\n$req";
    print $cl "HTTP/1.1 200 ok\r\nContent-type: text/plain\r\n"
	. "Connection: ".( $keep_alive ? 'keep-alive':'close' )."\r\n"
	. "Content-length: ".length($body)."\r\n"
	. "\r\n"
	. $body;

    goto REQUEST if $keep_alive;
    exit(0); # done handling requests
}