From 5594f2e64c7ea9e50c0a92d50402c46a61b0517c Mon Sep 17 00:00:00 2001 From: Brian Fraser Date: Mon, 24 Sep 2012 16:24:36 -0300 Subject: [PATCH] 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 --- bin/pt-archiver | 183 +++++++++++++++++++++++++++- bin/pt-config-diff | 183 +++++++++++++++++++++++++++- bin/pt-deadlock-logger | 183 +++++++++++++++++++++++++++- bin/pt-diskstats | 183 +++++++++++++++++++++++++++- bin/pt-duplicate-key-checker | 183 +++++++++++++++++++++++++++- bin/pt-find | 183 +++++++++++++++++++++++++++- bin/pt-fk-error-logger | 183 +++++++++++++++++++++++++++- bin/pt-heartbeat | 183 +++++++++++++++++++++++++++- bin/pt-index-usage | 183 +++++++++++++++++++++++++++- bin/pt-kill | 183 +++++++++++++++++++++++++++- bin/pt-online-schema-change | 183 +++++++++++++++++++++++++++- bin/pt-query-advisor | 183 +++++++++++++++++++++++++++- bin/pt-query-digest | 183 +++++++++++++++++++++++++++- bin/pt-slave-delay | 183 +++++++++++++++++++++++++++- bin/pt-slave-restart | 183 +++++++++++++++++++++++++++- bin/pt-table-checksum | 183 +++++++++++++++++++++++++++- bin/pt-upgrade | 183 +++++++++++++++++++++++++++- bin/pt-variable-advisor | 183 +++++++++++++++++++++++++++- lib/HTTPMicro.pm | 228 ++++++++++++++++++++++++++++++++++- t/lib/HTTPMicro.t | 17 +-- 20 files changed, 3493 insertions(+), 46 deletions(-) diff --git a/bin/pt-archiver b/bin/pt-archiver index 7efbd13a..f18d4884 100755 --- a/bin/pt-archiver +++ b/bin/pt-archiver @@ -4353,8 +4353,14 @@ 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 { + 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; @@ -4597,6 +4603,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-config-diff b/bin/pt-config-diff index ace8a7d1..c4d43e9f 100755 --- a/bin/pt-config-diff +++ b/bin/pt-config-diff @@ -3468,8 +3468,14 @@ 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 { + 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; @@ -3712,6 +3718,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-deadlock-logger b/bin/pt-deadlock-logger index 403355fc..7f76e59c 100755 --- a/bin/pt-deadlock-logger +++ b/bin/pt-deadlock-logger @@ -2912,8 +2912,14 @@ 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 { + 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; @@ -3156,6 +3162,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-diskstats b/bin/pt-diskstats index 55a2e72f..2dd03be5 100755 --- a/bin/pt-diskstats +++ b/bin/pt-diskstats @@ -4023,8 +4023,14 @@ 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 { + 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; @@ -4267,6 +4273,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-duplicate-key-checker b/bin/pt-duplicate-key-checker index 0d3b7730..745dd7d3 100755 --- a/bin/pt-duplicate-key-checker +++ b/bin/pt-duplicate-key-checker @@ -3869,8 +3869,14 @@ 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 { + 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; @@ -4113,6 +4119,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-find b/bin/pt-find index 9a1c9e28..2f3f4653 100755 --- a/bin/pt-find +++ b/bin/pt-find @@ -2709,8 +2709,14 @@ 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 { + 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; @@ -2953,6 +2959,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-fk-error-logger b/bin/pt-fk-error-logger index 86fede7a..d5541928 100755 --- a/bin/pt-fk-error-logger +++ b/bin/pt-fk-error-logger @@ -2616,8 +2616,14 @@ 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 { + 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; @@ -2860,6 +2866,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-heartbeat b/bin/pt-heartbeat index 9b63b52e..30e97647 100755 --- a/bin/pt-heartbeat +++ b/bin/pt-heartbeat @@ -3793,8 +3793,14 @@ 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 { + 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; @@ -4037,6 +4043,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-index-usage b/bin/pt-index-usage index 72438ea5..65adeddc 100755 --- a/bin/pt-index-usage +++ b/bin/pt-index-usage @@ -5375,8 +5375,14 @@ 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 { + 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; @@ -5619,6 +5625,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-kill b/bin/pt-kill index 9e91e319..8b1fbfce 100755 --- a/bin/pt-kill +++ b/bin/pt-kill @@ -5384,8 +5384,14 @@ 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 { + 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; @@ -5628,6 +5634,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-online-schema-change b/bin/pt-online-schema-change index ed47e407..882fd1bd 100755 --- a/bin/pt-online-schema-change +++ b/bin/pt-online-schema-change @@ -6406,8 +6406,14 @@ 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 { + 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; @@ -6650,6 +6656,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-query-advisor b/bin/pt-query-advisor index 574dda3c..af0d8e41 100755 --- a/bin/pt-query-advisor +++ b/bin/pt-query-advisor @@ -6560,8 +6560,14 @@ 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 { + 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; @@ -6804,6 +6810,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-query-digest b/bin/pt-query-digest index 40c64b6c..729a8ae0 100755 --- a/bin/pt-query-digest +++ b/bin/pt-query-digest @@ -12409,8 +12409,14 @@ 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 { + 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; @@ -12653,6 +12659,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-slave-delay b/bin/pt-slave-delay index b38862f4..25ddd728 100755 --- a/bin/pt-slave-delay +++ b/bin/pt-slave-delay @@ -3025,8 +3025,14 @@ 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 { + 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; @@ -3269,6 +3275,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-slave-restart b/bin/pt-slave-restart index 9433c837..9c681cca 100755 --- a/bin/pt-slave-restart +++ b/bin/pt-slave-restart @@ -3648,8 +3648,14 @@ 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 { + 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; @@ -3892,6 +3898,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-table-checksum b/bin/pt-table-checksum index bf363148..733206c9 100755 --- a/bin/pt-table-checksum +++ b/bin/pt-table-checksum @@ -574,8 +574,14 @@ 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 { + 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; @@ -818,6 +824,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-upgrade b/bin/pt-upgrade index 5bd88537..c8421f6b 100755 --- a/bin/pt-upgrade +++ b/bin/pt-upgrade @@ -10850,8 +10850,14 @@ 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 { + 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; @@ -11094,6 +11100,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/bin/pt-variable-advisor b/bin/pt-variable-advisor index 4885ef7f..373c935b 100755 --- a/bin/pt-variable-advisor +++ b/bin/pt-variable-advisor @@ -3937,8 +3937,14 @@ 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 { + 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; @@ -4181,6 +4187,179 @@ sub can_write { return $self->_do_timeout('write', @_) } +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 ) { + $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 ) { + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + return; + }; + } + + $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 + } + } + + + my %scheme = ( + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + http => { + wildcards_in_cn => 'anywhere', + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + 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 + + + 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' + + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + + if ( my $sub = $scheme->{callback} ) { + return $sub->($identity,$commonName,@altNames); + } + + + my $ipn; + if ( CAN_IPV6 and $identity =~m{:} ) { + $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+$} ) { + $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + 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!"; + } + } + + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + 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 ) { + 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; } # ########################################################################### diff --git a/lib/HTTPMicro.pm b/lib/HTTPMicro.pm index 25f616cb..90420d65 100644 --- a/lib/HTTPMicro.pm +++ b/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; } # ########################################################################### diff --git a/t/lib/HTTPMicro.t b/t/lib/HTTPMicro.t index 2a759c0f..b5ce24c5 100644 --- a/t/lib/HTTPMicro.t +++ b/t/lib/HTTPMicro.t @@ -20,15 +20,16 @@ if ( $EVAL_ERROR ) { } # Need a simple URL that won't try to do chunking. -my $test_url = "http://www.percona.com/robots.txt"; -my $tiny = HTTP::Tiny->new(max_redirect => 0)->request('GET', $test_url); -my $micro = HTTPMicro->new->request('GET', $test_url); +for my $test_url ( "http://www.percona.com/robots.txt", "https://v.percona.com" ) { + my $tiny = HTTP::Tiny->new(max_redirect => 0)->request('GET', $test_url); + my $micro = HTTPMicro->new->request('GET', $test_url); -is_deeply( - $micro->{content}, - $tiny->{content}, - "HTTPMicro behaves like HTTP::Tiny (max_redirect=0)" -); + is_deeply( + $micro->{content}, + $tiny->{content}, + "HTTPMicro behaves like HTTP::Tiny (max_redirect=0)" + ); +} done_testing; exit;