view release on metacpan or  search on metacpan

SocksChain10.pm  view on Meta::CPAN

########################################################################
#
# $Id: SocksChain10.pm,v 1.7 2009-11-21 20:25:47 gosha Exp $
#
# Copyright (C) Igor V. Okunev gosha<at>prv.mts-nn.ru 2005
#
#      All rights reserved. This library is free software;
#      you can redistribute it and/or modify it under the
#               same terms as Perl itself.
#
########################################################################

package LWP::Protocol::https::SocksChain10;

use strict;
use vars qw( @ISA $VERSION @EXTRA_SOCK_OPTS );

use Net::SC;

use HTTP::Response;
use HTTP::Status;
use IO::Select;
use IO::Socket::SSL;
use LWP::Protocol;

($VERSION='$Revision: 1.7 $')=~s/^\S+\s+(\S+)\s+.*/$1/;

local $^W = 1;

@ISA = qw(
				LWP::Protocol
				IO::Socket::SSL
		);

sub IO::Socket::SSL::SSL_HANDLE::READ { ${shift()}->read     (@_) }

my $CRLF = "\015\012";

sub _new_socket
{
	my($self, $host, $port, $timeout ) = @_;

	my %cfg = (
				PeerHost	=> $host,
				PeerPort	=> $port,
				timeout		=> $timeout,
				$self->_extra_sock_opts($host, $port) );

	#
	# client certificate support
	#
	if ( defined $ENV{HTTPS_KEY_FILE} and not exists $cfg{SSL_key_file} ) {
		$cfg{SSL_key_file} = $ENV{HTTPS_KEY_FILE};
	}

	if ( defined $ENV{HTTPS_CA_DIR} and not exists $cfg{SSL_ca_path} ) {
		$cfg{SSL_ca_path} = $ENV{HTTPS_CA_DIR}; 
	}

	if ( defined $ENV{HTTPS_CA_FILE} and not exists $cfg{SSL_ca_file} ) {
		$cfg{SSL_ca_file} = $ENV{HTTPS_CA_FILE};
	}

	if ( defined $ENV{HTTPS_CERT_FILE} and not exists $cfg{SSL_cert_file} ) {
		$cfg{SSL_cert_file} = $ENV{HTTPS_CERT_FILE};
	}

	if ( not exists $cfg{SSL_use_cert} and exists $cfg{SSL_cert_file} ) {
		$cfg{SSL_use_cert} = 1
	}

	my $sc = Net::SC->new( %cfg ) || die $!;

	unless ( ( my $rc = $sc->connect( $host, $port ) ) == SOCKS_OKAY ) {
		die socks_error($rc) . "\n";
	}

	my $obj = bless $sc->sh;

	if ( $IO::Socket::SSL::VERSION > 0.97 ) {
		$obj->configure_SSL( \%cfg ) && $obj->connect_SSL();
	} else {
		$obj->configure_SSL( \%cfg ) && $obj->connect_SSL($sc->sh);
	}

	unless ($obj) {
# IO::Socket leaves additional error messages in $@
		$@ =~ s/^.*?: //;
		die "Can't connect to $host:$port ($@)";
	}

# perl 5.005's IO::Socket does not have the blocking method.
	eval { $obj->blocking(0); };

	return $obj;
}

sub _extra_sock_opts  # to be overridden by subclass
{
	return @EXTRA_SOCK_OPTS;
}

sub _check_sock
{
    my($self, $req, $sock) = @_;
    my $check = $req->header("If-SSL-Cert-Subject");
    if (defined $check) {
	my $cert = $sock->get_peer_certificate ||
	    die "Missing SSL certificate";
	my $subject = $cert->subject_name;
	die "Bad SSL certificate subject: '$subject' !~ /$check/"
	    unless $subject =~ /$check/;
	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
    }
}

sub _get_sock_info
{
    my $self = shift;
    #$self->SUPER::_get_sock_info(@_);
    my($res, $sock) = @_;
    $res->header("Client-SSL-Cipher" => $sock->get_cipher);
    my $cert = $sock->get_peer_certificate;
    if ($cert) {
	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
    }
    $res->header("Client-SSL-Warning" => "Peer certificate not verified");
}

sub _fixup_header
{
	my($self, $h, $url) = @_;

	$h->remove_header('Connection');  # need support here to be useful

# HTTP/1.1 will require us to send the 'Host' header, so we might
# as well start now.
	my $hhost = $url->authority;