Skip to content

Commit ec57b73

Browse files
committed
correct behavior for https_proxy
This goes together with change to libwww-perl cb80c2ddb7 - new method _upgrade_sock in LWP::Protocol::https, but only if the default SSL library IO::Socket::SSL is used (e.g. can start_SSL). This enables LWP::Protocol::http to establish tunnel and upgrade an existing socket. - extensive test t/https_proxy.t to make sure that LWP behaves correctly. test can be run with IO::Socket::SSL and Net::SSL as backend by forcing library with environment PERL_NET_HTTPS_SSL_SOCKET_CLASS
1 parent 3d486d5 commit ec57b73

File tree

3 files changed

+325
-1
lines changed

3 files changed

+325
-1
lines changed

MANIFEST

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,3 +4,4 @@ Makefile.PL Makefile generator
44
README
55
lib/LWP/Protocol/https.pm Access with HTTP/1.1 protocol over SSL
66
t/apache.t
7+
t/https_proxy.t

lib/LWP/Protocol/https.pm

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ our $VERSION = "6.04";
55

66
require LWP::Protocol::http;
77
our @ISA = qw(LWP::Protocol::http);
8+
require Net::HTTPS;
89

910
sub socket_type
1011
{
@@ -83,10 +84,24 @@ sub _get_sock_info
8384
$res->header("Client-SSL-Socket-Class" => $Net::HTTPS::SSL_SOCKET_CLASS);
8485
}
8586

87+
# upgrade plain socket to SSL, used for CONNECT tunnel when proxying https
88+
# will only work if the underlying socket class of Net::HTTPS is
89+
# IO::Socket::SSL, but code will only be called in this case
90+
if ( $Net::HTTPS::SSL_SOCKET_CLASS->can('start_SSL')) {
91+
*_upgrade_sock = sub {
92+
my ($self,$sock,$url) = @_;
93+
$sock = LWP::Protocol::https::Socket->start_SSL( $sock,
94+
SSL_verifycn_name => $url->host,
95+
$self->_extra_sock_opts,
96+
);
97+
$@ = LWP::Protocol::https::Socket->errstr if ! $sock;
98+
return $sock;
99+
}
100+
}
101+
86102
#-----------------------------------------------------------
87103
package LWP::Protocol::https::Socket;
88104

89-
require Net::HTTPS;
90105
our @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
91106

92107
1;

t/https_proxy.t

Lines changed: 308 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,308 @@
1+
#!/usr/bin/perl
2+
3+
# to run test with Net::SSL as backend set environment
4+
# PERL_NET_HTTPS_SSL_SOCKET_CLASS=Net::SSL
5+
6+
use strict;
7+
use warnings;
8+
use Test::More;
9+
use File::Temp 'tempfile';
10+
use IO::Socket::INET;
11+
use IO::Select;
12+
use Socket 'MSG_PEEK';
13+
use LWP::UserAgent;
14+
use LWP::Protocol::https;
15+
16+
plan skip_all => "fork not implemented on this platform" if
17+
grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos );
18+
19+
eval { require IO::Socket::SSL }
20+
and $IO::Socket::SSL::VERSION >= 1.953
21+
and eval { require IO::Socket::SSL::Utils }
22+
or plan skip_all => "no recent version of IO::Socket::SSL::Utils";
23+
IO::Socket::SSL::Utils->import;
24+
25+
# create CA -------------------------------------------------------------
26+
my ($cacert,$cakey) = CERT_create( CA => 1 );
27+
my $cafile = do {
28+
my ($fh,$fname) = tempfile( CLEANUP => 1 );
29+
print $fh PEM_cert2string($cacert);
30+
$fname
31+
};
32+
33+
# create two web servers ------------------------------------------------
34+
my (@server,@saddr);
35+
for my $i (0,1) {
36+
my $server = IO::Socket::INET->new(
37+
LocalAddr => '127.0.0.1',
38+
LocalPort => 0, # let system pick port
39+
Listen => 10
40+
) or die "failed to create INET listener";
41+
my $saddr = $server->sockhost.':'.$server->sockport;
42+
$server[$i] = $server;
43+
$saddr[$i] = $saddr;
44+
}
45+
46+
my @childs;
47+
END { kill 9,@childs if @childs };
48+
defined( my $pid = fork()) or die "fork failed: $!";
49+
50+
# child process runs _server and exits
51+
if ( ! $pid ) {
52+
@childs = ();
53+
exit( _server());
54+
}
55+
56+
# parent continues with closed server sockets
57+
push @childs,$pid;
58+
@server = ();
59+
60+
# check which SSL implementation Net::HTTPS uses
61+
# Net::SSL behaves different than the default IO::Socket::SSL
62+
my $netssl = $Net::HTTPS::SSL_SOCKET_CLASS eq 'Net::SSL';
63+
64+
# do some tests ----------------------------------------------------------
65+
my %ua;
66+
$ua{noproxy} = LWP::UserAgent->new(
67+
keep_alive => 10, # size of connection cache
68+
# server does not know the expected name and returns generic certificate
69+
ssl_opts => { verify_hostname => 0 }
70+
);
71+
72+
$ua{proxy} = LWP::UserAgent->new(
73+
keep_alive => 10, # size of connection cache
74+
ssl_opts => {
75+
# Net::SSL cannot verify hostnames :(
76+
verify_hostname => $netssl ? 0: 1,
77+
SSL_ca_file => $cafile
78+
}
79+
);
80+
$ua{proxy_nokeepalive} = LWP::UserAgent->new(
81+
keep_alive => 0,
82+
ssl_opts => {
83+
# Net::SSL cannot verify hostnames :(
84+
verify_hostname => $netssl ? 0: 1,
85+
SSL_ca_file => $cafile
86+
}
87+
);
88+
$ENV{http_proxy} = $ENV{https_proxy} = "http://foo:bar\@$saddr[0]";
89+
$ua{proxy}->env_proxy;
90+
$ua{proxy_nokeepalive}->env_proxy;
91+
if ($netssl) {
92+
# Net::SSL cannot get user/pass from proxy url
93+
$ENV{HTTPS_PROXY_USERNAME} = 'foo';
94+
$ENV{HTTPS_PROXY_PASSWORD} = 'bar';
95+
}
96+
97+
my @tests = (
98+
# the expected ids are connid.reqid[tunnel_auth][req_auth]@sslhost
99+
# because we run different sets of test depending on the SSL class
100+
# used by Net::HTTPS we replace connid with a letter and later
101+
# match it to a number
102+
103+
# keep-alive for non-proxy http
104+
# requests to same target use same connection, even if intermixed
105+
[ 'noproxy', "http://$saddr[0]/foo",'A.1@nossl' ],
106+
[ 'noproxy', "http://$saddr[0]/bar",'A.2@nossl' ], # reuse conn#1
107+
[ 'noproxy', "http://$saddr[1]/foo",'B.1@nossl' ],
108+
[ 'noproxy', "http://$saddr[1]/bar",'B.2@nossl' ], # reuse conn#2
109+
[ 'noproxy', "http://$saddr[0]/tor",'A.3@nossl' ], # reuse conn#1 again
110+
[ 'noproxy', "http://$saddr[1]/tor",'B.3@nossl' ], # reuse conn#2 again
111+
# keep-alive for proxy http
112+
# use the same proxy connection for all even if the target host differs
113+
[ 'proxy', "http://foo/foo",'C.1.auth@nossl' ],
114+
[ 'proxy', "http://foo/bar",'C.2.auth@nossl' ],
115+
[ 'proxy', "http://bar/foo",'C.3.auth@nossl' ],
116+
[ 'proxy', "http://bar/bar",'C.4.auth@nossl' ],
117+
[ 'proxy', "http://foo/tor",'C.5.auth@nossl' ],
118+
[ 'proxy', "http://bar/tor",'C.6.auth@nossl' ],
119+
# keep-alive for non-proxy https
120+
# requests to same target use same connection, even if intermixed
121+
[ 'noproxy', "https://$saddr[0]/foo",'[email protected]' ],
122+
[ 'noproxy', "https://$saddr[0]/bar",'[email protected]' ],
123+
[ 'noproxy', "https://$saddr[1]/foo",'[email protected]' ],
124+
[ 'noproxy', "https://$saddr[1]/bar",'[email protected]' ],
125+
[ 'noproxy', "https://$saddr[0]/tor",'[email protected]' ],
126+
[ 'noproxy', "https://$saddr[1]/tor",'[email protected]' ],
127+
# keep-alive for proxy https
128+
! $netssl ? (
129+
# note that we reuse proxy conn#C in first request. Although the last id
130+
# from this conn was C.6 the new one is C.8, because request C.7 was the
131+
# socket upgrade via CONNECT request
132+
[ 'proxy', "https://foo/foo",'C.8.Tauth@foo' ],
133+
[ 'proxy', "https://foo/bar",'C.9.Tauth@foo' ],
134+
# if the target of the tunnel is different we need another connection
135+
# note that it starts with F.2, because F.1 is the CONNECT request which
136+
# established the tunnel
137+
[ 'proxy', "https://bar/foo",'F.2.Tauth@bar' ],
138+
[ 'proxy', "https://bar/bar",'F.3.Tauth@bar' ],
139+
[ 'proxy', "https://foo/tor",'C.10.Tauth@foo' ],
140+
[ 'proxy', "https://bar/tor",'F.4.Tauth@bar' ],
141+
):(
142+
# Net::SSL will cannot reuse socket for CONNECT, but once inside tunnel
143+
# keep-alive is possible
144+
[ 'proxy', "https://foo/foo",'G.2.Tauth@foo' ],
145+
[ 'proxy', "https://foo/bar",'G.3.Tauth@foo' ],
146+
[ 'proxy', "https://bar/foo",'F.2.Tauth@bar' ],
147+
[ 'proxy', "https://bar/bar",'F.3.Tauth@bar' ],
148+
[ 'proxy', "https://foo/tor",'G.4.Tauth@foo' ],
149+
[ 'proxy', "https://bar/tor",'F.4.Tauth@bar' ],
150+
),
151+
# non-keep alive for proxy https
152+
[ 'proxy_nokeepalive', "https://foo/foo",'H.2.Tauth@foo' ],
153+
[ 'proxy_nokeepalive', "https://foo/bar",'I.2.Tauth@foo' ],
154+
[ 'proxy_nokeepalive', "https://bar/foo",'J.2.Tauth@bar' ],
155+
[ 'proxy_nokeepalive', "https://bar/bar",'K.2.Tauth@bar' ],
156+
);
157+
plan tests => 2*@tests;
158+
159+
my (%conn2id,%id2conn);
160+
for my $test (@tests) {
161+
my ($uatype,$url,$expect_id) = @$test;
162+
my $ua = $ua{$uatype} or die "no such ua: $uatype";
163+
164+
# Net::SSL uses only the environment to decide about proxy, so we need the
165+
# proxy/non-proxy environment for each request
166+
if ( $netssl && $url =~m{^https://} ) {
167+
$ENV{https_proxy} = $uatype =~m{^proxy} ? "http://$saddr[0]":""
168+
}
169+
170+
my $response = $ua->get($url) or die "no response";
171+
if ( $response->is_success
172+
and ( my $body = $response->content()) =~m{^ID: *(\d+)\.(\S+)}m ) {
173+
my $id = [ $1,$2 ];
174+
my $xid = [ $expect_id =~m{(\w+)\.(\S+)} ];
175+
if ( my $x = $id2conn{$id->[0]} ) {
176+
$id->[0] = $x;
177+
} elsif ( ! $conn2id{$xid->[0]} ) {
178+
$conn2id{ $xid->[0] } = $id->[0];
179+
$id2conn{ $id->[0] } = $xid->[0];
180+
$id->[0] = $xid->[0];
181+
}
182+
is("$id->[0].$id->[1]",$expect_id,"$uatype $url -> $expect_id")
183+
or diag($response->as_string);
184+
# inside proxy tunnel and for non-proxy there should be only absolute
185+
# URI in request w/o scheme
186+
my $expect_rqurl = $url;
187+
$expect_rqurl =~s{^\w+://[^/]+}{}
188+
if $uatype eq 'noproxy' or $url =~m{^https://};
189+
my ($rqurl) = $body =~m{^GET (\S+) HTTP/}m;
190+
is($rqurl,$expect_rqurl,"URL in request -> $expect_rqurl");
191+
} else {
192+
die "unexpected response: ".$response->as_string
193+
}
194+
}
195+
196+
# ------------------------------------------------------------------------
197+
# simple web server with keep alive and SSL, which can also simulate proxy
198+
# ------------------------------------------------------------------------
199+
sub _server {
200+
my $connid = 0;
201+
my %certs; # generated certificates
202+
203+
ACCEPT:
204+
my ($server) = IO::Select->new(@server)->can_read();
205+
my $cl = $server->accept or goto ACCEPT;
206+
207+
# peek into socket to determine if this is direct SSL or not
208+
# minimal request is "GET / HTTP/1.1\n\n"
209+
my $buf = '';
210+
while (length($buf)<15) {
211+
my $lbuf;
212+
if ( ! IO::Select->new($cl)->can_read(30)
213+
or ! defined recv($cl,$lbuf,20,MSG_PEEK)) {
214+
warn "not enough data for request ($buf): $!";
215+
goto ACCEPT;
216+
}
217+
$buf .= $lbuf;
218+
}
219+
my $ssl_host = '';
220+
if ( $buf !~m{\A[A-Z]{3,} } ) {
221+
# does not look like HTTP, assume direct SSL
222+
$ssl_host = "direct.ssl.access";
223+
}
224+
225+
$connid++;
226+
227+
defined( my $pid = fork()) or die "failed to fork: $!";
228+
if ( $pid ) {
229+
push @childs,$pid;
230+
goto ACCEPT; # wait for next connection
231+
}
232+
233+
# child handles requests
234+
@server = ();
235+
my $reqid = 0;
236+
my $tunnel_auth = '';
237+
238+
SSL_UPGRADE:
239+
if ( $ssl_host ) {
240+
my ($cert,$key) = @{
241+
$certs{$ssl_host} ||= do {
242+
diag("creating cert for $ssl_host");
243+
my ($c,$k) = CERT_create(
244+
subject => { commonName => $ssl_host },
245+
issuer_cert => $cacert,
246+
issuer_key => $cakey,
247+
# just reuse cakey as key for certificate
248+
key => $cakey,
249+
);
250+
[ $c,$k ];
251+
};
252+
};
253+
254+
IO::Socket::SSL->start_SSL( $cl,
255+
SSL_server => 1,
256+
SSL_cert => $cert,
257+
SSL_key => $key,
258+
) or do {
259+
diag("SSL handshake failed: ".IO::Socket::SSL->errstr);
260+
exit(1);
261+
};
262+
}
263+
264+
REQUEST:
265+
# read header
266+
my $req = '';
267+
while (<$cl>) {
268+
$_ eq "\r\n" and last;
269+
$req .= $_;
270+
}
271+
$reqid++;
272+
my $req_auth = $req =~m{^Proxy-Authorization:}mi ? '.auth':'';
273+
274+
if ( $req =~m{\ACONNECT ([^\s:]+)} ) {
275+
if ( $ssl_host ) {
276+
diag("CONNECT inside SSL tunnel");
277+
exit(1);
278+
}
279+
$ssl_host = $1;
280+
$tunnel_auth = $req_auth ? '.Tauth':'';
281+
#diag($req);
282+
283+
# simulate proxy and establish SSL tunnel
284+
print $cl "HTTP/1.0 200 ok\r\n\r\n";
285+
goto SSL_UPGRADE;
286+
}
287+
288+
if ( $req =~m{^Content-length: *(\d+)}mi ) {
289+
read($cl,my $buf,$1) or die "eof while reading request body";
290+
}
291+
my $keep_alive =
292+
$req =~m{^(?:Proxy-)?Connection: *(?:(keep-alive)|close)}mi ? $1 :
293+
$req =~m{\A.*HTTP/1\.1} ? 1 :
294+
0;
295+
296+
# just echo request back, including connid and reqid
297+
my $body = "ID: $connid.$reqid$tunnel_auth$req_auth\@"
298+
. ( $ssl_host || 'nossl' )."\n"
299+
. "---------\n$req";
300+
print $cl "HTTP/1.1 200 ok\r\nContent-type: text/plain\r\n"
301+
. "Connection: ".( $keep_alive ? 'keep-alive':'close' )."\r\n"
302+
. "Content-length: ".length($body)."\r\n"
303+
. "\r\n"
304+
. $body;
305+
306+
goto REQUEST if $keep_alive;
307+
exit(0); # done handling requests
308+
}

0 commit comments

Comments
 (0)