summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm148
1 files changed, 78 insertions, 70 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm
index 8d7c6d93928..a75e147650a 100644
--- a/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm
+++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm
@@ -16,16 +16,6 @@ my $CRLF = "\015\012";
sub _new_socket
{
my($self, $host, $port, $timeout) = @_;
- my $conn_cache = $self->{ua}{conn_cache};
- if ($conn_cache) {
- if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
- return $sock if $sock && !$sock->can_read(0);
- # if the socket is readable, then either the peer has closed the
- # connection or there are some garbage bytes on it. In either
- # case we abandon it.
- $sock->close;
- }
- }
local($^W) = 0; # IO::Socket::INET can be noisy
my $sock = $self->socket_class->new(PeerAddr => $host,
@@ -33,7 +23,7 @@ sub _new_socket
LocalAddr => $self->{ua}{local_address},
Proto => 'tcp',
Timeout => $timeout,
- KeepAlive => !!$conn_cache,
+ KeepAlive => !!$self->{ua}{conn_cache},
SendTE => 1,
$self->_extra_sock_opts($host, $port),
);
@@ -104,9 +94,10 @@ sub _fixup_header
}
$h->init_header('Host' => $hhost);
- if ($proxy) {
+ if ($proxy && $url->scheme ne 'https') {
# Check the proxy URI's userinfo() for proxy credentials
- # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
+ # export http_proxy="http://proxyuser:proxypass@proxyhost:port".
+ # For https only the initial CONNECT requests needs authorization.
my $p_auth = $proxy->userinfo();
if(defined $p_auth) {
require URI::Escape;
@@ -140,26 +131,80 @@ sub request
}
my $url = $request->uri;
- my($host, $port, $fullpath);
-
- # Check if we're proxy'ing
- if (defined $proxy) {
- # $proxy is an URL to an HTTP server which will proxy this request
- $host = $proxy->host;
- $port = $proxy->port;
- $fullpath = $method eq "CONNECT" ?
- ($url->host . ":" . $url->port) :
- $url->as_string;
+
+ # Proxying SSL with a http proxy needs issues a CONNECT request to build a
+ # tunnel and then upgrades the tunnel to SSL. But when doing keep-alive the
+ # https request does not need to be the first request in the connection, so
+ # we need to distinguish between
+ # - not yet connected (create socket and ssl upgrade)
+ # - connected but not inside ssl tunnel (ssl upgrade)
+ # - inside ssl tunnel to the target - once we are in the tunnel to the
+ # target we cannot only reuse the tunnel for more https requests with the
+ # same target
+
+ my $ssl_tunnel = $proxy && $url->scheme eq 'https'
+ && $url->host.":".$url->port;
+
+ my ($host,$port) = $proxy
+ ? ($proxy->host,$proxy->port)
+ : ($url->host,$url->port);
+ my $fullpath =
+ $method eq 'CONNECT' ? $url->host . ":" . $url->port :
+ $proxy && ! $ssl_tunnel ? $url->as_string :
+ do {
+ my $path = $url->path_query;
+ $path = "/$path" if $path !~m{^/};
+ $path
+ };
+
+ my $socket;
+ my $conn_cache = $self->{ua}{conn_cache};
+ my $cache_key;
+ if ( $conn_cache ) {
+ $cache_key = "$host:$port";
+ # For https we reuse the socket immediatly only if it has an established
+ # tunnel to the target. Otherwise a CONNECT request followed by an SSL
+ # upgrade need to be done first. The request itself might reuse an
+ # existing non-ssl connection to the proxy
+ $cache_key .= "!".$ssl_tunnel if $ssl_tunnel;
+ if ( $socket = $conn_cache->withdraw($self->socket_type,$cache_key)) {
+ if ($socket->can_read(0)) {
+ # if the socket is readable, then either the peer has closed the
+ # connection or there are some garbage bytes on it. In either
+ # case we abandon it.
+ $socket->close;
+ $socket = undef;
+ } # else use $socket
+ }
}
- else {
- $host = $url->host;
- $port = $url->port;
- $fullpath = $url->path_query;
- $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
+
+ if ( ! $socket && $ssl_tunnel ) {
+ my $proto_https = LWP::Protocol::create('https',$self->{ua})
+ or die "no support for scheme https found";
+
+ # only if ssl socket class is IO::Socket::SSL we can upgrade
+ # a plain socket to SSL. In case of Net::SSL we fall back to
+ # the old version
+ if ( my $upgrade_sub = $proto_https->can('_upgrade_sock')) {
+ my $response = $self->request(
+ HTTP::Request->new('CONNECT',"http://$ssl_tunnel"),
+ $proxy,
+ undef,$size,$timeout
+ );
+ $response->is_success or die
+ "establishing SSL tunnel failed: ".$response->status_line;
+ $socket = $upgrade_sub->($proto_https,
+ $response->{client_socket},$url)
+ or die "SSL upgrade failed: $@";
+ } else {
+ $socket = $proto_https->_new_socket($url->host,$url->port,$timeout);
+ }
}
- # connect to remote site
- my $socket = $self->_new_socket($host, $port, $timeout);
+ if ( ! $socket ) {
+ # connect to remote site w/o reusing established socket
+ $socket = $self->_new_socket($host, $port, $timeout );
+ }
my $http_version = "";
if (my $proto = $request->protocol) {
@@ -410,7 +455,7 @@ sub request
{
$n = $socket->read_entity_body($buf, $size);
unless (defined $n) {
- redo READ if $!{EINTR} || $!{EAGAIN};
+ redo READ if $!{EINTR} || $!{EAGAIN} || $!{ENOTTY};
die "read failed: $!";
}
redo READ if $n == -1;
@@ -428,13 +473,13 @@ sub request
# keep-alive support
unless ($drop_connection) {
- if (my $conn_cache = $self->{ua}{conn_cache}) {
+ if ($cache_key) {
my %connection = map { (lc($_) => 1) }
split(/\s*,\s*/, ($response->header("Connection") || ""));
if (($peer_http_version eq "1.1" && !$connection{close}) ||
$connection{"keep-alive"})
{
- $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
+ $conn_cache->deposit($self->socket_type, $cache_key, $socket);
}
}
}
@@ -446,43 +491,6 @@ sub request
#-----------------------------------------------------------
package LWP::Protocol::http::SocketMethods;
-sub sysread {
- my $self = shift;
- if (my $timeout = ${*$self}{io_socket_timeout}) {
- die "read timeout" unless $self->can_read($timeout);
- }
- else {
- # since we have made the socket non-blocking we
- # use select to wait for some data to arrive
- $self->can_read(undef) || die "Assert";
- }
- sysread($self, $_[0], $_[1], $_[2] || 0);
-}
-
-sub can_read {
- my($self, $timeout) = @_;
- my $fbits = '';
- vec($fbits, fileno($self), 1) = 1;
- SELECT:
- {
- my $before;
- $before = time if $timeout;
- my $nfound = select($fbits, undef, undef, $timeout);
- if ($nfound < 0) {
- if ($!{EINTR} || $!{EAGAIN}) {
- # don't really think EAGAIN can happen here
- if ($timeout) {
- $timeout -= time - $before;
- $timeout = 0 if $timeout < 0;
- }
- redo SELECT;
- }
- die "select failed: $!";
- }
- return $nfound > 0;
- }
-}
-
sub ping {
my $self = shift;
!$self->can_read(0);