1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
|
#!/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
}
);
$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' ],
[ 'proxy', "http://bar/foo",'C.3.auth@nossl' ],
[ 'proxy', "http://bar/bar",'C.4.auth@nossl' ],
[ 'proxy', "http://foo/tor",'C.5.auth@nossl' ],
[ 'proxy', "http://bar/tor",'C.6.auth@nossl' ],
# keep-alive for non-proxy https
# requests to same target use same connection, even if intermixed
[ 'noproxy', "https://$saddr[0]/foo",'D.1@direct.ssl.access' ],
[ 'noproxy', "https://$saddr[0]/bar",'D.2@direct.ssl.access' ],
[ 'noproxy', "https://$saddr[1]/foo",'E.1@direct.ssl.access' ],
[ 'noproxy', "https://$saddr[1]/bar",'E.2@direct.ssl.access' ],
[ 'noproxy', "https://$saddr[0]/tor",'D.3@direct.ssl.access' ],
[ 'noproxy', "https://$saddr[1]/tor",'E.3@direct.ssl.access' ],
# keep-alive for proxy https
! $netssl ? (
# note that we reuse proxy conn#C in first request. Although the last id
# from this conn was C.6 the new one is C.8, because request C.7 was the
# socket upgrade via CONNECT request
[ 'proxy', "https://foo/foo",'C.8.Tauth@foo' ],
[ 'proxy', "https://foo/bar",'C.9.Tauth@foo' ],
# if the target of the tunnel is different we need another connection
# note that it starts with F.2, because F.1 is the CONNECT request which
# established the tunnel
[ 'proxy', "https://bar/foo",'F.2.Tauth@bar' ],
[ 'proxy', "https://bar/bar",'F.3.Tauth@bar' ],
[ 'proxy', "https://foo/tor",'C.10.Tauth@foo' ],
[ 'proxy', "https://bar/tor",'F.4.Tauth@bar' ],
):(
# Net::SSL will cannot reuse socket for CONNECT, but once inside tunnel
# keep-alive is possible
[ 'proxy', "https://foo/foo",'G.2.Tauth@foo' ],
[ 'proxy', "https://foo/bar",'G.3.Tauth@foo' ],
[ 'proxy', "https://bar/foo",'F.2.Tauth@bar' ],
[ 'proxy', "https://bar/bar",'F.3.Tauth@bar' ],
[ 'proxy', "https://foo/tor",'G.4.Tauth@foo' ],
[ 'proxy', "https://bar/tor",'F.4.Tauth@bar' ],
),
# non-keep alive for proxy https
[ 'proxy_nokeepalive', "https://foo/foo",'H.2.Tauth@foo' ],
[ 'proxy_nokeepalive', "https://foo/bar",'I.2.Tauth@foo' ],
[ 'proxy_nokeepalive', "https://bar/foo",'J.2.Tauth@bar' ],
[ 'proxy_nokeepalive', "https://bar/bar",'K.2.Tauth@bar' ],
);
plan tests => 2*@tests;
my (%conn2id,%id2conn);
for my $test (@tests) {
my ($uatype,$url,$expect_id) = @$test;
my $ua = $ua{$uatype} or die "no such ua: $uatype";
# Net::SSL uses only the environment to decide about proxy, so we need the
# proxy/non-proxy environment for each request
if ( $netssl && $url =~m{^https://} ) {
$ENV{https_proxy} = $uatype =~m{^proxy} ? "http://$saddr[0]":""
}
my $response = $ua->get($url) or die "no response";
if ( $response->is_success
and ( my $body = $response->content()) =~m{^ID: *(\d+)\.(\S+)}m ) {
my $id = [ $1,$2 ];
my $xid = [ $expect_id =~m{(\w+)\.(\S+)} ];
if ( my $x = $id2conn{$id->[0]} ) {
$id->[0] = $x;
} elsif ( ! $conn2id{$xid->[0]} ) {
$conn2id{ $xid->[0] } = $id->[0];
$id2conn{ $id->[0] } = $xid->[0];
$id->[0] = $xid->[0];
}
is("$id->[0].$id->[1]",$expect_id,"$uatype $url -> $expect_id")
or diag($response->as_string);
# inside proxy tunnel and for non-proxy there should be only absolute
# URI in request w/o scheme
my $expect_rqurl = $url;
$expect_rqurl =~s{^\w+://[^/]+}{}
if $uatype eq 'noproxy' or $url =~m{^https://};
my ($rqurl) = $body =~m{^GET (\S+) HTTP/}m;
is($rqurl,$expect_rqurl,"URL in request -> $expect_rqurl");
} else {
die "unexpected response: ".$response->as_string
}
}
# ------------------------------------------------------------------------
# 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 {
diag("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
}
|