On Sun, 28 Sep 2008 16:59:15 +0200, Luk Claes wrote:
> > It's the decision of the release team, therefore I'm cc'ing them and
> > ask for their opinion instead of guessing what they may think :)
> Please provide a diff with all the whitespace changes in SSL.pm stripped.
Attached is the output of
$ svn diff -x -b -r21743:24723 SSL.pm
/*
r24723: releasing version 1.15-1
r21743: releasing version 1.13-1
*/
Thanks for looking into this issue!
Cheers,
gregor
--
.''`. Home: http://info.comodo.priv.at/{,blog/} / GPG Key ID: 0x00F3CFE4
: :' : Debian GNU/Linux user, admin, & developer - http://www.debian.org/
`. `' Member of VIBE!AT, SPI Inc., fellow of FSFE | http://got.to/quote/
`- NP: Aimee Mann: I Know There's A Word
Index: SSL.pm
===================================================================
--- SSL.pm (revision 21743)
+++ SSL.pm (revision 24723)
@@ -32,7 +32,6 @@
if $@;
}
-
use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT );
{
@@ -46,13 +45,13 @@
my $y = Net::SSLeay::ERROR_WANT_WRITE();
use constant SSL_WANT_WRITE => dualvar( \$y, 'SSL wants a write first' );
- @EXPORT = qw( SSL_WANT_READ SSL_WANT_WRITE $SSL_ERROR );
+ @EXPORT = qw( SSL_WANT_READ SSL_WANT_WRITE $SSL_ERROR GEN_DNS GEN_IPADD );
}
BEGIN {
# Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS
@ISA = qw(IO::Socket::INET);
- $VERSION = '1.13';
+ $VERSION = '1.15';
$GLOBAL_CONTEXT_ARGS = {};
#Make $DEBUG another name for $Net::SSLeay::trace
@@ -65,18 +64,46 @@
Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();
-
}
sub DEBUG {
- $DEBUG or return;
+ $DEBUG>=shift or return; # check against debug level
my (undef,$file,$line) = caller;
my $msg = shift;
+ $file = '...'.substr( $file,-17 ) if length($file)>20;
$msg = sprintf $msg,@_ if @_;
print STDERR "DEBUG: $file:$line: $msg\n";
}
+BEGIN {
+ # import some constants from Net::SSLeay or use hard-coded defaults
+ # if Net::SSLeay isn't recent enough to provide the constants
+ 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 };
+ }
+ # check if we have something to handle IDN
+ local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent
+ if ( eval { require Net::IDN::Encode }) {
+ *{idn_to_ascii} = \&Net::IDN::Encode::domain_to_ascii;
+ } elsif ( eval { require Net::LibIDN }) {
+ *{idn_to_ascii} = \&Net::LibIDN::idn_to_ascii;
+ } else {
+ # default: croak if we really got an unencoded international domain
+ *{idn_to_ascii} = sub {
+ my $domain = shift;
+ return $domain if $domain =~m{^[a-zA-Z0-9-_\.]+$};
+ croak "cannot handle international domains, please install Net::LibIDN or Net::IDN::Encode"
+ }
+ }
+}
+
# Export some stuff
# inet4|inet6|debug will be handeled by myself, everything
# else will be handeld the Exporter way
@@ -85,11 +112,20 @@
my @export;
foreach (@_) {
- @ISA=qw(IO::Socket::INET), next if /inet4/i;
- @ISA=qw(IO::Socket::INET6), next if /inet6/i;
- $DEBUG=$1, next if /debug(\d)/;
+ if ( /^inet4$/i ) {
+ require IO::Socket::INET;
+ @ISA = 'IO::Socket::INET'
+ } elsif ( /^inet6$/i ) {
+ require IO::Socket::INET6;
+ require Socket6;
+ Socket6->import( 'inet_pton' );
+ @ISA = 'IO::Socket::INET6'
+ } elsif ( /^:?debug(\d+)/ ) {
+ $DEBUG=$1;
+ } else {
push @export,$_
}
+ }
@_ = ( $class,@export );
goto &Exporter::import;
@@ -130,16 +166,18 @@
my ($self, $arg_hash) = @_;
my $is_server = $arg_hash->{'SSL_server'} || $arg_hash->{'Listen'} || 0;
- my %default_args =
- ('Proto' => 'tcp',
- 'SSL_server' => $is_server,
- 'SSL_ca_file' => 'certs/my-ca.pem',
- 'SSL_ca_path' => 'ca/',
- 'SSL_use_cert' => $is_server,
- 'SSL_check_crl' => 0,
- 'SSL_version' => 'sslv23',
- 'SSL_verify_mode' => Net::SSLeay::VERIFY_NONE(),
- 'SSL_verify_callback' => 0,
+ my %default_args = (
+ Proto => 'tcp',
+ SSL_server => $is_server,
+ SSL_ca_file => 'certs/my-ca.pem',
+ SSL_ca_path => 'ca/',
+ SSL_use_cert => $is_server,
+ SSL_check_crl => 0,
+ SSL_version => 'sslv23',
+ SSL_verify_mode => Net::SSLeay::VERIFY_NONE(),
+ SSL_verify_callback => undef,
+ SSL_verifycn_scheme => undef, # don't verify cn
+ SSL_verifycn_name => undef, # use from PeerAddr/PeerHost
);
# SSL_key_file and SSL_cert_file will only be set in defaults if
@@ -161,13 +199,44 @@
#Handle CA paths properly if no CA file is specified
if ($arg_hash->{'SSL_ca_path'} ne '' and !(-f $arg_hash->{'SSL_ca_file'})) {
- warn "CA file $arg_hash->{'SSL_ca_file'} not found, using CA path instead.\n" if ($DEBUG);
+ DEBUG(1, "CA file $arg_hash->{SSL_ca_file} not found, using CA path instead.\n" )
+ if $arg_hash->{SSL_ca_file};
$arg_hash->{'SSL_ca_file'} = '';
}
+ my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme};
+ if ( $vcn_scheme && $vcn_scheme ne 'none' ) {
+ my $vcb = $arg_hash->{SSL_verify_callback};
+ $arg_hash->{SSL_verify_callback} = sub {
+ my ($ok,$ctx_store,$cert,$error) = @_;
+ $ok = $vcb->($ok,$ctx_store,$cert,$error) if $vcb;
+ $ok or return;
+ my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store);
+ return $ok if $depth != 0;
+
+ # use SSL_peer_hostname or determine from PeerAddr
+ my $arg_hash = ${*$self}{_SSL_arguments};
+ my $host = $arg_hash->{SSL_verifycn_name};
+ if (not defined($host)) {
+ $host = ( $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} );
+ $host =~s{:\w+$}{} if ! $host;
+ }
+ $host ||= ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown';
+ $host or return $self->error( "Cannot determine peer hostname for verification" );
+
+ # verify name
+ my $x509 = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store);
+ my $rv = verify_hostname_of_cert( $host,$x509,$vcn_scheme );
+ # just do some code here against optimization because x509 has no
+ # increased reference and CRYPTO_add is not available from Net::SSLeay
+ DEBUG(99999,"don't to anything with $x509" );
+ return $rv;
+ };
+ }
+
${*$self}{'_SSL_arguments'} = $arg_hash;
${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) || return;
- ${*$self}{'_SSL_opened'} = 1 if ($is_server);
+ ${*$self}{'_SSL_opened'} = 1 if $is_server;
return $self;
}
@@ -181,7 +250,7 @@
$err == Net::SSLeay::ERROR_WANT_WRITE() ? SSL_WANT_WRITE :
return;
$! ||= EAGAIN;
- ${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self));
+ ${*$self}{'_SSL_last_err'} = $SSL_ERROR if ref($self);
return 1;
}
@@ -197,9 +266,9 @@
# if this fails this might not be an error (e.g. if $! = EINPROGRESS
# and socket is nonblocking this is normal), so keep any error
# handling to the client
- #DEBUG( 'socket not yet connected' );
+ DEBUG(2, 'socket not yet connected' );
$self->SUPER::connect(@_) || return;
- #DEBUG( 'socket connected' );
+ DEBUG(2,'socket connected' );
}
return $self->connect_SSL;
}
@@ -212,7 +281,7 @@
my ($ssl,$ctx);
if ( ! ${*$self}{'_SSL_opening'} ) {
# start ssl connection
- #DEBUG( 'ssl handshake not started' );
+ DEBUG(2,'ssl handshake not started' );
${*$self}{'_SSL_opening'} = 1;
my $arg_hash = ${*$self}{'_SSL_arguments'};
@@ -243,7 +312,7 @@
? $args->{Timeout}
: ${*$self}{io_socket_timeout}; # from IO::Socket
if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) {
- #DEBUG( "set socket to non-blocking to enforce timeout=$timeout" );
+ DEBUG(2, "set socket to non-blocking to enforce timeout=$timeout" );
# timeout was given and socket was blocking
# enforce timeout with now non-blocking socket
} else {
@@ -255,17 +324,17 @@
for my $dummy (1) {
#DEBUG( 'calling ssleay::connect' );
my $rv = Net::SSLeay::connect($ssl);
- #DEBUG( "connect -> rv=$rv" );
+ DEBUG( 3,"Net::SSLeay::connect -> $rv" );
if ( $rv < 0 ) {
unless ( $self->_set_rw_error( $ssl,$rv )) {
$self->error("SSL connect attempt failed with unknown error");
delete ${*$self}{'_SSL_opening'};
- ${*$self}{'_SSL_opened'} = 1;
- #DEBUG( "fatal SSL error: $SSL_ERROR" );
+ ${*$self}{'_SSL_opened'} = -1;
+ DEBUG(1, "fatal SSL error: $SSL_ERROR" );
return $self->fatal_ssl_error();
}
- #DEBUG( 'ssl handshake in progress' );
+ DEBUG(2,'ssl handshake in progress' );
# connect failed because handshake needs to be completed
# if socket was non-blocking or no timeout was given return with this error
return if ! defined($timeout);
@@ -275,27 +344,27 @@
if ( $timeout>0 ) {
my $vec = '';
vec($vec,$self->fileno,1) = 1;
- #DEBUG( "waiting for fd to become ready: $SSL_ERROR" );
+ DEBUG(2, "waiting for fd to become ready: $SSL_ERROR" );
$rv =
$SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
$SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
undef;
} else {
- #DEBUG( "handshake failed because no more time" );
+ DEBUG(2,"handshake failed because no more time" );
$! = ETIMEDOUT
}
if ( ! $rv ) {
- #DEBUG( "handshake failed because socket did not became ready" );
+ DEBUG(2,"handshake failed because socket did not became ready" );
# failed because of timeout, return
$! ||= ETIMEDOUT;
delete ${*$self}{'_SSL_opening'};
- ${*$self}{'_SSL_opened'} = 1;
+ ${*$self}{'_SSL_opened'} = -1;
$self->blocking(1); # was blocking before
return
}
# socket is ready, try non-blocking connect again after recomputing timeout
- #DEBUG( "socket ready, retrying connect" );
+ DEBUG(2,"socket ready, retrying connect" );
my $now = time();
$timeout -= $now - $start;
$start = $now;
@@ -303,14 +372,14 @@
} elsif ( $rv == 0 ) {
delete ${*$self}{'_SSL_opening'};
- #DEBUG( "connection failed - connect returned 0" );
+ DEBUG(2,"connection failed - connect returned 0" );
$self->error("SSL connect attempt failed because of handshake problems" );
- ${*$self}{'_SSL_opened'} = 1;
+ ${*$self}{'_SSL_opened'} = -1;
return $self->fatal_ssl_error();
}
}
- #DEBUG( 'ssl handshake done' );
+ DEBUG(2,'ssl handshake done' );
# ssl connect successful
delete ${*$self}{'_SSL_opening'};
${*$self}{'_SSL_opened'}=1;
@@ -352,13 +421,13 @@
my $socket = ${*$self}{'_SSL_opening'};
if ( ! $socket ) {
# underlying socket not done
- #DEBUG( 'no socket yet' );
+ DEBUG(2,'no socket yet' );
$socket = $self->SUPER::accept($class) || return;
- #DEBUG( 'accept created normal socket '.$socket );
+ DEBUG(2,'accept created normal socket '.$socket );
}
$self->accept_SSL($socket) || return;
- #DEBUG( 'accept_SSL ok' );
+ DEBUG(2,'accept_SSL ok' );
return wantarray ? ($socket, getpeername($socket) ) : $socket;
}
@@ -370,7 +439,7 @@
my $ssl;
if ( ! ${*$self}{'_SSL_opening'} ) {
- #DEBUG( 'starting sslifying' );
+ DEBUG(2,'starting sslifying' );
${*$self}{'_SSL_opening'} = $socket;
my $arg_hash = ${*$self}{'_SSL_arguments'};
${*$socket}{'_SSL_arguments'} = { %$arg_hash, SSL_server => 0 };
@@ -394,7 +463,7 @@
$ssl ||= ${*$socket}{'_SSL_object'};
$SSL_ERROR = undef;
- #DEBUG( 'calling ssleay::accept' );
+ #DEBUG(2,'calling ssleay::accept' );
my $timeout = exists $args->{Timeout}
? $args->{Timeout}
@@ -410,12 +479,12 @@
my $start = defined($timeout) && time();
for my $dummy (1) {
my $rv = Net::SSLeay::accept($ssl);
- #DEBUG( 'called ssleay::accept rv='.$rv );
+ DEBUG(3, "Net::SSLeay::accept -> $rv" );
if ( $rv < 0 ) {
unless ( $socket->_set_rw_error( $ssl,$rv )) {
$socket->error("SSL accept attempt failed with unknown error");
delete ${*$self}{'_SSL_opening'};
- ${*$socket}{'_SSL_opened'} = 1;
+ ${*$socket}{'_SSL_opened'} = -1;
return $socket->fatal_ssl_error();
}
@@ -439,7 +508,7 @@
# failed because of timeout, return
$! ||= ETIMEDOUT;
delete ${*$self}{'_SSL_opening'};
- ${*$socket}{'_SSL_opened'} = 1;
+ ${*$socket}{'_SSL_opened'} = -1;
$socket->blocking(1); # was blocking before
return
}
@@ -453,12 +522,12 @@
} elsif ( $rv == 0 ) {
$socket->error("SSL connect accept failed because of handshake problems" );
delete ${*$self}{'_SSL_opening'};
- ${*$socket}{'_SSL_opened'} = 1;
+ ${*$socket}{'_SSL_opened'} = -1;
return $socket->fatal_ssl_error();
}
}
- #DEBUG( 'handshake done, socket ready' );
+ DEBUG(2,'handshake done, socket ready' );
# socket opened
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = 1;
@@ -674,7 +743,8 @@
sub stop_SSL {
my $self = shift || return _invalid_object();
my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
- return $self->error("SSL object already closed") unless (${*$self}{'_SSL_opened'});
+ return $self->error("SSL object already closed")
+ unless (${*$self}{'_SSL_opened'} == 1);
if (my $ssl = ${*$self}{'_SSL_object'}) {
my $shutdown_done;
@@ -748,7 +818,7 @@
sub kill_socket {
my $self = shift;
shutdown($self, 2);
- $self->close(SSL_no_shutdown => 1) if (${*$self}{'_SSL_opened'});
+ $self->close(SSL_no_shutdown => 1) if (${*$self}{'_SSL_opened'} == 1);
delete(${*$self}{'_SSL_ctx'});
return;
}
@@ -799,7 +869,7 @@
my $start_handshake = $arg_hash->{SSL_startHandshake};
if ( ! defined($start_handshake) || $start_handshake ) {
# if we have no callback force blocking mode
- #DEBUG( "start handshake" );
+ DEBUG(2, "start handshake" );
my $blocking = $socket->blocking(1);
my $result = ${*$socket}{'_SSL_arguments'}{SSL_server}
? $socket->accept_SSL(%to)
@@ -807,7 +877,7 @@
$socket->blocking(0) if !$blocking;
return $result ? $socket : (bless($socket, $original_class) && ());
} else {
- #DEBUG( "dont start handshake: $socket" );
+ DEBUG(2, "dont start handshake: $socket" );
return $socket; # just return upgraded socket
}
@@ -835,25 +905,201 @@
return Net::SSLeay::dump_peer_certificate($ssl);
}
-sub peer_certificate {
+{
+ 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 {
+ 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 || return;
+ my $ssl = $self->_get_ssl_object or return;
- my $cert = ${*$self}{'_SSL_certificate'} ||= Net::SSLeay::get_peer_certificate($ssl) ||
- return $self->error("Could not retrieve peer certificate");
+ my $cert = ${*$self}{_SSL_certificate}
+ ||= Net::SSLeay::get_peer_certificate($ssl)
+ or return $self->error("Could not retrieve peer certificate");
if ($field) {
- my $name = ($field eq "issuer" or $field eq "authority")
- ? Net::SSLeay::X509_get_issuer_name($cert)
- : Net::SSLeay::X509_get_subject_name($cert);
+ 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
+ }
+ }
- return $self->error("Could not retrieve peer certificate $field") unless ($name);
- return Net::SSLeay::X509_NAME_oneline($name);
+ # 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 => 0,
+ 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
+
+ # 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) ) {
+ DEBUG(3, "scheme=$scheme cert=$cert" );
+ $scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
+ }
+
+ # get data from certificate
+ my $commonName = $dispatcher{cn}->($cert);
+ my @altNames = $dispatcher{subjectAltNames}->($cert);
+ DEBUG(3,"identity=$identity cn=$commonName alt=@altNames" );
+
+ 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 ($ip4,$ip6);
+ if ( $identity =~m{:} ) {
+ # no IPv4 or hostname have ':' in it, try IPv6.
+ # make sure that Socket6 was loaded properly
+ UNIVERSAL::can( __PACKAGE__, 'inet_pton' ) or croak
+ q[Looks like IPv6 address, make sure that Socket6 is loaded or make "use IO::Socket::SSL 'inet6'];
+ $ip6 = inet_pton( $identity ) or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
+ } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
+ # definitly no hostname, try IPv4
+ $ip4 = inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
- return $cert
+ # assume hostname
+ if ( $identity !~m{^[a-zA-Z0-9-_\.]+$} ) {
+ $identity = 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{^([\w\-]*)\*(.+)} ) {
+ $pattern = qr{^\Q$1\E[\w\-]*\Q$2\E$}i;
+ } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
+ $pattern = qr{^[\w\-]*\Q$1\E$}i;
+ } else {
+ $pattern = qr{^\Q$name}i;
+ }
+ return $identity =~ $pattern;
};
+
+ my $alt_dnsNames = 0;
+ while (@altNames) {
+ my ($type, $name) = splice (@altNames, 0, 2);
+ if ( $type == GEN_IPADD ) {
+ # exakt match needed for IP
+ # $name is already packed format (inet_xton)
+ return 1 if
+ $ip6 ? $ip6 eq $name :
+ $ip4 ? $ip4 eq $name :
+ 0;
+
+ } elsif ( $type == GEN_DNS ) {
+ $name =~s/\s+$//; $name =~s/^\s+//;
+ $alt_dnsNames++;
+ $check_name->($name,$identity,$scheme->{wildcards_in_alt})
+ and return 1;
+ }
+ }
+
+ if ( $scheme->{check_cn} eq 'always' or
+ $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames) {
+ $check_name->($commonName,$identity,$scheme->{wildcars_in_cn})
+ and return 1;
+ }
+
+ return 0; # no match
+ }
}
+sub verify_hostname {
+ my $self = shift;
+ my $host = shift;
+ my $cert = $self->peer_certificate;
+ return verify_hostname_of_cert( $host,$cert,@_ );
+}
+
+
sub get_cipher {
my $ssl = shift()->_get_ssl_object || return;
return Net::SSLeay::get_cipher($ssl);
@@ -870,7 +1116,9 @@
$@ = $self->errstr;
if (defined $error_trap and ref($error_trap) eq 'CODE') {
$error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error());
- } else { $self->kill_socket; }
+ } else {
+ $self->kill_socket;
+ }
return;
}
@@ -884,7 +1132,7 @@
sub error {
my ($self, $error, $destroy_socket) = @_;
$error .= Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
- carp $error."\n".$self->get_ssleay_error() if $DEBUG;
+ DEBUG(2, $error."\n".$self->get_ssleay_error());
$SSL_ERROR = dualvar( -1, $error );
${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self));
return;
@@ -893,7 +1141,8 @@
sub DESTROY {
my $self = shift || return;
- $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1) if (${*$self}{'_SSL_opened'});
+ $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1)
+ if (${*$self}{'_SSL_opened'} == 1);
delete(${*$self}{'_SSL_ctx'});
}
@@ -918,10 +1167,18 @@
$GLOBAL_CONTEXT_ARGS->{SSL_session_cache} = shift;
}
+sub set_ctx_defaults {
+ my %args = @_;
+ while ( my ($k,$v) = each %args ) {
+ $k =~s{^(SSL_)?}{SSL_};
+ $GLOBAL_CONTEXT_ARGS->{$k} = $v;
+ }
+}
+
sub opened {
my $self = shift;
- return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'};
+ return IO::Handle::opened($self) && ( ${*$self}{'_SSL_opened'} == 1 );
}
sub opening {
@@ -935,8 +1192,10 @@
#Redundant IO::Handle functionality
sub getline { return(scalar shift->readline()) }
-sub getlines { if (wantarray()) { return(shift->readline()) }
- else { croak("Use of getlines() not allowed in scalar context"); }}
+sub getlines {
+ return(shift->readline()) if wantarray();
+ croak("Use of getlines() not allowed in scalar context");
+}
#Useless IO::Handle functionality
sub truncate { croak("Use of truncate() not allowed with SSL") }
@@ -971,15 +1230,15 @@
bless \$handle, $class;
}
-sub READ { ${shift()}->sysread (@_) }
-sub READLINE { ${shift()}->readline (@_) }
-sub GETC { ${shift()}->getc (@_) }
+sub READ { ${shift()}->sysread(@_) }
+sub READLINE { ${shift()}->readline(@_) }
+sub GETC { ${shift()}->getc(@_) }
-sub PRINT { ${shift()}->print (@_) }
-sub PRINTF { ${shift()}->printf (@_) }
-sub WRITE { ${shift()}->syswrite (@_) }
+sub PRINT { ${shift()}->print(@_) }
+sub PRINTF { ${shift()}->printf(@_) }
+sub WRITE { ${shift()}->syswrite(@_) }
-sub FILENO { ${shift()}->fileno (@_) }
+sub FILENO { ${shift()}->fileno(@_) }
sub TELL { $! = EBADF; return -1 }
sub BINMODE { return 0 } # not perfect, but better than not implementing the method
@@ -1007,7 +1266,7 @@
# it can be blessed.
sub new {
my $class = shift;
- DEBUG( "$class @_" );
+ #DEBUG( "$class @_" );
my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
my $ctx_object = $arg_hash->{'SSL_reuse_ctx'};
@@ -1036,24 +1295,23 @@
# buffer was written and not block for the rest
# SSL_MODE_ENABLE_PARTIAL_WRITE can be necessary for non-blocking because we
# cannot guarantee, that the location of the buffer stays constant
- Net::SSLeay::CTX_set_mode( $ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER
- |SSL_MODE_ENABLE_PARTIAL_WRITE);
+ Net::SSLeay::CTX_set_mode( $ctx,
+ SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER|SSL_MODE_ENABLE_PARTIAL_WRITE);
- my ($verify_mode, $verify_cb) = @{$arg_hash}{'SSL_verify_mode','SSL_verify_callback'};
- unless ($verify_mode == Net::SSLeay::VERIFY_NONE())
- {
- &Net::SSLeay::CTX_load_verify_locations
- ($ctx, @{$arg_hash}{'SSL_ca_file','SSL_ca_path'}) ||
- return IO::Socket::SSL->error("Invalid certificate authority locations");
+ my $verify_mode = $arg_hash->{SSL_verify_mode};
+ unless ($verify_mode == Net::SSLeay::VERIFY_NONE()) {
+ Net::SSLeay::CTX_load_verify_locations(
+ $ctx, $arg_hash->{SSL_ca_file},$arg_hash->{SSL_ca_path}
+ ) || return IO::Socket::SSL->error("Invalid certificate authority locations");
}
if ($arg_hash->{'SSL_check_crl'}) {
- if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090702f)
- {
- Net::SSLeay::X509_STORE_CTX_set_flags
- (Net::SSLeay::CTX_get_cert_store($ctx),
- Net::SSLeay::X509_V_FLAG_CRL_CHECK());
+ if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090702f) {
+ Net::SSLeay::X509_STORE_CTX_set_flags(
+ Net::SSLeay::CTX_get_cert_store($ctx),
+ Net::SSLeay::X509_V_FLAG_CRL_CHECK()
+ );
} else {
return IO::Socket::SSL->error("CRL not supported for OpenSSL < v0.9.7b");
}
@@ -1108,8 +1366,8 @@
}
}
- my $verify_callback = $verify_cb &&
- sub {
+ my $verify_cb = $arg_hash->{SSL_verify_callback};
+ my $verify_callback = $verify_cb && sub {
my ($ok, $ctx_store) = @_;
my ($cert, $error);
if ($ctx_store) {
@@ -1119,13 +1377,14 @@
Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert));
$error &&= Net::SSLeay::ERR_error_string($error);
}
+ DEBUG(3, "ok=$ok cert=$cert" );
return $verify_cb->($ok, $ctx_store, $cert, $error);
};
Net::SSLeay::CTX_set_verify($ctx, $verify_mode, $verify_callback);
$ctx_object = { context => $ctx };
- DEBUG( "new ctx $ctx" );
+ DEBUG(3, "new ctx $ctx" );
$CTX_CREATED_IN_THIS_THREAD{$ctx} = 1;
if ( my $cache = $arg_hash->{SSL_session_cache} ) {
@@ -1156,14 +1415,14 @@
}
-sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); DEBUG( "clone!" ) }
+sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); }
sub DESTROY {
my $self = shift;
if ( my $ctx = $self->{context} ) {
- DEBUG( "free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD ));
+ DEBUG( 3,"free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD ));
if ( %CTX_CREATED_IN_THIS_THREAD and
delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) {
- DEBUG( "OK free ctx $ctx" );
+ DEBUG( 3,"OK free ctx $ctx" );
Net::SSLeay::CTX_free($ctx);
}
}
@@ -1237,18 +1496,16 @@
=head1 SYNOPSIS
+ use strict;
use IO::Socket::SSL;
- my $client = IO::Socket::SSL->new("www.example.com:https");
+ my $client = IO::Socket::SSL->new("www.example.com:https")
+ || warn "I encountered a problem: ".IO::Socket::SSL::errstr();
+ $client->verify_hostname( 'www.example.com','http' )
+ || die "hostname verification failed";
- if ($client) {
print $client "GET / HTTP/1.0\r\n\r\n";
print <$client>;
- close $client;
- } else {
- warn "I encountered a problem: ",
- IO::Socket::SSL::errstr();
- }
=head1 DESCRIPTION
@@ -1376,6 +1633,7 @@
(0x00) does no authentication. You may combine 0x01 (verify peer), 0x02 (fail
verification if no peer certificate exists; ignored for clients), and 0x04
(verify client once) to change the default.
+See OpenSSL man page for SSL_CTX_set_verify for more information.
=item SSL_verify_callback
@@ -1388,6 +1646,22 @@
The function should return 1 or 0, depending on whether it thinks the certificate
is valid or invalid. The default is to let OpenSSL do all of the busy work.
+=item SSL_verifycn_scheme
+
+Set the scheme used to automatically verify the hostname of the peer.
+See the information about the verification schemes in B<verify_hostname>.
+The default is undef, e.g. to not automatically verify the hostname.
+
+=item SSL_verifycn_name
+
+Set the name which is used in verification of hostname. If SSL_verifycn_scheme
+is set and no SSL_verifycn_name is given it will try to use the PeerHost and
+PeerAddr settings and fail if no name caan be determined.
+
+Using PeerHost or PeerAddr works only if you create the connection directly
+with C<< IO::Socket::SSL->new >>, if an IO::Socket::INET object is upgraded
+with B<start_SSL> the name has to be given in B<SSL_verifycn_name>.
+
=item SSL_check_crl
If you want to verify that the peer certificate has not been revoked by the
@@ -1504,13 +1778,99 @@
=item B<peer_certificate($field)>
-If a peer certificate exists, this function can retrieve values from it. Right now, the
-only fields it can return are "authority" and "owner" (or "issuer" and "subject" if
-you want to use OpenSSL names), corresponding to the certificate authority that signed the
-peer certificate and the owner of the peer certificate. This function returns a string
-with all the information about the particular field in one parsable line.
-If no field is given it returns the full certificate (x509).
+If a peer certificate exists, this function can retrieve values from it.
+If no field is given the internal representation of certificate from Net::SSLeay is
+returned.
+The following fields can be queried:
+=over 8
+
+=item authority (alias issuer)
+
+The certificate authority which signed the certificate.
+
+=item owner (alias subject)
+
+The owner of the certificate.
+
+=item commonName (alias cn) - only for Net::SSLeay version >=1.30
+
+The common name, usually the server name for SSL certificates.
+
+=item subjectAltNames - only for Net::SSLeay version >=1.33
+
+Alternative names for the subject, usually different names for the same
+server, like example.org, example.com, *.example.com.
+
+It returns a list of (typ,value) with typ GEN_DNS, GEN_IPADD etc (these
+constants are exported from IO::Socket::SSL).
+See Net::SSLeay::X509_get_subjectAltNames.
+
+=back
+
+=item B<verify_hostname($hostname,$scheme)>
+
+This verifies the given hostname against the peer certificate using the
+given scheme. Hostname is usually what you specify within the PeerAddr.
+
+Verification of hostname against a certificate is different between various
+applications and RFCs. Some scheme allow wildcards for hostnames, some only
+in subjectAltNames, and even their different wildcard schemes are possible.
+
+To ease the verification the following schemes are predefined:
+
+=over 8
+
+=item ldap (rfc4513), pop3,imap,acap (rfc2995), nntp (rfc4642)
+
+Simple wildcards in subjectAltNames are possible, e.g. *.example.org matches
+www.example.org but not lala.www.example.org. If nothing from subjectAltNames
+match it checks against the common name, but there are no wildcards allowed.
+
+=item http (rfc2818), alias is www
+
+Extended wildcards in subjectAltNames are possible, e.g. *.example.org or
+even www*.example.org. Wildcards in the common name are not allowed. The common
+name will be only checked if no names are given in subjectAltNames.
+
+=item smtp (rfc3207)
+
+This RFC doesn't say much useful about the verification so it just assumes
+that subjectAltNames are possible, but no wildcards are possible anywhere.
+
+=back
+
+The scheme can be given either by specifying the name for one of the above predefined
+schemes, by using a callback (see below) or by using a hash which can have the
+following keys and values:
+
+=over 8
+
+=item check_cn: 0|'always'|'when_only'
+
+Determines if the common name gets checked. If 'always' it will always be checked
+(like in ldap), if 'when_only' it will only be checked if no names are given in
+subjectAltNames (like in http), for any other values the common name will not be checked.
+
+=item wildcards_in_alt: 0|'leftmost'|'anywhere'
+
+Determines if and where wildcards in subjectAltNames are possible. If 'leftmost'
+only cases like *.example.org will be possible (like in ldap), for 'anywhere'
+www*.example.org is possible too (like http), dangerous things like but www.*.org
+or even '*' will not be allowed.
+
+=item wildcards_in_cn: 0|'leftmost'|'anywhere'
+
+Similar to wildcards_in_alt, but checks the common name. There is no predefined
+scheme which allows wildcards in common names.
+
+=back
+
+If you give a subroutine for verification it will be called with the arguments
+($hostname,$commonName,@subjectAltNames), where hostname is the name given for
+verification, commonName is the result from peer_certificate('cn') and
+subjectAltNames is the result from peer_certificate('subjectAltNames').
+
=item B<errstr()>
Returns the last error (in string form) that occurred. If you do not have a real
@@ -1577,9 +1937,27 @@
See the SSL_session_cache option of new() for more details. Note that this sets the default
cache globally, so use with caution.
+=item B<IO::Socket::SSL::set_ctx_defaults(%args)>
+With this function one can set defaults for all SSL_* parameter used for creation of
+the context, like the SSL_verify* parameter.
+
+=over 8
+
+=item mode - set default SSL_verify_mode
+
+=item callback - set default SSL_verify_callback
+
+=item scheme - set default SSL_verifycn_scheme
+
+=item name - set default SSL_verifycn_name
+
+If not given and scheme is hash reference with key callback it will be set to 'unknown'
+
=back
+=back
+
The following methods are unsupported (not to mention futile!) and IO::Socket::SSL
will emit a large CROAK() if you are silly enough to use them:
@@ -1637,36 +2015,31 @@
If you are having problems using IO::Socket::SSL despite the fact that can recite backwards
the section of this documentation labelled 'Using SSL', you should try enabling debugging. To
-specify the debug level, pass 'debug#' (where # is a number from 0 to 4) to IO::Socket::SSL
-when calling it:
+specify the debug level, pass 'debug#' (where # is a number from 0 to 3) to IO::Socket::SSL
+when calling it.
+The debug level will also be propagated to Net::SSLeay::trace, see also L<Net::SSLeay>:
=over 4
=item use IO::Socket::SSL qw(debug0);
-#No debugging (default).
+No debugging (default).
=item use IO::Socket::SSL qw(debug1);
-#Only print out errors.
+Print out errors from IO::Socket::SSL and ciphers from Net::SSLeay.
=item use IO::Socket::SSL qw(debug2);
-#Print out errors and cipher negotiation.
+Print also information about call flow from IO::Socket::SSL and progress
+information from Net::SSLeay.
=item use IO::Socket::SSL qw(debug3);
-#Print out progress, ciphers, and errors.
+Print also some data dumps from IO::Socket::SSL and from Net::SSLeay.
-=item use IO::Socket::SSL qw(debug4);
-
-#Print out everything, including data.
-
=back
-You can also set $IO::Socket::SSL::DEBUG to 0-4, but that's a bit of a mouthful,
-isn't it?
-
=head1 EXAMPLES
See the 'example' directory.
@@ -1677,7 +2050,7 @@
This is because IO::Socket::SSL is based on Net::SSLeay which
uses a global object to access some of the API of openssl
and is therefore not threadsafe.
-It might probably work if you don't use SSL_verify_cb and
+It might probably work if you don't use SSL_verify_callback and
SSL_password_cb.
IO::Socket::SSL does not work together with Storable::fd_retrieve/fd_store.
Attachment:
signature.asc
Description: Digital signature