mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-14 15:33:49 +00:00
HTTPMicro: Inline part of IO::Socket::SSL for cases when the local version of the module isn't high enough to support ->verify_hostname(), like in centos5
This commit is contained in:
Brian Fraser
228
lib/HTTPMicro.pm
228
lib/HTTPMicro.pm
@@ -234,8 +234,16 @@ sub connect {
|
||||
IO::Socket::SSL->start_SSL($self->{fh});
|
||||
ref($self->{fh}) eq 'IO::Socket::SSL'
|
||||
or die(qq/SSL connection failed for $host\n/);
|
||||
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
|
||||
or die(qq/SSL certificate not valid for $host\n/);
|
||||
if ( $self->{fh}->can("verify_hostname") ) {
|
||||
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
|
||||
}
|
||||
else {
|
||||
# Can't use $self->{fh}->verify_hostname because the IO::Socket::SSL
|
||||
# that comes from yum doesn't have it, so use our inlined version.
|
||||
my $fh = $self->{fh};
|
||||
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
|
||||
or die(qq/SSL certificate not valid for $host\n/);
|
||||
}
|
||||
}
|
||||
|
||||
$self->{host} = $host;
|
||||
@@ -478,6 +486,222 @@ sub can_write {
|
||||
return $self->_do_timeout('write', @_)
|
||||
}
|
||||
|
||||
# Partially copy-pasted from IO::Socket::SSL 1.76, with some changes because
|
||||
# we're forced to use IO::Socket::SSL version 1.01 in yum-based distros
|
||||
my $prog = <<'EOP';
|
||||
BEGIN {
|
||||
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
|
||||
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
|
||||
}
|
||||
else {
|
||||
constant->import( CAN_IPV6 => '' );
|
||||
}
|
||||
my %const = (
|
||||
NID_CommonName => 13,
|
||||
GEN_DNS => 2,
|
||||
GEN_IPADD => 7,
|
||||
);
|
||||
while ( my ($name,$value) = each %const ) {
|
||||
no strict 'refs';
|
||||
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
|
||||
}
|
||||
}
|
||||
{
|
||||
my %dispatcher = (
|
||||
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
|
||||
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
|
||||
);
|
||||
if ( $Net::SSLeay::VERSION >= 1.30 ) {
|
||||
# I think X509_NAME_get_text_by_NID got added in 1.30
|
||||
$dispatcher{commonName} = sub {
|
||||
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
|
||||
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
|
||||
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
|
||||
$cn;
|
||||
}
|
||||
} else {
|
||||
$dispatcher{commonName} = sub {
|
||||
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
|
||||
}
|
||||
}
|
||||
|
||||
if ( $Net::SSLeay::VERSION >= 1.33 ) {
|
||||
# X509_get_subjectAltNames did not really work before
|
||||
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
|
||||
} else {
|
||||
$dispatcher{subjectAltNames} = sub {
|
||||
# In the original, this croaked, but yum's Net::SSLeay doesn't have
|
||||
# X509_get_subjectAltNames -- which is mostly okay, because we don't
|
||||
# really need it.
|
||||
return;
|
||||
#croak "you need at least Net::SSLeay version 1.33 for getting subjectAltNames"
|
||||
};
|
||||
}
|
||||
|
||||
# alternative names
|
||||
$dispatcher{authority} = $dispatcher{issuer};
|
||||
$dispatcher{owner} = $dispatcher{subject};
|
||||
$dispatcher{cn} = $dispatcher{commonName};
|
||||
|
||||
sub _peer_certificate {
|
||||
my ($self, $field) = @_;
|
||||
my $ssl = $self->_get_ssl_object or return;
|
||||
|
||||
my $cert = ${*$self}{_SSL_certificate}
|
||||
||= Net::SSLeay::get_peer_certificate($ssl)
|
||||
or return $self->error("Could not retrieve peer certificate");
|
||||
|
||||
if ($field) {
|
||||
my $sub = $dispatcher{$field} or croak
|
||||
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
|
||||
"\nMaybe you need to upgrade your Net::SSLeay";
|
||||
return $sub->($cert);
|
||||
} else {
|
||||
return $cert
|
||||
}
|
||||
}
|
||||
|
||||
# known schemes, possible attributes are:
|
||||
# - wildcards_in_alt (0, 'leftmost', 'anywhere')
|
||||
# - wildcards_in_cn (0, 'leftmost', 'anywhere')
|
||||
# - check_cn (0, 'always', 'when_only')
|
||||
|
||||
my %scheme = (
|
||||
# rfc 4513
|
||||
ldap => {
|
||||
wildcards_in_cn => 0,
|
||||
wildcards_in_alt => 'leftmost',
|
||||
check_cn => 'always',
|
||||
},
|
||||
# rfc 2818
|
||||
http => {
|
||||
wildcards_in_cn => 'anywhere',
|
||||
wildcards_in_alt => 'anywhere',
|
||||
check_cn => 'when_only',
|
||||
},
|
||||
# rfc 3207
|
||||
# This is just a dumb guess
|
||||
# RFC3207 itself just says, that the client should expect the
|
||||
# domain name of the server in the certificate. It doesn't say
|
||||
# anything about wildcards, so I forbid them. It doesn't say
|
||||
# anything about alt names, but other documents show, that alt
|
||||
# names should be possible. The check_cn value again is a guess.
|
||||
# Fix the spec!
|
||||
smtp => {
|
||||
wildcards_in_cn => 0,
|
||||
wildcards_in_alt => 0,
|
||||
check_cn => 'always'
|
||||
},
|
||||
none => {}, # do not check
|
||||
);
|
||||
|
||||
$scheme{www} = $scheme{http}; # alias
|
||||
$scheme{xmpp} = $scheme{http}; # rfc 3920
|
||||
$scheme{pop3} = $scheme{ldap}; # rfc 2595
|
||||
$scheme{imap} = $scheme{ldap}; # rfc 2595
|
||||
$scheme{acap} = $scheme{ldap}; # rfc 2595
|
||||
$scheme{nntp} = $scheme{ldap}; # rfc 4642
|
||||
$scheme{ftp} = $scheme{http}; # rfc 4217
|
||||
|
||||
# function to verify the hostname
|
||||
#
|
||||
# as every application protocol has its own rules to do this
|
||||
# we provide some default rules as well as a user-defined
|
||||
# callback
|
||||
|
||||
sub _verify_hostname_of_cert {
|
||||
my $identity = shift;
|
||||
my $cert = shift;
|
||||
my $scheme = shift || 'none';
|
||||
if ( ! ref($scheme) ) {
|
||||
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
|
||||
}
|
||||
|
||||
return 1 if ! %$scheme; # 'none'
|
||||
|
||||
# get data from certificate
|
||||
my $commonName = $dispatcher{cn}->($cert);
|
||||
my @altNames = $dispatcher{subjectAltNames}->($cert);
|
||||
|
||||
if ( my $sub = $scheme->{callback} ) {
|
||||
# use custom callback
|
||||
return $sub->($identity,$commonName,@altNames);
|
||||
}
|
||||
|
||||
# is the given hostname an IP address? Then we have to convert to network byte order [RFC791][RFC2460]
|
||||
|
||||
my $ipn;
|
||||
if ( CAN_IPV6 and $identity =~m{:} ) {
|
||||
# no IPv4 or hostname have ':' in it, try IPv6.
|
||||
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
|
||||
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
|
||||
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
|
||||
# definitly no hostname, try IPv4
|
||||
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
|
||||
} else {
|
||||
# assume hostname, check for umlauts etc
|
||||
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
|
||||
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
|
||||
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
|
||||
croak "Warning: Given name '$identity' could not be converted to IDNA!";
|
||||
}
|
||||
}
|
||||
|
||||
# do the actual verification
|
||||
my $check_name = sub {
|
||||
my ($name,$identity,$wtyp) = @_;
|
||||
$wtyp ||= '';
|
||||
my $pattern;
|
||||
### IMPORTANT!
|
||||
# we accept only a single wildcard and only for a single part of the FQDN
|
||||
# e.g *.example.org does match www.example.org but not bla.www.example.org
|
||||
# The RFCs are in this regard unspecific but we don't want to have to
|
||||
# deal with certificates like *.com, *.co.uk or even *
|
||||
# see also http://nils.toedtmann.net/pub/subjectAltName.txt
|
||||
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
|
||||
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
|
||||
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
|
||||
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
|
||||
} else {
|
||||
$pattern = qr{^\Q$name\E$}i;
|
||||
}
|
||||
return $identity =~ $pattern;
|
||||
};
|
||||
|
||||
my $alt_dnsNames = 0;
|
||||
while (@altNames) {
|
||||
my ($type, $name) = splice (@altNames, 0, 2);
|
||||
if ( $ipn and $type == GEN_IPADD ) {
|
||||
# exakt match needed for IP
|
||||
# $name is already packed format (inet_xton)
|
||||
return 1 if $ipn eq $name;
|
||||
|
||||
} elsif ( ! $ipn and $type == GEN_DNS ) {
|
||||
$name =~s/\s+$//; $name =~s/^\s+//;
|
||||
$alt_dnsNames++;
|
||||
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
|
||||
and return 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ( ! $ipn and (
|
||||
$scheme->{check_cn} eq 'always' or
|
||||
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
|
||||
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
|
||||
and return 1;
|
||||
}
|
||||
|
||||
return 0; # no match
|
||||
}
|
||||
}
|
||||
EOP
|
||||
|
||||
eval { require IO::Socket::SSL };
|
||||
if ( $INC{"IO/Socket/SSL.pm"} ) {
|
||||
eval $prog;
|
||||
die $@ if $@;
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
|
||||
Reference in New Issue
Block a user