|
| 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