Net::SSLGlue::LWP - proper certificate checking for https in LWP

  	use Net::SSLGlue::LWP SSL_ca_path => ...;
	use LWP::Simple;
	get( 'https://www....' );

	{
		local %Net::SSLGlue::LWP::SSLopts = %Net::SSLGlue::LWP::SSLopts;

		# switch off verification
		$Net::SSLGlue::LWP::SSLopts{SSL_verify_mode} = 0; 

		# or: set different verification policy, because cert does
		# not conform to RFC (wildcards in CN are not allowed for https,
		# but some servers do it anyway)
		$Net::SSLGlue::LWP::SSLopts{SSL_verifycn_scheme} = {
			wildcards_in_cn => 'anywhere',
			check_cn => 'always',
		};
	}

use strict;
use warnings;
package Net::SSLGlue::LWP;
our $VERSION = 0.3;
use LWP::UserAgent '5.822';
use IO::Socket::SSL 1.19;
use URI::Escape 'uri_unescape';
use MIME::Base64 'encode_base64';
use URI;

# force Net::SSLGlue::LWP::Socket as superclass of Net::HTTPS, because
# only it can verify certificates
BEGIN {
	my $oc = $Net::HTTPS::SSL_SOCKET_CLASS;
	$Net::HTTPS::SSL_SOCKET_CLASS = my $need = 'Net::SSLGlue::LWP::Socket';
	require Net::HTTPS;
	require LWP::Protocol::https;
	if ( ( my $oc = $Net::HTTPS::SSL_SOCKET_CLASS ) ne $need ) {
		# was probably loaded before, change ISA
		grep { s{^\Q$oc\E$}{$need} } @Net::HTTPS::ISA
	}
	die "cannot force $need into Net::HTTPS"
		if $Net::HTTPS::SSL_SOCKET_CLASS ne $need;
}

our %SSLopts;  # set by local and import
sub import {
	shift;
	%SSLopts = @_;
}

{
	# add SSL options
	my $old_eso = UNIVERSAL::can( 'LWP::Protocol::https','_extra_sock_opts' );
	no warnings 'redefine';
	*LWP::Protocol::https::_extra_sock_opts = sub {
		return (
			$old_eso ? ( $old_eso->(@_) ):(),
			SSL_verify_mode => 1,
			SSL_verifycn_scheme => 'http',
			HTTPS_proxy => $_[0]->{ua}{https_proxy},
			%SSLopts,
		);
	};
}

{
	# fix https_proxy handling - forward it to a variable handled by me
	my $old_proxy = defined &LWP::UserAgent::proxy && \&LWP::UserAgent::proxy
		or die "cannot find LWP::UserAgent::proxy";
	no warnings 'redefine';
	*LWP::UserAgent::proxy = sub {
		my ($self,$key,$val) = @_;
		goto &$old_proxy if ref($key) || $key ne 'https';
		if (@_>2) {
			my $rv = &$old_proxy;
			$self->{https_proxy} = delete $self->{proxy}{https}
				|| die "https proxy not set?";
		}
		return $self->{https_proxy};
	}
}

{

	package Net::SSLGlue::LWP::Socket;
	use IO::Socket::SSL;
	use base 'IO::Socket::SSL';
	my $sockclass = 'IO::Socket::INET';
	$sockclass .= '6' if eval "require IO::Socket::INET6";

	sub configure {
		my ($self,$args) = @_;
		my $phost = delete $args->{HTTPS_proxy}
			or return $self->SUPER::configure($args);
		$phost = URI->new($phost) if ! ref $phost;

		my $port = $args->{PeerPort};
		my $host = $args->{PeerHost} || $args->{PeerAddr};
		if ( ! $port ) {
			$host =~s{:(\w+)$}{};
			$port = $args->{PeerPort} = $1;
			$args->{PeerHost} = $host;
		}
		if ( $phost->scheme ne 'http' ) {
			$@ = "scheme ".$phost->scheme." not supported for https_proxy";
			return;
		}
		my $auth = '';
		if ( my ($user,$pass) = split( ':', $phost->userinfo || '' ) ) {
			$auth = "Proxy-authorization: Basic ".
				encode_base64( uri_unescape($user).':'.uri_unescape($pass),'' ).
				"\r\n";
		}

		my $pport = $phost->port;
		$phost = $phost->host;

		# temporally downgrade $self so that the right connect chain
		# gets called w/o doing SSL stuff. If we don't do it it will
		# try to call IO::Socket::SSL::connect
		my $ssl_class = ref($self);
		bless $self,$sockclass;
		$self->configure({ %$args, PeerAddr => $phost, PeerPort => $pport }) or do {
			$@ = "connect to proxy $phost port $pport failed";
			return;
		};
		print $self "CONNECT $host:$port HTTP/1.0\r\n$auth\r\n";
		my $hdr = '';
		while (<$self>) {
			$hdr .= $_;
			last if $_ eq "\n" or $_ eq "\r\n";
		}
		if ( $hdr !~m{\AHTTP/1.\d 2\d\d} ) {
			# error
			$@ = "non 2xx response to CONNECT: $hdr";
			return;
		}

		# and upgrade self by calling start_SSL
		$ssl_class->start_SSL( $self,
			SSL_verifycn_name => $host,
			%$args
		) or do {
			$@ = "start SSL failed: $SSL_ERROR";
			return;
		};
		return $self;
	};
}

1;