IO-Socket-SSL
view release on metacpan or search on metacpan
lib/IO/Socket/SSL.pm view on Meta::CPAN
#vim: set sts=4 sw=4 ts=8 ai:
#
# IO::Socket::SSL:
# provide an interface to SSL connections similar to IO::Socket modules
#
# Current Code Shepherd: Steffen Ullrich <sullr at cpan.org>
# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu>
#
# The original version of this module was written by
# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from
# Crypt::SSLeay (Net::SSL) by Gisle Aas.
#
package IO::Socket::SSL;
our $VERSION = '2.098';
use IO::Socket;
use Net::SSLeay 1.46;
use IO::Socket::SSL::PublicSuffix;
use Exporter ();
use Errno qw( EWOULDBLOCK EAGAIN ETIMEDOUT EINTR EPIPE EPERM );
use Carp;
use Scalar::Util qw(weaken blessed dualvar);
use Symbol;
use strict;
my $use_threads;
BEGIN {
require Config;
$use_threads = $Config::Config{usethreads};
}
# results from commonly used constant functions from Net::SSLeay for fast access
my $Net_SSLeay_ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ();
my $Net_SSLeay_ERROR_WANT_WRITE = Net::SSLeay::ERROR_WANT_WRITE();
my $Net_SSLeay_ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL();
my $Net_SSLeay_ERROR_SSL = Net::SSLeay::ERROR_SSL();
my $Net_SSLeay_VERIFY_NONE = Net::SSLeay::VERIFY_NONE();
my $Net_SSLeay_VERIFY_PEER = Net::SSLeay::VERIFY_PEER();
use constant SSL_VERIFY_NONE => &Net::SSLeay::VERIFY_NONE;
use constant SSL_VERIFY_PEER => &Net::SSLeay::VERIFY_PEER;
use constant SSL_VERIFY_FAIL_IF_NO_PEER_CERT => Net::SSLeay::VERIFY_FAIL_IF_NO_PEER_CERT();
use constant SSL_VERIFY_CLIENT_ONCE => Net::SSLeay::VERIFY_CLIENT_ONCE();
# from openssl/ssl.h; should be better in Net::SSLeay
use constant SSL_SENT_SHUTDOWN => 1;
use constant SSL_RECEIVED_SHUTDOWN => 2;
use constant SSL_OCSP_NO_STAPLE => 0b00001;
use constant SSL_OCSP_MUST_STAPLE => 0b00010;
use constant SSL_OCSP_FAIL_HARD => 0b00100;
use constant SSL_OCSP_FULL_CHAIN => 0b01000;
use constant SSL_OCSP_TRY_STAPLE => 0b10000;
# capabilities of underlying Net::SSLeay/openssl
my $can_client_sni; # do we support SNI on the client side
my $can_server_sni; # do we support SNI on the server side
my $can_multi_cert; # RSA and ECC certificate in same context
my $can_npn; # do we support NPN (obsolete)
my $can_alpn; # do we support ALPN
my $can_ecdh; # do we support ECDH key exchange
my $set_groups_list; # SSL_CTX_set1_groups_list || SSL_CTX_set1_curves_list || undef
my $can_ocsp; # do we support OCSP
my $can_ocsp_staple; # do we support OCSP stapling
my $can_tckt_keycb; # TLS ticket key callback
my $can_pha; # do we support PHA
my $session_upref; # SSL_SESSION_up_ref is implemented
my %sess_cb; # SSL_CTX_sess_set_(new|remove)_cb
my $check_partial_chain; # use X509_V_FLAG_PARTIAL_CHAIN if available
my $auto_retry; # (clear|set)_mode SSL_MODE_AUTO_RETRY with OpenSSL 1.1.1+ with non-blocking
my $ssl_mode_release_buffers = 0; # SSL_MODE_RELEASE_BUFFERS if available
my $can_ciphersuites; # support for SSL_CTX_set_ciphersuites (TLS 1.3)
my $can_client_psk; # work as PSK client
my $can_server_psk; # work as PSK server
my $openssl_version;
lib/IO/Socket/SSL.pm view on Meta::CPAN
return ($host,$port);
};
'Socket';
} || eval {
require Socket6;
Socket6::inet_pton( AF_INET6(),'::1') && AF_INET6() or die;
Socket6->import( qw/inet_pton NI_NUMERICHOST NI_NUMERICSERV/ );
# behavior different to Socket::getnameinfo - wrap
*_getnameinfo = sub { return Socket6::getnameinfo(@_); };
'Socket6';
} || undef;
# try IO::Socket::IP or IO::Socket::INET6 for IPv6 support
$family_key = 'Domain'; # traditional
if ($ip6) {
# if we have IO::Socket::IP >= 0.31 we will use this in preference
# because it can handle both IPv4 and IPv6
if ( eval {
require IO::Socket::IP;
IO::Socket::IP->VERSION(0.31)
}) {
@ISA = qw(IO::Socket::IP);
constant->import( CAN_IPV6 => "IO::Socket::IP" );
$family_key = 'Family';
$IOCLASS = "IO::Socket::IP";
# if we have IO::Socket::INET6 we will use this not IO::Socket::INET
# because it can handle both IPv4 and IPv6
# require at least 2.62 because of several problems before that version
} elsif( eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION(2.62) } ) {
@ISA = qw(IO::Socket::INET6);
constant->import( CAN_IPV6 => "IO::Socket::INET6" );
$IOCLASS = "IO::Socket::INET6";
} else {
$ip6 = ''
}
}
# fall back to IO::Socket::INET for IPv4 only
if (!$ip6) {
@ISA = qw(IO::Socket::INET);
$IOCLASS = "IO::Socket::INET";
constant->import(CAN_IPV6 => '');
if (!defined $ip6) {
constant->import(NI_NUMERICHOST => 1);
constant->import(NI_NUMERICSERV => 2);
}
}
#Make $DEBUG another name for $Net::SSLeay::trace
*DEBUG = \$Net::SSLeay::trace;
#Compatibility
*ERROR = \$SSL_ERROR;
}
sub DEBUG {
$DEBUG or return;
my (undef,$file,$line,$sub) = caller(1);
if ($sub =~m{^IO::Socket::SSL::(?:error|(_internal_error))$}) {
(undef,$file,$line) = caller(2) if $1;
} else {
(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 };
}
*idn_to_ascii = \&IO::Socket::SSL::PublicSuffix::idn_to_ascii;
*idn_to_unicode = \&IO::Socket::SSL::PublicSuffix::idn_to_unicode;
}
my $OPENSSL_LIST_SEPARATOR = $^O =~m{^(?:(dos|os2|mswin32|netware)|vms)$}i
? $1 ? ';' : ',' : ':';
my $CHECK_SSL_PATH = sub {
my %args = (@_ == 1) ? ('',@_) : @_;
for my $type (keys %args) {
my $path = $args{$type};
if (!$type) {
delete $args{$type};
$type = (ref($path) || -d $path) ? 'SSL_ca_path' : 'SSL_ca_file';
$args{$type} = $path;
}
next if ref($path) eq 'SCALAR' && ! $$path;
if ($type eq 'SSL_ca_file') {
die "SSL_ca_file $path can't be used: $!"
if ! open(my $fh,'<',$path);
} elsif ($type eq 'SSL_ca_path') {
$path = [ split($OPENSSL_LIST_SEPARATOR,$path) ] if !ref($path);
my @err;
for my $d (ref($path) ? @$path : $path) {
if (! -d $d) {
push @err, "SSL_ca_path $d does not exist";
} elsif (! opendir(my $dh,$d)) {
push @err, "SSL_ca_path $d is not accessible: $!"
} else {
@err = ();
last
}
}
die "@err" if @err;
}
}
return %args;
};
{
my %default_ca;
my $ca_detected; # 0: never detect, undef: need to (re)detect
my $openssldir;
sub default_ca {
if (@_) {
# user defined default CA or reset
if ( @_ > 1 ) {
%default_ca = @_;
$ca_detected = 0;
} elsif ( my $path = shift ) {
%default_ca = $CHECK_SSL_PATH->($path);
$ca_detected = 0;
} else {
$ca_detected = undef;
}
}
return %default_ca if defined $ca_detected;
# SSLEAY_DIR was 5 up to OpenSSL 1.1, then switched to 4 and got
# renamed to OPENSSL_DIR. Unfortunately it is not exported as constant
lib/IO/Socket/SSL.pm view on Meta::CPAN
@_ = ( $class,@export );
goto &Exporter::import;
}
my %SSL_OBJECT;
my %CREATED_IN_THIS_THREAD;
sub CLONE { %CREATED_IN_THIS_THREAD = (); }
# all keys specific for the current state of the socket
# these should be removed on close
my %all_my_conn_keys = map { $_ => 1 } qw(
_SSL_fileno
_SSL_object
_SSL_opened
_SSL_opening
_SSL_read_closed
_SSL_write_closed
_SSL_rawfd
_SSL_bio_socket
_SSL_bio_sub
);
my %all_my_conn_and_cert_keys = (
%all_my_conn_keys,
_SSL_certificate => 1,
);
# all keys used internally, these should be cleaned up at end
# but not already on close
my %all_my_keys = (
%all_my_conn_and_cert_keys,
map { $_ => 1 } qw(
_SSL_arguments
_SSL_ctx
_SSL_ioclass_upgraded
_SSL_last_err
_SSL_ocsp_verify
_SSL_servername
_SSL_msg_callback
)
);
# we have callbacks associated with contexts, but have no way to access the
# current SSL object from these callbacks. To work around this
# CURRENT_SSL_OBJECT will be set before calling Net::SSLeay::{connect,accept}
# and reset afterwards, so we have access to it inside _internal_error.
my $CURRENT_SSL_OBJECT;
# You might be expecting to find a new() subroutine here, but that is
# not how IO::Socket::INET works. All configuration gets performed in
# the calls to configure() and either connect() or accept().
#Call to configure occurs when a new socket is made using
#IO::Socket::INET. Returns false (empty list) on failure.
sub configure {
my ($self, $arg_hash) = @_;
return _invalid_object() unless($self);
# force initial blocking
# otherwise IO::Socket::SSL->new might return undef if the
# socket is nonblocking and it fails to connect immediately
# for real nonblocking behavior one should create a nonblocking
# socket and later call connect explicitly
my $blocking = delete $arg_hash->{Blocking};
# because Net::HTTPS simple redefines blocking() to {} (e.g.
# return undef) and IO::Socket::INET does not like this we
# set Blocking only explicitly if it was set
$arg_hash->{Blocking} = 1 if defined ($blocking);
$self->configure_SSL($arg_hash) || return;
if ($arg_hash->{$family_key} ||= $arg_hash->{Domain} || $arg_hash->{Family}) {
# Hack to work around the problem that IO::Socket::IP defaults to
# AI_ADDRCONFIG which creates problems if we have only the loopback
# interface. If we already know the family this flag is more harmful
# then useful.
$arg_hash->{GetAddrInfoFlags} = 0 if $IOCLASS eq 'IO::Socket::IP'
&& ! defined $arg_hash->{GetAddrInfoFlags};
}
return $self->_internal_error("@ISA configuration failed",0)
if ! $self->SUPER::configure($arg_hash);
$self->blocking(0) if defined $blocking && !$blocking;
return $self;
}
sub configure_SSL {
my ($self, $arg_hash) = @_;
$arg_hash->{Proto} ||= 'tcp';
my $is_server = $arg_hash->{SSL_server};
if ( ! defined $is_server ) {
$is_server = $arg_hash->{SSL_server} = $arg_hash->{Listen} || 0;
}
# add user defined defaults, maybe after filtering
$FILTER_SSL_ARGS->($is_server,$arg_hash) if $FILTER_SSL_ARGS;
# cleanup in case there was something left, but leave BIO socket
_cleanup_ssl($self, undef, '_SSL_bio_socket');
${*$self}{_SSL_opened} = $is_server;
${*$self}{_SSL_arguments} = $arg_hash;
# this adds defaults to $arg_hash as a side effect!
${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash)
or return;
return $self;
}
sub _skip_rw_error {
my ($self,$ssl,$rv) = @_;
my $err = Net::SSLeay::get_error($ssl,$rv);
if ( $err == $Net_SSLeay_ERROR_WANT_READ) {
$SSL_ERROR = SSL_WANT_READ;
} elsif ( $err == $Net_SSLeay_ERROR_WANT_WRITE) {
$SSL_ERROR = SSL_WANT_WRITE;
} else {
return $err;
}
$! ||= EWOULDBLOCK;
${*$self}{_SSL_last_err} = [$SSL_ERROR,4] if ref($self);
Net::SSLeay::ERR_clear_error();
return 0;
}
# Call to connect occurs when a new client socket is made using IO::Socket::*
sub connect {
my $self = shift || return _invalid_object();
return $self if ${*$self}{'_SSL_opened'}; # already connected
if ( ! ${*$self}{'_SSL_opening'} ) {
# call SUPER::connect if the underlying socket is not connected
# 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>=2 && DEBUG('socket not yet connected' );
$self->SUPER::connect(@_) || return;
$DEBUG>=2 && DEBUG('socket connected' );
# IO::Socket works around systems, which return EISCONN or similar
# on non-blocking re-connect by returning true, even if $! is set
# but it does not clear $!, so do it here
$! = undef;
# don't continue with connect_SSL if SSL_startHandshake is set to 0
my $sh = ${*$self}{_SSL_arguments}{SSL_startHandshake};
return $self if defined $sh && ! $sh;
}
return $self->connect_SSL;
}
sub connect_SSL {
my $self = shift;
my $args = @_>1 ? {@_}: $_[0]||{};
return $self if ${*$self}{'_SSL_opened'}; # already connected
my ($ssl,$ctx);
if ( ! ${*$self}{'_SSL_opening'} ) {
# start ssl connection
$DEBUG>=2 && DEBUG('ssl handshake not started' );
${*$self}{'_SSL_opening'} = 1;
lib/IO/Socket/SSL.pm view on Meta::CPAN
}
# socket is ready, try non-blocking connect again after recomputing timeout
$DEBUG>=2 && DEBUG("socket ready, retrying connect" );
my $now = time();
$timeout -= $now - $start;
$start = $now;
redo;
} elsif ( $rv == 0 ) {
delete ${*$self}{'_SSL_opening'};
$DEBUG>=2 && DEBUG("connection failed - connect returned 0" );
$self->error("SSL connect attempt failed because of handshake problems" );
${*$self}{'_SSL_opened'} = -1;
return $self->fatal_ssl_error();
}
}
$DEBUG>=2 && DEBUG('ssl handshake done' );
# ssl connect successful
delete ${*$self}{'_SSL_opening'};
${*$self}{'_SSL_opened'}=1;
if (defined($timeout)) {
$self->blocking(1); # reset back to blocking
$! = undef; # reset errors from non-blocking
}
$ctx ||= ${*$self}{'_SSL_ctx'};
if ( my $ocsp_result = ${*$self}{_SSL_ocsp_verify} ) {
# got result from OCSP stapling
if ( $ocsp_result->[0] > 0 ) {
$DEBUG>=3 && DEBUG("got OCSP success with stapling");
# successful validated
} elsif ( $ocsp_result->[0] < 0 ) {
# Permanent problem with validation because certificate
# is either self-signed or the issuer cannot be found.
# Ignore here, because this will cause other errors too.
$DEBUG>=3 && DEBUG("got OCSP failure with stapling: %s",
$ocsp_result->[1]);
} else {
# definitely revoked
$DEBUG>=3 && DEBUG("got OCSP revocation with stapling: %s",
$ocsp_result->[1]);
$self->_internal_error($ocsp_result->[1],5);
return $self->fatal_ssl_error();
}
} elsif ( $ctx->{ocsp_mode} & SSL_OCSP_MUST_STAPLE ) {
$self->_internal_error("did not receive the required stapled OCSP response",5);
return $self->fatal_ssl_error();
}
if (!%sess_cb and $ctx->{session_cache}
and my $session = Net::SSLeay::get1_session($ssl)) {
$ctx->{session_cache}->add_session(
${*$self}{_SSL_arguments}{SSL_session_key},
$session
);
}
tie *{$self}, "IO::Socket::SSL::SSL_HANDLE", $self;
return $self;
}
# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'}
# this can be the case if start_SSL is called with a normal IO::Socket::INET
# so that PeerAddr|PeerPort are not set from args
# returns PeerAddr
sub _update_peer {
my $self = shift;
my $arg_hash = ${*$self}{'_SSL_arguments'};
eval {
my $sockaddr = getpeername( $self );
my $af = sockaddr_family($sockaddr);
if( CAN_IPV6 && $af == AF_INET6 ) {
my (undef, $host, $port) = _getnameinfo($sockaddr,
NI_NUMERICHOST | NI_NUMERICSERV);
$arg_hash->{PeerPort} = $port;
$arg_hash->{PeerAddr} = $host;
} else {
my ($port,$addr) = sockaddr_in( $sockaddr);
$arg_hash->{PeerPort} = $port;
$arg_hash->{PeerAddr} = inet_ntoa( $addr );
}
}
}
#Call to accept occurs when a new client connects to a server using
#IO::Socket::SSL
sub accept {
my $self = shift || return _invalid_object();
my $class = shift || 'IO::Socket::SSL';
my $socket = ${*$self}{'_SSL_opening'};
if ( ! $socket ) {
# underlying socket not done
$DEBUG>=2 && DEBUG('no socket yet' );
$socket = $self->SUPER::accept($class) || return;
$DEBUG>=2 && DEBUG('accept created normal socket '.$socket );
# don't continue with accept_SSL if SSL_startHandshake is set to 0
my $sh = ${*$self}{_SSL_arguments}{SSL_startHandshake};
if (defined $sh && ! $sh) {
$socket = _setup_accepted_socket($self,$socket);
$DEBUG>=2 && DEBUG('will not start SSL handshake yet');
return wantarray ? ($socket, getpeername($socket) ) : $socket
}
}
$self->accept_SSL($socket) || return;
$DEBUG>=2 && DEBUG('accept_SSL ok' );
return wantarray ? ($socket, getpeername($socket) ) : $socket;
}
sub _setup_accepted_socket {
my ($self,$socket) = @_;
my $args = ${*$self}{_SSL_arguments};
my $biosock = ${*$self}{_SSL_bio_socket};
my $usebio = $biosock || $args->{SSL_usebio};
if ($socket != $self) {
$socket = _bio_wrap_socket(blessed($self), $biosock = $socket) if $usebio;
${*$socket}{_SSL_ctx} = ${*$self}{_SSL_ctx};
${*$socket}{_SSL_arguments} = { %$args, SSL_server => 0 };
} elsif ($usebio && !$biosock) {
die "cannot upgrade socket in-place with SSL BIO"
}
return $socket;
}
sub accept_SSL {
my $self = shift;
my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self;
my $args = @_>1 ? {@_}: $_[0]||{};
my $ssl;
if ( ! ${*$self}{'_SSL_opening'} ) {
$DEBUG>=2 && DEBUG('starting sslifying' );
$socket = _setup_accepted_socket($self,$socket) if $socket != $self;
${*$self}{'_SSL_opening'} = $socket;
$ssl = ${*$socket}{_SSL_object} =
Net::SSLeay::new(${*$socket}{_SSL_ctx}{context})
|| return $socket->error("SSL structure creation failed");
$CREATED_IN_THIS_THREAD{$ssl} = 1 if $use_threads;
$SSL_OBJECT{$ssl} = [$socket,1];
weaken($SSL_OBJECT{$ssl}[0]);
my $fileno = ${*$socket}{_SSL_fileno} = fileno($socket);
if (${*$socket}{_SSL_bio_socket}) {
_bio_attach($socket);
} else {
lib/IO/Socket/SSL.pm view on Meta::CPAN
goto retry_after_dobio if $dobio->($self,
$SSL_ERROR == SSL_WANT_READ,
$SSL_ERROR == SSL_WANT_WRITE,
\$err);
}
if ($err) {
$socket->error("SSL accept attempt failed");
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = -1;
return $socket->fatal_ssl_error();
}
# accept 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);
# wait until socket is readable or writable
my $rv;
if ( $timeout>0 ) {
my $vec = '';
vec($vec,$socket->fileno,1) = 1;
$rv =
$SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
$SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
undef;
} else {
$! = ETIMEDOUT
}
if ( ! $rv ) {
# failed because of timeout, return
$! ||= ETIMEDOUT;
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = -1;
$socket->blocking(1); # was blocking before
return
}
# socket is ready, try non-blocking accept again after recomputing timeout
my $now = time();
$timeout -= $now - $start;
$start = $now;
redo;
} elsif ( $rv == 0 ) {
$socket->error("SSL accept attempt failed because of handshake problems" );
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = -1;
return $socket->fatal_ssl_error();
}
}
$DEBUG>=2 && DEBUG('handshake done, socket ready' );
# socket opened
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = 1;
if (defined($timeout)) {
$socket->blocking(1); # reset back to blocking
$! = undef; # reset errors from non-blocking
}
tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket;
return $socket;
}
sub _bio_wrap_socket {
my ($class,$upper_socket) = @_;
my $self = bless gensym(),$class;
${*$self}{_SSL_bio_socket} = $upper_socket;
return $self;
}
sub _bio_attach {
my $self = shift;
my $ssl = ${*$self}{_SSL_object} or die "no SSL object for BIO attach";
my $rbio = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem());
my $wbio = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem());
Net::SSLeay::set_bio($ssl, $rbio, $wbio);
my $wbuf = ''; # BIO_read(wbio) but not syswrite yet
my $rbuf = ''; # collect full TLS record before BIO_write($rbio)
${*$self}{_SSL_bio_sub} = sub {
my ($self,$read,$write,$r_err) = @_;
my $biosock = ${*$self}{_SSL_bio_socket} or die "no BIO socket";
my $rv = 0;
while ($wbuf ne '' or Net::SSLeay::BIO_pending($wbio)>0) {
if ($wbuf eq '') {
my $buf = Net::SSLeay::BIO_read($wbio);
if (!defined $buf or $buf eq '') {
last; # nothing new to write
} else {
$wbuf .= $buf;
}
}
my $n = syswrite($biosock,$wbuf);
if ($n) {
substr($wbuf,0,$n,'');
$rv += $write || 0;
$write = 0; # count only once but continue to flush wbuf
} elsif (!defined $n) {
goto socket_error if !$!{EAGAIN} && !$!{EWOULDBLOCK};
last;
} else {
# should not return 0 with non-empty wbuf, treat as error
goto socket_error;
}
}
# $read should only be requested on SSL_WANT_READ. It will only feed a
# single and complete TLS record into the BIO since it is unknown if
# more data are actually wanted by the TLS layer
{
$read or last;
# read (remaining part of) single TLS record
my $need = 5-length($rbuf); # TLS record start
my $n;
while ($need>0) {
$n = sysread($biosock,$rbuf,$need,length($rbuf));
goto full_read_failed if !$n;
$need -= $n;
}
$need = unpack("x3n", $rbuf); # extract length of record
while ($need>0) {
$n = sysread($biosock,$rbuf,$need,length($rbuf));
goto full_read_failed if !$n;
$need -= $n;
}
# full TLS record read -> send to BIO
Net::SSLeay::BIO_write($rbio,$rbuf)>0 or die "BIO_write failed";
$rbuf = '';
$rv += $read;
last;
full_read_failed: # $n == 0|undef
if (defined $n) { # $n==0
# signal EOF
# XXX not available in Net::SSLeay, propagate via r_err
# Net::SSLeay::BIO_set_mem_eof_return($rbio, 0);
$$r_err = $Net_SSLeay_ERROR_SSL;
} elsif ($!{EAGAIN} || $!{EWOULDBLOCK}) {
# retry later
} else {
goto socket_error; # fatal
}
}
return $rv;
socket_error:
# unavailable - Net::SSLeay::BIO_set_mem_eof_return($rbio, 0);
$$r_err = $Net_SSLeay_ERROR_SSL;
$DEBUG>=2 && DEBUG("biosock error: $!" );
return;
};
}
# support user defined message callback but also internal debugging
sub _msg_callback {
## my ($direction, $ssl_ver, $content_type, $buf, $len, $ssl, $userp) = @_;
IO::Socket::SSL::Trace::ossl_trace(@_) if $DEBUG>=2;
my $self = ($SSL_OBJECT{$_[5]} || return)->[0] || return;
if (my $cb = ${*$self}{_SSL_msg_callback}) {
my ($sub,@arg) = @$cb;
$sub->($self, @_[0..5], @arg);
}
}
my $ssleay_set_msg_callback = defined &Net::SSLeay::set_msg_callback
&& \&Net::SSLeay::set_msg_callback;
sub set_msg_callback {
my $self = shift;
if (@_) {
if ($_[0]) {
# enable user defined callback: ($cb,@arg)
die "no support for msg callback with this version of Net::SSLeay/OpenSSL"
if !$ssleay_set_msg_callback;
${*$self}{_SSL_msg_callback} = [@_];
} else {
# disable user defined callback
delete ${*$self}{_SSL_msg_callback};
}
}
# activate user set callback and/or internal for debugging
if ($ssleay_set_msg_callback and my $ssl = ${*$self}{_SSL_object}) {
$ssleay_set_msg_callback->($ssl,
($DEBUG>=2 || ${*$self}{_SSL_msg_callback})? \&_msg_callback : undef)
}
}
####### I/O subroutines ########################
sub blocking {
my $self = shift;
{ @_ && $auto_retry && $auto_retry->(${*$self}{_SSL_object} || last, @_); }
if (my $biosock = ${*$self}{_SSL_bio_socket}) {
return $biosock->blocking(@_);
} else {
return $self->SUPER::blocking(@_);
}
}
sub _generic_read {
my ($self, $ssl, $justpeek, $read_func, undef, $length, $offset) = @_;
my $buffer = \$_[4];
my ($data,$dobio);
while (1) {
$SSL_ERROR = $! = undef;
($data, my $err) = $read_func->($ssl, $length);
last if defined $data; # read success
$err = $self->_skip_rw_error($ssl, defined($err) ? $err:-1);
if (!$err) {
$dobio = ${*$self}{_SSL_bio_sub} || 0 if !defined $dobio;
if ($dobio) {
# retry after successfully reading from underlying fd on BIO
redo if $dobio->($self, 1, $SSL_ERROR == SSL_WANT_WRITE, \$err);
lib/IO/Socket/SSL.pm view on Meta::CPAN
$self->error("SSL read error"); # generic not recoverable error
return;
}
$$buffer = '' if !defined $$buffer;
$offset ||= 0;
if ($offset>length($$buffer)) {
$$buffer.="\0" x ($offset-length($$buffer)); #mimic behavior of read
}
$length = length($data);
if (!$length && !$justpeek) {
my $status = Net::SSLeay::get_shutdown($ssl);
if ($status & SSL_RECEIVED_SHUTDOWN) {
if ($status & SSL_SENT_SHUTDOWN) {
# fully done, close SSL object - no need to call shutdown again
$self->stop_SSL(SSL_no_shutdown => 1);
} elsif (my $cb = ${*$self}{_SSL_arguments}{SSL_on_peer_shutdown}) {
# Mark as half done but leave further handling to callback
${*$self}{_SSL_read_closed} = 1;
return $cb->($self);
} else {
# Half done, send also close notify
# Don't destruct _SSL_object since code might still rely on
# having access to it. Leave this to explicit stop_SSL or close.
local $SIG{PIPE} = 'IGNORE';
$SSL_ERROR = $! = undef;
Net::SSLeay::shutdown($ssl);
$dobio->($self,0,0,\(my $err)) if $dobio; # flush write
# Use "-1" to mark as automatic closed and thus require action
# before reading/sending plain data
${*$self}{_SSL_read_closed} = ${*$self}{_SSL_write_closed} = -1;
}
}
return 0;
}
substr($$buffer, $offset, length($$buffer), $data);
return $length;
}
# This is only needed in case of a one sided SSL shutdown, i.e. if the fd is
# still tied and has SSL_object, but needs to read or write in plain in one
# direction. Here it will fdopen the SSL fd, thus loosing the class and tie.
sub _rawfd {
my $self = shift;
return ${*$self}{_SSL_bio_socket}
|| (${*$self}{_SSL_rawfd} ||= do { open(my $fh,'+<&=',$self); $fh });
}
# peek to check if a non-SSL read would lead to more data
# This is used with incomplete SSL_shutdown initiated by peer, so that one can
# return EOF but not plain data until stop_SSL is locally called too
sub _handle_read_closed_unack {
my ($self,$rc) = @_;
# reading eof is fine, reading plain data is not
my ($buf,$rv);
my $biosock = ${*$self}{_SSL_bio_socket};
if ($biosock and UNIVERSAL::can($biosock,'peek')) {
# upper IO::Socket::SSL?
$rv = $biosock->peek($buf,1);
} else {
$rv = recv($biosock || $self, $buf,1,MSG_PEEK);
}
return if ! defined $rv;
return 0 if $buf eq '';
$! = EPERM;
return;
}
sub read {
my $self = shift;
my $rc = ${*$self}{_SSL_read_closed} || 0;
if (my $ssl = !$rc && ${*$self}{_SSL_object}) {
return _generic_read($self, $ssl, 0,
$self->blocking ? \&Net::SSLeay::ssl_read_all : \&Net::SSLeay::read,
@_);
}
return _handle_read_closed_unack($self) if $rc<0;
# fall back to plain read if we are not required to use SSL yet
if (my $biosock = ${*$self}{_SSL_bio_socket}) {
return $biosock->read(@_);
} else {
return ($rc ? _rawfd($self) : $self)->SUPER::read(@_);
}
}
# contrary to the behavior of read sysread can read partial data
sub sysread {
my $self = shift;
my $rc = ${*$self}{_SSL_read_closed} || 0;
if (my $ssl = !$rc && ${*$self}{_SSL_object}) {
return _generic_read( $self, $ssl, 0, \&Net::SSLeay::read, @_ );
}
return _handle_read_closed_unack($self) if $rc<0;
# fall back to plain sysread if we are not required to use SSL yet
if (my $biosock = ${*$self}{_SSL_bio_socket}) {
return $biosock->sysread(@_);
} else {
return ($rc ? _rawfd($self) : $self)->SUPER::sysread(@_);
}
}
sub peek {
my $self = shift;
my $rc = ${*$self}{_SSL_read_closed} || 0;
if (my $ssl = !$rc && ${*$self}{_SSL_object}) {
return _generic_read( $self, $ssl, 1, \&Net::SSLeay::peek, @_ );
}
return _handle_read_closed_unack($self) if $rc<0;
# fall back to plain peek if we are not required to use SSL yet
my $fd = ${*$self}{_SSL_bio_socket};
return $fd->peek(@_) if $fd && UNIVERSAL::can($fd,'peek');
$fd ||= $self;
lib/IO/Socket/SSL.pm view on Meta::CPAN
_cleanup_ssl($self,{map { $_ => 1 } @sslkeys}) if @sslkeys;
}
}
}
return $original_socket;
}
sub _cleanup_ssl {
my ($self,$keys,@except) = @_;
$keys ||= \%all_my_keys;
if (@except) {
$keys = { %$keys };
delete @{$keys}{@except};
}
# if we have BIO socket we don't untie on removing _SSL_object but need to
# untie later if we remove _SSL_bio_socket
my $untie;
if (${*$self}{_SSL_bio_socket}) {
$keys = { %$keys } if ! @except;
if (!$keys->{_SSL_bio_socket}) {
# if existing _SSL_bio_socket should not be deleted, then don't
# delete _SSL_fileno either
delete $keys->{_SSL_fileno};
} else {
$untie = 1; # deferred untie on BIO delete
$keys->{_SSL_fileno} = 1; # deferred remove of _SSL_fileno
}
};
if ($keys->{_SSL_object} and my $ssl = ${*$self}{_SSL_object}) {
Net::SSLeay::free($ssl);
delete $SSL_OBJECT{$ssl};
delete $CREATED_IN_THIS_THREAD{$ssl};
$untie = 1;
}
if ($keys->{_SSL_certificate} and
my $cert = delete ${*$self}{_SSL_certificate}) {
Net::SSLeay::X509_free($cert);
}
# don't cleanup _SSL_ctx here, will only be explicitly done when stop_SSL is
# used with SSL_ctx_free
delete @{*$self}{keys %$keys};
${*$self}{_SSL_opened} = 0 if exists ${*$self}{_SSL_opened};
# keep tied in case of kept BIO since we cannot IO on the untied filehandle
untie(*$self) if $untie && !${*$self}{_SSL_bio_socket};
}
sub fileno {
my $self = shift;
my $fn = ${*$self}{'_SSL_fileno'};
return defined($fn) ? $fn : $self->SUPER::fileno();
}
####### IO::Socket::SSL specific functions #######
# get access to SSL handle for use with Net::SSLeay. Use with caution!
sub _get_ssl_object {
my $self = shift;
return ${*$self}{'_SSL_object'} ||
IO::Socket::SSL->_internal_error("Undefined SSL object",9);
}
# get access to SSL handle for use with Net::SSLeay. Use with caution!
sub _get_ctx_object {
my $self = shift;
my $ctx_object = ${*$self}{_SSL_ctx};
return $ctx_object && $ctx_object->{context};
}
# default error for undefined arguments
sub _invalid_object {
return IO::Socket::SSL->_internal_error("Undefined IO::Socket::SSL object",9);
}
sub pending {
my $self = shift;
my $rv = Net::SSLeay::pending(${*$self}{_SSL_object} || return);
if (my $outer = ${*$self}{_SSL_bio_socket}) {
$rv += $outer->pending if UNIVERSAL::can($outer,'pending');
}
return $rv;
}
sub start_SSL {
my ($class,$socket) = (shift,shift);
return $class->_internal_error("Not a socket",9) if ! ref($socket); # glob or object
my $arg_hash = @_ == 1 ? $_[0] : {@_};
my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :();
my $original_class = blessed($socket);
my $usebio = $arg_hash->{SSL_usebio};
my $original_fileno = (UNIVERSAL::can($socket, "fileno"))
? $socket->fileno : CORE::fileno($socket);
return $class->_internal_error("Socket has no fileno",9)
if !$usebio && ! defined $original_fileno;
if ($usebio) {
$socket = _bio_wrap_socket($class,$socket);
$original_class = undef;
} else {
bless $socket, $class;
}
if (!$socket->configure_SSL($arg_hash)) {
bless($socket, $original_class) if $original_class;
return;
}
${*$socket}{'_SSL_fileno'} = $original_fileno;
${*$socket}{'_SSL_ioclass_upgraded'} = $original_class
if $class ne $original_class;
my $start_handshake = $arg_hash->{SSL_startHandshake};
if ( ! defined($start_handshake) || $start_handshake ) {
# if we have no callback force blocking mode
$DEBUG>=2 && DEBUG( "start handshake" );
my $was_blocking = $socket->blocking(1);
my $result = ${*$socket}{'_SSL_arguments'}{SSL_server}
? $socket->accept_SSL(%to)
: $socket->connect_SSL(%to);
$socket->blocking(0) if ! $was_blocking;
if ( $result ) {
return $socket;
} else {
# upgrade to SSL failed, downgrade socket to original class
bless($socket,$original_class) if $original_class;
return;
}
} else {
$DEBUG>=2 && DEBUG( "don't start handshake: $socket" );
return $socket; # just return upgraded socket
lib/IO/Socket/SSL.pm view on Meta::CPAN
$identity =~s{\.+$}{}; # ignore absolutism
# get data from certificate
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
$DEBUG>=3 && DEBUG("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 $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
# no IPv4 or hostname have ':' in it, try IPv6.
$identity =~m{[^\da-fA-F:\.]} and return; # invalid characters in name
$ipn = inet_pton(AF_INET6,$identity) or return; # invalid name
} elsif ( my @ip = $identity =~m{^(\d+)(?:\.(\d+)\.(\d+)\.(\d+)|[\d\.]*)$} ) {
# check for invalid IP/hostname
return if 4 != @ip or 4 != grep { defined($_) && $_<256 } @ip;
$ipn = pack("CCCC",@ip);
} else {
# assume hostname, check for umlauts etc
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and return; # $identity has \\0 byte
$identity = idn_to_ascii($identity)
or return; # conversation to IDNA failed
$identity =~m{[^a-zA-Z0-9_.\-]}
and return; # still junk inside
}
}
# do the actual verification
my $check_name = sub {
my ($name,$identity,$wtyp,$publicsuffix) = @_;
$name =~s{\.+$}{}; # ignore absolutism
$name eq '' and return;
$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 .
# Also, we fall back to full_label matches if the identity is an IDNA
# name, see RFC6125 and the discussion at
# http://bugs.python.org/issue17997#msg194950
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
return if $1 ne '' and substr($identity,0,4) eq 'xn--'; # IDNA
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]+\Q$2\E$}i;
} elsif ( $wtyp =~ m{^(?:full_label|leftmost)$}
and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]+\Q$1\E$}i;
} else {
return lc($identity) eq lc($name);
}
if ( $identity =~ $pattern ) {
$publicsuffix = IO::Socket::SSL::PublicSuffix->default
if ! defined $publicsuffix;
return 1 if $publicsuffix eq '';
my @labels = split( m{\.+}, $identity );
my $tld = $publicsuffix->public_suffix(\@labels,+1);
return 1 if @labels > ( $tld ? 0+@$tld : 1 );
}
return;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
# exact 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},$publicsuffix)
and return 1;
}
}
if ( $scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames ) {
if ( ! $ipn ) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn},$publicsuffix)
and return 1;
} elsif ( $scheme->{ip_in_cn} ) {
if ( $identity eq $commonName ) {
return 1 if
$scheme->{ip_in_cn} == 4 ? length($ipn) == 4 :
$scheme->{ip_in_cn} == 6 ? length($ipn) == 16 :
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_servername {
my $self = shift;
return ${*$self}{_SSL_servername} ||= do {
my $ssl = $self->_get_ssl_object or return;
Net::SSLeay::get_servername($ssl);
};
}
sub get_fingerprint_bin {
my ($self,$algo,$cert,$key_only) = @_;
$cert ||= $self->peer_certificate or return;
return $key_only
? Net::SSLeay::X509_pubkey_digest($cert, $algo2digest->($algo || 'sha256'))
: Net::SSLeay::X509_digest($cert, $algo2digest->($algo || 'sha256'));
}
sub get_fingerprint {
my ($self,$algo,$cert,$key_only) = @_;
$algo ||= 'sha256';
my $fp = get_fingerprint_bin($self,$algo,$cert,$key_only) or return;
return $algo.'$'.($key_only ? 'pub$':'').unpack('H*',$fp);
}
sub get_cipher {
my $ssl = shift()->_get_ssl_object || return;
return Net::SSLeay::get_cipher($ssl);
}
sub get_sslversion {
my $ssl = shift()->_get_ssl_object || return;
my $version = Net::SSLeay::version($ssl) or return;
return
$version == 0x0304 ? 'TLSv1_3' :
$version == 0x0303 ? 'TLSv1_2' :
$version == 0x0302 ? 'TLSv1_1' :
$version == 0x0301 ? 'TLSv1' :
$version == 0x0300 ? 'SSLv3' :
$version == 0x0002 ? 'SSLv2' :
$version == 0xfeff ? 'DTLS1' :
undef;
}
sub get_sslversion_int {
my $ssl = shift()->_get_ssl_object || return;
return Net::SSLeay::version($ssl);
}
sub get_session_reused {
return Net::SSLeay::session_reused(
shift()->_get_ssl_object || return);
}
if ($can_ocsp) {
no warnings 'once';
*ocsp_resolver = sub {
my $self = shift;
my $ssl = $self->_get_ssl_object || return;
my $ctx = ${*$self}{_SSL_ctx};
return IO::Socket::SSL::OCSP_Resolver->new(
$ssl,
$ctx->{ocsp_cache} ||= IO::Socket::SSL::OCSP_Cache->new,
$ctx->{ocsp_mode} & SSL_OCSP_FAIL_HARD,
@_ ? \@_ :
$ctx->{ocsp_mode} & SSL_OCSP_FULL_CHAIN ? [ $self->peer_certificates ]:
[ $self->peer_certificate ]
);
};
}
sub errstr {
my $self = shift;
my $oe = ref($self) && ${*$self}{_SSL_last_err};
return $oe ? $oe->[0] : $SSL_ERROR || '';
}
sub fatal_ssl_error {
my $self = shift;
my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'};
$@ = $self->errstr;
my $saved_error = $SSL_ERROR;
if (defined $error_trap and ref($error_trap) eq 'CODE') {
$error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error());
} elsif ( ${*$self}{'_SSL_ioclass_upgraded'}
|| ${*$self}{_SSL_arguments}{SSL_keepSocketOnError}) {
# downgrade only
$DEBUG>=3 && DEBUG('downgrading SSL only, not closing socket' );
$self->stop_SSL;
} else {
# kill socket
$self->close
}
$SSL_ERROR = $saved_error if $saved_error;
return;
}
sub get_ssleay_error {
#Net::SSLeay will print out the errors itself unless we explicitly
#undefine $Net::SSLeay::trace while running print_errs()
local $Net::SSLeay::trace;
return Net::SSLeay::print_errs('SSL error: ') || '';
}
# internal errors, e.g. unsupported features, hostname check failed etc
# _SSL_last_err contains severity so that on error chains we can decide if one
# error should replace the previous one or if this is just a less specific
# follow-up error, e.g. configuration failed because certificate failed because
# hostname check went wrong:
# 0 - fallback errors
# 4 - errors bubbled up from OpenSSL (sub error, r/w error)
# 5 - hostname or OCSP verification failed
# 9 - fatal problems, e.g. missing feature, no fileno...
# _SSL_last_err and SSL_ERROR are only replaced if the error has a higher
# severity than the previous one
sub _internal_error {
my ($self, $error, $severity) = @_;
$error = dualvar( -1, $error );
$self = $CURRENT_SSL_OBJECT if !ref($self) && $CURRENT_SSL_OBJECT;
if (ref($self)) {
my $oe = ${*$self}{_SSL_last_err};
if (!$oe || $oe->[1] <= $severity) {
lib/IO/Socket/SSL.pm view on Meta::CPAN
$SSL_ERROR = $error;
$DEBUG && DEBUG("global error: $error");
}
return;
}
# OpenSSL errors
sub error {
my ($self, $error) = @_;
my @err;
while ( my $err = Net::SSLeay::ERR_get_error()) {
push @err, Net::SSLeay::ERR_error_string($err);
$DEBUG>=2 && DEBUG( $error."\n".$self->get_ssleay_error());
}
$error .= ' '.join(' ',@err) if @err;
return $self->_internal_error($error,4) if $error;
return;
}
sub _errstack {
my @err;
while (my $err = Net::SSLeay::ERR_get_error()) {
push @err, Net::SSLeay::ERR_error_string($err);
}
return @err;
}
sub can_client_sni { return $can_client_sni }
sub can_server_sni { return $can_server_sni }
sub can_multi_cert { return $can_multi_cert }
sub can_npn { return $can_npn }
sub can_alpn { return $can_alpn }
sub can_ecdh { return $can_ecdh }
sub can_ipv6 { return CAN_IPV6 }
sub can_ocsp { return $can_ocsp }
sub can_ticket_keycb { return $can_tckt_keycb }
sub can_pha { return $can_pha }
sub can_partial_chain { return $check_partial_chain && 1 }
sub can_ciphersuites { return $can_ciphersuites }
sub can_psk {
my %can;
$can{client}=1 if $can_client_psk;
$can{server}=1 if $can_server_psk;
return %can ? \%can : undef
}
sub can_nested_ssl { return { SSL_usebio => 1 } }
sub DESTROY {
my $self = shift or return;
if (my $ssl = ${*$self}{_SSL_object}) {
delete $SSL_OBJECT{$ssl};
if (!$use_threads or delete $CREATED_IN_THIS_THREAD{$ssl}) {
$self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1);
}
}
delete @{*$self}{keys %all_my_keys};
}
#######Extra Backwards Compatibility Functionality#######
sub socket_to_SSL { IO::Socket::SSL->start_SSL(@_); }
sub socketToSSL { IO::Socket::SSL->start_SSL(@_); }
sub kill_socket { shift->close }
sub issuer_name { return(shift()->peer_certificate("issuer")) }
sub subject_name { return(shift()->peer_certificate("subject")) }
sub get_peer_certificate { return shift() }
sub context_init {
return($GLOBAL_SSL_ARGS = (ref($_[0]) eq 'HASH') ? $_[0] : {@_});
}
sub set_default_context {
$GLOBAL_SSL_ARGS->{'SSL_reuse_ctx'} = shift;
}
sub set_default_session_cache {
$GLOBAL_SSL_ARGS->{SSL_session_cache} = shift;
}
{
my $set_defaults = sub {
my $args = shift;
for(my $i=0;$i<@$args;$i+=2 ) {
my ($k,$v) = @{$args}[$i,$i+1];
if ( $k =~m{^SSL_} ) {
$_->{$k} = $v for(@_);
} elsif ( $k =~m{^(name|scheme)$} ) {
$_->{"SSL_verifycn_$k"} = $v for (@_);
} elsif ( $k =~m{^(callback|mode)$} ) {
$_->{"SSL_verify_$k"} = $v for(@_);
} else {
$_->{"SSL_$k"} = $v for(@_);
}
}
};
sub set_defaults {
my %args = @_;
$set_defaults->(\@_,
$GLOBAL_SSL_ARGS,
$GLOBAL_SSL_CLIENT_ARGS,
$GLOBAL_SSL_SERVER_ARGS
);
}
{ # deprecated API
no warnings;
*set_ctx_defaults = \&set_defaults;
}
sub set_client_defaults {
my %args = @_;
$set_defaults->(\@_, $GLOBAL_SSL_CLIENT_ARGS );
}
sub set_server_defaults {
my %args = @_;
$set_defaults->(\@_, $GLOBAL_SSL_SERVER_ARGS );
}
}
sub set_args_filter_hack {
my $sub = shift;
if ( ref $sub ) {
$FILTER_SSL_ARGS = $sub;
} elsif ( $sub eq 'use_defaults' ) {
# override args with defaults
$FILTER_SSL_ARGS = sub {
my ($is_server,$args) = @_;
%$args = ( %$args, $is_server
? ( %DEFAULT_SSL_SERVER_ARGS, %$GLOBAL_SSL_SERVER_ARGS )
: ( %DEFAULT_SSL_CLIENT_ARGS, %$GLOBAL_SSL_CLIENT_ARGS )
);
}
}
}
sub next_proto_negotiated {
my $self = shift;
return $self->_internal_error("NPN not supported in Net::SSLeay",9) if ! $can_npn;
my $ssl = $self->_get_ssl_object || return;
return Net::SSLeay::P_next_proto_negotiated($ssl);
}
sub alpn_selected {
my $self = shift;
return $self->_internal_error("ALPN not supported in Net::SSLeay",9) if ! $can_alpn;
my $ssl = $self->_get_ssl_object || return;
return Net::SSLeay::P_alpn_selected($ssl);
}
sub opened {
my $self = shift;
return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'};
}
sub opening {
my $self = shift;
return ${*$self}{'_SSL_opening'};
}
sub want_read { shift->errstr == SSL_WANT_READ }
sub want_write { shift->errstr == SSL_WANT_WRITE }
#Redundant IO::Handle functionality
sub getline { return(scalar shift->readline()) }
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") }
sub stat { croak("Use of stat() not allowed with SSL" ) }
sub setbuf { croak("Use of setbuf() not allowed with SSL" ) }
sub setvbuf { croak("Use of setvbuf() not allowed with SSL" ) }
sub fdopen { croak("Use of fdopen() not allowed with SSL" ) }
#Unsupported socket functionality
sub ungetc { croak("Use of ungetc() not implemented in IO::Socket::SSL") }
sub send { croak("Use of send() not implemented in IO::Socket::SSL; use print/printf/syswrite instead") }
sub recv { croak("Use of recv() not implemented in IO::Socket::SSL; use read/sysread instead") }
package IO::Socket::SSL::SSL_HANDLE;
use strict;
use Errno 'EBADF';
*weaken = *IO::Socket::SSL::weaken;
sub TIEHANDLE {
my ($class, $handle) = @_;
weaken($handle);
bless \$handle, $class;
}
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 FILENO { ${shift()}->fileno(@_) }
sub TELL { $! = EBADF; return -1 }
sub BINMODE { return 0 } # not perfect, but better than not implementing the method
sub CLOSE { #<---- Do not change this function!
my $ssl = ${$_[0]};
local @_;
$ssl->close();
}
package IO::Socket::SSL::SSL_Context;
use Carp;
use strict;
my %CTX_CREATED_IN_THIS_THREAD;
*DEBUG = *IO::Socket::SSL::DEBUG;
*_errstack = \&IO::Socket::SSL::_errstack;
use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1;
use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2;
use constant FILETYPE_PEM => Net::SSLeay::FILETYPE_PEM();
use constant FILETYPE_ASN1 => Net::SSLeay::FILETYPE_ASN1();
my $DEFAULT_SSL_OP = &Net::SSLeay::OP_ALL
| &Net::SSLeay::OP_SINGLE_DH_USE
| ($can_ecdh ? &Net::SSLeay::OP_SINGLE_ECDH_USE : 0);
# get access to SSL handle for use with Net::SSLeay. Use with caution!
sub _get_ctx_object { shift->{context} }
# Note that the final object will actually be a reference to the scalar
# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that
# it can be blessed.
sub new {
my $class = shift;
#DEBUG( "$class @_" );
my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
my $is_server = $arg_hash->{SSL_server};
my %defaults = $is_server
? (%DEFAULT_SSL_SERVER_ARGS, %$GLOBAL_SSL_ARGS, %$GLOBAL_SSL_SERVER_ARGS)
: (%DEFAULT_SSL_CLIENT_ARGS, %$GLOBAL_SSL_ARGS, %$GLOBAL_SSL_CLIENT_ARGS);
if ( $defaults{SSL_reuse_ctx} ) {
# ignore default context if there are args to override it
delete $defaults{SSL_reuse_ctx}
if grep { m{^SSL_(?!verifycn_name|hostname)$} } keys %$arg_hash;
}
%$arg_hash = ( %defaults, %$arg_hash ) if %defaults;
if (my $ctx = $arg_hash->{'SSL_reuse_ctx'}) {
if ($ctx->isa('IO::Socket::SSL::SSL_Context')) {
return $ctx if $ctx->{context};
} elsif (eval { $ctx = ${*$ctx}{_SSL_ctx} }) {
# reuse context from existing SSL object
return $ctx;
}
die "invalid context to reuse: $ctx";
}
# common problem forgetting to set SSL_use_cert
# if client cert is given by user but SSL_use_cert is undef, assume that it
# should be set
if ( ! $is_server && ! defined $arg_hash->{SSL_use_cert}
&& ( grep { $arg_hash->{$_} } qw(SSL_cert SSL_cert_file))
&& ( grep { $arg_hash->{$_} } qw(SSL_key SSL_key_file)) ) {
$arg_hash->{SSL_use_cert} = 1
}
# if any of SSL_ca* is set don't set the other SSL_ca*
# from defaults
if ( $arg_hash->{SSL_ca} ) {
$arg_hash->{SSL_ca_file} ||= undef
$arg_hash->{SSL_ca_path} ||= undef
} elsif ( $arg_hash->{SSL_ca_path} ) {
$arg_hash->{SSL_ca_file} ||= undef
} elsif ( $arg_hash->{SSL_ca_file} ) {
$arg_hash->{SSL_ca_path} ||= undef;
}
# add library defaults
$arg_hash->{SSL_use_cert} = $is_server if ! defined $arg_hash->{SSL_use_cert};
# Avoid passing undef arguments to Net::SSLeay
defined($arg_hash->{$_}) or delete($arg_hash->{$_}) for(keys %$arg_hash);
# check SSL CA, cert etc arguments
# some apps set keys '' to signal that it is not set, replace with undef
for (qw( SSL_cert SSL_cert_file SSL_key SSL_key_file
SSL_ca SSL_ca_file SSL_ca_path
SSL_fingerprint )) {
$arg_hash->{$_} = undef if defined $arg_hash->{$_}
and $arg_hash->{$_} eq '';
}
for(qw(SSL_cert_file SSL_key_file)) {
defined( my $file = $arg_hash->{$_} ) or next;
for my $f (ref($file) eq 'HASH' ? values(%$file):$file ) {
die "$_ $f can't be used: $!" if ! open(my $fh,'<',$f)
}
}
my $verify_mode = $arg_hash->{SSL_verify_mode} || 0;
if ( $verify_mode != $Net_SSLeay_VERIFY_NONE) {
for (qw(SSL_ca_file SSL_ca_path)) {
$CHECK_SSL_PATH->($_ => $arg_hash->{$_} || next);
}
} elsif ( $verify_mode ne '0' ) {
# some users use the string 'SSL_VERIFY_PEER' instead of the constant
die "SSL_verify_mode must be a number and not a string";
}
my $self = bless {},$class;
my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme};
my $vcn_publicsuffix = delete $arg_hash->{SSL_verifycn_publicsuffix};
if ( ! $is_server and $verify_mode & 0x01 and
! $vcn_scheme || $vcn_scheme ne 'none' ) {
# gets updated during configure_SSL
my $verify_name;
$self->{verify_name_ref} = \$verify_name;
my $vcb = $arg_hash->{SSL_verify_callback};
$arg_hash->{SSL_verify_callback} = sub {
my ($ok,$ctx_store,$certname,$error,$cert,$depth) = @_;
$ok = $vcb->($ok,$ctx_store,$certname,$error,$cert,$depth) if $vcb;
$ok or return 0;
return $ok if $depth != 0;
my $host = $verify_name || ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown';
if ( ! $host ) {
if ( $vcn_scheme ) {
IO::Socket::SSL->_internal_error(
"Cannot determine peer hostname for verification",8);
return 0;
}
warn "Cannot determine hostname of peer for verification. ".
"Disabling default hostname verification for now. ".
"Please specify hostname with SSL_verifycn_name and better set SSL_verifycn_scheme too.\n";
return $ok;
}
# verify name
my $rv = IO::Socket::SSL::verify_hostname_of_cert(
$host,$cert,$vcn_scheme,$vcn_publicsuffix );
if ( ! $rv ) {
IO::Socket::SSL->_internal_error(
"hostname verification failed",5);
}
return $rv;
};
}
if ($is_server) {
if ($arg_hash->{SSL_ticket_keycb} && !$can_tckt_keycb) {
warn "Ticket Key Callback is not supported - ignoring option SSL_ticket_keycb\n";
delete $arg_hash->{SSL_ticket_keycb};
}
}
my $ssl_op = $DEFAULT_SSL_OP;
my $ver;
for (split(/\s*:\s*/,$arg_hash->{SSL_version})) {
m{^(!?)(?:(SSL(?:v2|v3|v23|v2/3))|(TLSv1(?:_?[123])?))$}i
or croak("invalid SSL_version specified");
my $not = $1;
( my $v = lc($2||$3) ) =~s{^(...)}{\U$1};
if ( $not ) {
$ssl_op |= $SSL_OP_NO{$v};
} else {
croak("cannot set multiple SSL protocols in SSL_version")
if $ver && $v ne $ver;
$ver = $v;
$ver =~s{/}{}; # interpret SSLv2/3 as SSLv23
$ver =~s{(TLSv1)(\d)}{$1\_$2}; # TLSv1_1
}
}
my $ctx_new_sub =
$ver eq 'TLSv1_3' ? $CTX_tlsv1_3_new :
UNIVERSAL::can( 'Net::SSLeay',
$ver eq 'SSLv2' ? 'CTX_v2_new' :
$ver eq 'SSLv3' ? 'CTX_v3_new' :
$ver eq 'TLSv1' ? 'CTX_tlsv1_new' :
$ver eq 'TLSv1_1' ? 'CTX_tlsv1_1_new' :
$ver eq 'TLSv1_2' ? 'CTX_tlsv1_2_new' :
'CTX_new'
)
or return IO::Socket::SSL->_internal_error("SSL Version $ver not supported",9);
# For SNI in server mode we need a separate context for each certificate.
my %ctx;
if ($is_server) {
my %sni;
for my $opt (qw(SSL_key SSL_key_file SSL_cert SSL_cert_file)) {
my $val = $arg_hash->{$opt} or next;
if ( ref($val) eq 'HASH' ) {
while ( my ($host,$v) = each %$val ) {
$sni{lc($host)}{$opt} = $v;
}
}
}
while (my ($host,$v) = each %sni) {
$ctx{$host} = $host =~m{%} ? $v : { %$arg_hash, %$v };
}
}
$ctx{''} = $arg_hash if ! %ctx;
for my $host (sort keys %ctx) {
my $arg_hash = delete $ctx{$host};
my $ctx;
if ($host =~m{^([^%]*)%}) {
$ctx = $ctx{$1} or return IO::Socket::SSL->error(
"SSL Context init for $host failed - no config for $1");
if (my @k = grep { !m{^SSL_(?:cert|key)(?:_file)?$} }
keys %$arg_hash) {
return IO::Socket::SSL->error(
"invalid keys @k in configuration '$host' of additional certs");
}
$can_multi_cert or return IO::Socket::SSL->error(
"no support for both RSA and ECC certificate in same context");
$host = $1;
goto just_configure_certs;
}
$ctx = $ctx_new_sub->() or return
IO::Socket::SSL->error("SSL Context init failed");
$CTX_CREATED_IN_THIS_THREAD{$ctx} = 1 if $use_threads;
$ctx{$host} = $ctx; # replace value in %ctx with real context
# SSL_OP_CIPHER_SERVER_PREFERENCE
$ssl_op |= 0x00400000 if $arg_hash->{SSL_honor_cipher_order};
if ($ver eq 'SSLv23' && !($ssl_op & $SSL_OP_NO{SSLv3})) {
# At least LibreSSL disables SSLv3 by default in SSL_CTX_new.
# If we really want SSL3.0 we need to explicitly allow it with
# SSL_CTX_clear_options.
Net::SSLeay::CTX_clear_options($ctx,$SSL_OP_NO{SSLv3});
}
Net::SSLeay::CTX_set_options($ctx,$ssl_op);
# enable X509_V_FLAG_PARTIAL_CHAIN if possible (OpenSSL 1.1.0+)
$check_partial_chain && $check_partial_chain->($ctx);
# if we don't set session_id_context if client certificate is expected
# client session caching will fail
# if user does not provide explicit id just use the stringification
# of the context
if($arg_hash->{SSL_server} and my $id =
$arg_hash->{SSL_session_id_context} ||
( $arg_hash->{SSL_verify_mode} & 0x01 ) && "$ctx" ) {
Net::SSLeay::CTX_set_session_id_context($ctx,$id,length($id));
}
# SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER makes syswrite return if at least one
# 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 |
($arg_hash->{SSL_mode_release_buffers} ? $ssl_mode_release_buffers : 0)
);
if ( my $proto_list = $arg_hash->{SSL_npn_protocols} ) {
return IO::Socket::SSL->_internal_error("NPN not supported in Net::SSLeay",9)
if ! $can_npn;
if($arg_hash->{SSL_server}) {
# on server side SSL_npn_protocols means a list of advertised protocols
Net::SSLeay::CTX_set_next_protos_advertised_cb($ctx, $proto_list);
} else {
# on client side SSL_npn_protocols means a list of preferred protocols
# negotiation algorithm used is "as-openssl-implements-it"
Net::SSLeay::CTX_set_next_proto_select_cb($ctx, $proto_list);
}
}
if ( my $proto_list = $arg_hash->{SSL_alpn_protocols} ) {
return IO::Socket::SSL->_internal_error("ALPN not supported in Net::SSLeay",9)
if ! $can_alpn;
if($arg_hash->{SSL_server}) {
Net::SSLeay::CTX_set_alpn_select_cb($ctx, $proto_list);
} else {
Net::SSLeay::CTX_set_alpn_protos($ctx, $proto_list);
}
}
if ($arg_hash->{SSL_ticket_keycb}) {
my $cb = $arg_hash->{SSL_ticket_keycb};
($cb,my $arg) = ref($cb) eq 'CODE' ? ($cb):@$cb;
Net::SSLeay::CTX_set_tlsext_ticket_getkey_cb($ctx,$cb,$arg);
}
if ($arg_hash->{SSL_psk}) {
my $psk = $arg_hash->{SSL_psk};
if ($arg_hash->{SSL_server}) {
$can_server_psk or return IO::Socket::SSL->_internal_error(
"no support for server side PSK");
Net::SSLeay::CTX_set_psk_server_callback($ctx, sub {
my ($ssl,$identity,$psklen) = @_;
if (ref($psk) eq 'HASH') {
return $psk->{$identity} || $psk->{''} ||
IO::Socket::SSL->_internal_error(
"no PSK for given identity '$identity' and no default");
} else {
return $psk;
}
});
} else {
$can_client_psk or return IO::Socket::SSL->_internal_error(
"no support for client side PSK");
Net::SSLeay::CTX_set_psk_client_callback($ctx, sub {
my $hint = shift;
my ($i,$p);
if (ref($psk) eq 'HASH') {
$hint = '' if ! defined $hint;
$p = $psk->{$hint} or return IO::Socket::SSL->_internal_error(
"no PSK for given hint '$hint'");
$i = $hint;
} elsif (ref($psk)) { # [identity,psk]
($i,$p) = @$psk;
} else {
($i,$p) = ('io_socket_ssl', $psk)
}
# for some reason this expects the PSK in hex whereas the server
# side function expects the PSK in binary
return ($i, unpack("H*",$p));
});
}
}
# Try to apply SSL_ca even if SSL_verify_mode is 0, so that they can be
# used to verify OCSP responses.
# If applying fails complain only if verify_mode != VERIFY_NONE.
if ( $arg_hash->{SSL_ca}
|| defined $arg_hash->{SSL_ca_file}
|| defined $arg_hash->{SSL_ca_path} ) {
my $file = $arg_hash->{SSL_ca_file};
$file = undef if ref($file) eq 'SCALAR' && ! $$file;
my $dir = $arg_hash->{SSL_ca_path};
$dir = undef if ref($dir) eq 'SCALAR' && ! $$dir;
if ( $arg_hash->{SSL_ca} ) {
my $store = Net::SSLeay::CTX_get_cert_store($ctx);
for (@{$arg_hash->{SSL_ca}}) {
Net::SSLeay::X509_STORE_add_cert($store,$_) or
return IO::Socket::SSL->error(
"Failed to add certificate to CA store");
}
}
$dir = join($OPENSSL_LIST_SEPARATOR,@$dir) if ref($dir);
if ( $file || $dir and ! Net::SSLeay::CTX_load_verify_locations(
$ctx, $file || '', $dir || '')) {
return IO::Socket::SSL->error(
"Invalid certificate authority locations")
if $verify_mode != $Net_SSLeay_VERIFY_NONE;
}
} elsif ( my %ca = IO::Socket::SSL::default_ca()) {
# no CA path given, continue with system defaults
my $dir = $ca{SSL_ca_path};
$dir = join($OPENSSL_LIST_SEPARATOR,@$dir) if ref($dir);
if (! Net::SSLeay::CTX_load_verify_locations( $ctx,
$ca{SSL_ca_file} || '',$dir || '')
&& $verify_mode != $Net_SSLeay_VERIFY_NONE) {
return IO::Socket::SSL->error(
"Invalid default certificate authority locations")
}
}
if ($is_server && ($verify_mode & $Net_SSLeay_VERIFY_PEER)) {
if ($arg_hash->{SSL_client_ca}) {
for (@{$arg_hash->{SSL_client_ca}}) {
return IO::Socket::SSL->error(
"Failed to add certificate to client CA list") if
! Net::SSLeay::CTX_add_client_CA($ctx,$_);
}
}
if ($arg_hash->{SSL_client_ca_file}) {
my $list = Net::SSLeay::load_client_CA_file(
$arg_hash->{SSL_client_ca_file}) or
return IO::Socket::SSL->error(
"Failed to load certificate to client CA list");
Net::SSLeay::CTX_set_client_CA_list($ctx,$list);
}
}
my $X509_STORE_flags = $DEFAULT_X509_STORE_flags;
if ($arg_hash->{'SSL_check_crl'}) {
$X509_STORE_flags |= Net::SSLeay::X509_V_FLAG_CRL_CHECK();
if ($arg_hash->{'SSL_crl_file'}) {
my $bio = Net::SSLeay::BIO_new_file($arg_hash->{'SSL_crl_file'}, 'r');
my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio);
Net::SSLeay::BIO_free($bio);
if ( $crl ) {
Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ctx), $crl);
Net::SSLeay::X509_CRL_free($crl);
} else {
return IO::Socket::SSL->error("Invalid certificate revocation list");
}
}
}
Net::SSLeay::X509_STORE_set_flags(
Net::SSLeay::CTX_get_cert_store($ctx),
$X509_STORE_flags
) if $X509_STORE_flags;
Net::SSLeay::CTX_set_default_passwd_cb($ctx,$arg_hash->{SSL_passwd_cb})
if $arg_hash->{SSL_passwd_cb};
just_configure_certs:
my ($havekey,$havecert);
if ( my $x509 = $arg_hash->{SSL_cert} ) {
# binary, e.g. X509*
# we have either a single certificate or a list with
# a chain of certificates
my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509);
my $cert = shift @x509;
Net::SSLeay::CTX_use_certificate( $ctx,$cert )
|| return IO::Socket::SSL->error("Failed to use Certificate");
foreach my $ca (@x509) {
Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca )
|| return IO::Socket::SSL->error("Failed to use Certificate");
}
$havecert = 'OBJ';
} elsif ( my $f = $arg_hash->{SSL_cert_file} ) {
# try to load chain from PEM or certificate from ASN1
my @err;
if (Net::SSLeay::CTX_use_certificate_chain_file($ctx,$f)) {
$havecert = 'PEM';
} elsif (do {
push @err, [ PEM => _errstack() ];
Net::SSLeay::CTX_use_certificate_file($ctx,$f,FILETYPE_ASN1)
}) {
$havecert = 'DER';
} else {
push @err, [ DER => _errstack() ];
# try to load certificate, key and chain from PKCS12 file
my ($key,$cert,@chain) = Net::SSLeay::P_PKCS12_load_file($f,1);
if (!$cert and $arg_hash->{SSL_passwd_cb}
and defined( my $pw = $arg_hash->{SSL_passwd_cb}->(0))) {
($key,$cert,@chain) = Net::SSLeay::P_PKCS12_load_file($f,1,$pw);
}
PKCS12: while ($cert) {
Net::SSLeay::CTX_use_certificate($ctx,$cert) or last;
# Net::SSLeay::P_PKCS12_load_file is implemented using
# OpenSSL PKCS12_parse which according to the source code
# returns the chain with the last CA certificate first (i.e.
# reverse order as in the PKCS12 file). This is not
# documented but given the age of this function we'll assume
# that this will stay this way in the future.
while (my $ca = pop @chain) {
Net::SSLeay::CTX_add_extra_chain_cert($ctx,$ca)
or last PKCS12;
}
last if $key && ! Net::SSLeay::CTX_use_PrivateKey($ctx,$key);
$havecert = 'PKCS12';
last;
}
$havekey = 'PKCS12' if $key;
Net::SSLeay::X509_free($cert) if $cert;
Net::SSLeay::EVP_PKEY_free($key) if $key;
# don't free @chain, because CTX_add_extra_chain_cert
# did not duplicate the certificates
}
if (!$havecert) {
push @err, [ PKCS12 => _errstack() ];
my $err = "Failed to load certificate from file $f:";
for(@err) {
my ($type,@e) = @$_;
$err .= " [format:$type] @e **" if @e;
}
return IO::Socket::SSL->error($err);
}
}
if (!$havecert || $havekey) {
# skip SSL_key_*
} elsif ( my $pkey = $arg_hash->{SSL_key} ) {
# binary, e.g. EVP_PKEY*
Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey)
|| return IO::Socket::SSL->error("Failed to use Private Key");
$havekey = 'MEM';
} elsif ( my $f = $arg_hash->{SSL_key_file}
|| (($havecert eq 'PEM') ? $arg_hash->{SSL_cert_file}:undef) ) {
for my $ft ( FILETYPE_PEM, FILETYPE_ASN1 ) {
if (Net::SSLeay::CTX_use_PrivateKey_file($ctx,$f,$ft)) {
$havekey = ($ft == FILETYPE_PEM) ? 'PEM':'DER';
last;
}
}
$havekey or return IO::Socket::SSL->error(
"Failed to load key from file (no PEM or DER)");
}
Net::SSLeay::CTX_set_post_handshake_auth($ctx,1)
if (!$is_server && $can_pha && $havecert && $havekey);
}
if ($arg_hash->{SSL_server}) {
if ( my $f = $arg_hash->{SSL_dh_file} ) {
my $bio = Net::SSLeay::BIO_new_file( $f,'r' )
|| return IO::Socket::SSL->error( "Failed to open DH file $f" );
my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio);
Net::SSLeay::BIO_free($bio);
$dh || return IO::Socket::SSL->error( "Failed to read PEM for DH from $f - wrong format?" );
my $rv;
for (values (%ctx)) {
$rv = Net::SSLeay::CTX_set_tmp_dh( $_,$dh ) or last;
}
Net::SSLeay::DH_free( $dh );
$rv || return IO::Socket::SSL->error( "Failed to set DH from $f" );
} elsif ( my $dh = $arg_hash->{SSL_dh} ) {
# binary, e.g. DH*
for( values %ctx ) {
Net::SSLeay::CTX_set_tmp_dh( $_,$dh ) || return
IO::Socket::SSL->error( "Failed to set DH from SSL_dh" );
}
}
}
if ( my $curve = $arg_hash->{SSL_ecdh_curve} ) {
return IO::Socket::SSL->_internal_error(
"ECDH curve needs Net::SSLeay>=1.56 and OpenSSL>=1.0",9)
if ! $can_ecdh;
for(values %ctx) {
if ($arg_hash->{SSL_server} and $curve eq 'auto') {
if ($can_ecdh eq 'can_auto') {
Net::SSLeay::CTX_set_ecdh_auto($_,1) or
return IO::Socket::SSL->error(
"failed to set ECDH curve context");
} elsif ($can_ecdh eq 'auto') {
# automatically enabled anyway
} else {
return IO::Socket::SSL->error(
"SSL_CTX_set_ecdh_auto not implemented");
}
} elsif ($set_groups_list) {
$set_groups_list->($_,$curve) or return IO::Socket::SSL->error(
"failed to set ECDH groups/curves on context");
# needed for OpenSSL 1.0.2 if ($can_ecdh eq 'can_auto') {
Net::SSLeay::CTX_set_ecdh_auto($_,1) if $can_ecdh eq 'can_auto';
} elsif ($curve =~m{:}) {
return IO::Socket::SSL->error(
"SSL_CTX_groups_list or SSL_CTX_curves_list not implemented");
} elsif ($arg_hash->{SSL_server}) {
if ( $curve !~ /^\d+$/ ) {
# name of curve, find NID
$curve = Net::SSLeay::OBJ_txt2nid($curve)
|| return IO::Socket::SSL->error(
"cannot find NID for curve name '$curve'");
}
my $ecdh = Net::SSLeay::EC_KEY_new_by_curve_name($curve) or
return IO::Socket::SSL->error(
"cannot create curve for NID $curve");
for( values %ctx ) {
Net::SSLeay::CTX_set_tmp_ecdh($_,$ecdh) or
return IO::Socket::SSL->error(
"failed to set ECDH curve context");
}
Net::SSLeay::EC_KEY_free($ecdh);
}
}
}
my $verify_cb = $arg_hash->{SSL_verify_callback};
my @accept_fp;
if ( my $fp = $arg_hash->{SSL_fingerprint} ) {
for( ref($fp) ? @$fp : $fp) {
my ($algo,$pubkey,$digest) = m{^(?:([\w-]+)\$)?(pub\$)?([a-f\d:]+)$}i
or return IO::Socket::SSL->_internal_error("invalid fingerprint '$_'",9);
( $digest = lc($digest) ) =~s{:}{}g;
$algo ||=
length($digest) == 32 ? 'md5' :
length($digest) == 40 ? 'sha1' :
length($digest) == 64 ? 'sha256' :
return IO::Socket::SSL->_internal_error(
"cannot detect hash algorithm from fingerprint '$_'",9);
$algo = lc($algo);
push @accept_fp,[ $algo, $pubkey || '', pack('H*',$digest) ]
}
}
my $verify_fingerprint = @accept_fp && do {
my $fail;
my $force = $arg_hash->{SSL_force_fingerprint};
sub {
my ($ok,$cert,$depth) = @_;
$fail = 1 if ! $ok;
return 1 if $depth>0; # to let us continue with verification
# Check fingerprint only from top certificate.
my %fp;
for(@accept_fp) {
my $fp = $fp{$_->[0],$_->[1]} ||= $_->[1]
? Net::SSLeay::X509_pubkey_digest($cert,$algo2digest->($_->[0]))
: Net::SSLeay::X509_digest($cert,$algo2digest->($_->[0]));
next if $fp ne $_->[2];
return 1;
}
return $force ? 0 : ! $fail;
}
};
my $verify_callback = ( $verify_cb || @accept_fp ) && sub {
my ($ok, $ctx_store) = @_;
my ($certname,$cert,$error,$depth);
if ($ctx_store) {
$cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store);
$error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store);
$depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store);
$certname =
Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)).
Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert));
$error &&= Net::SSLeay::ERR_error_string($error);
}
$DEBUG>=3 && DEBUG( "ok=$ok [$depth] $certname" );
$ok = $verify_cb->($ok,$ctx_store,$certname,$error,$cert,$depth) if $verify_cb;
$ok = $verify_fingerprint->($ok,$cert,$depth) if $verify_fingerprint && $cert;
return $ok;
};
if ( $^O eq 'darwin' ) {
# explicitly set error code to disable use of apples TEA patch
# https://hynek.me/articles/apple-openssl-verification-surprises/
my $vcb = $verify_callback;
$verify_callback = sub {
my $rv = $vcb ? &$vcb : $_[0];
if ( $rv != 1 ) {
# 50 - X509_V_ERR_APPLICATION_VERIFICATION: application verification failure
Net::SSLeay::X509_STORE_CTX_set_error($_[1], 50);
}
return $rv;
};
}
Net::SSLeay::CTX_set_verify($_, $verify_mode, $verify_callback)
for (values %ctx);
my $staple_callback = $arg_hash->{SSL_ocsp_staple_callback};
if ( !$is_server && $can_ocsp_staple && ! $verify_fingerprint) {
$self->{ocsp_cache} = $arg_hash->{SSL_ocsp_cache};
my $status_cb = sub {
my ($ssl,$resp) = @_;
my $iossl = $SSL_OBJECT{$ssl} or
die "no IO::Socket::SSL object found for SSL $ssl";
$iossl->[1] and do {
# we must return with 1 or it will be called again
# and because we have no SSL object we must make the error global
Carp::cluck($IO::Socket::SSL::SSL_ERROR
= "OCSP callback on server side");
return 1;
};
$iossl = $iossl->[0];
# if we have a callback use this
# callback must not free or copy $resp !!
if ( $staple_callback ) {
$staple_callback->($iossl,$resp);
return 1;
}
# default callback does verification
if ( ! $resp ) {
$DEBUG>=3 && DEBUG("did not get stapled OCSP response");
return 1;
}
$DEBUG>=3 && DEBUG("got stapled OCSP response");
my $status = Net::SSLeay::OCSP_response_status($resp);
if ($status != Net::SSLeay::OCSP_RESPONSE_STATUS_SUCCESSFUL()) {
$DEBUG>=3 && DEBUG("bad status of stapled OCSP response: ".
Net::SSLeay::OCSP_response_status_str($status));
return 1;
}
if (!eval { Net::SSLeay::OCSP_response_verify($ssl,$resp) }) {
$DEBUG>=3 && DEBUG("verify of stapled OCSP response failed");
return 1;
}
my (@results,$hard_error);
my @chain = $iossl->peer_certificates;
for my $cert (@chain) {
my $certid = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) };
if (!$certid) {
$DEBUG>=3 && DEBUG("cannot create OCSP_CERTID: $@");
push @results,[-1,$@];
last;
}
($status) = Net::SSLeay::OCSP_response_results($resp,$certid);
if ($status && $status->[2]) {
my $cache = ${*$iossl}{_SSL_ctx}{ocsp_cache};
if (!$status->[1]) {
push @results,[1,$status->[2]{nextUpdate}];
$cache && $cache->put($certid,$status->[2]);
} elsif ( $status->[2]{statusType} ==
Net::SSLeay::V_OCSP_CERTSTATUS_GOOD()) {
push @results,[1,$status->[2]{nextUpdate}];
$cache && $cache->put($certid,{
%{$status->[2]},
expire => time()+120,
soft_error => $status->[1],
});
} else {
push @results,($hard_error = [0,$status->[1]]);
$cache && $cache->put($certid,{
%{$status->[2]},
hard_error => $status->[1],
});
}
}
}
# return result of lead certificate, this should be in chain[0] and
# thus result[0], but we better check. But if we had any hard_error
# return this instead
if ($hard_error) {
${*$iossl}{_SSL_ocsp_verify} = $hard_error;
} elsif (@results and $chain[0] == $iossl->peer_certificate) {
${*$iossl}{_SSL_ocsp_verify} = $results[0];
}
return 1;
};
Net::SSLeay::CTX_set_tlsext_status_cb($_,$status_cb) for (values %ctx);
}
if ( my $cl = $arg_hash->{SSL_cipher_list} ) {
for (keys %ctx) {
Net::SSLeay::CTX_set_cipher_list($ctx{$_}, ref($cl)
? $cl->{$_} || $cl->{''} || $DEFAULT_SSL_ARGS{SSL_cipher_list} || next
: $cl
) || return IO::Socket::SSL->error("Failed to set SSL cipher list");
}
}
if ( my $cl = $arg_hash->{SSL_ciphersuites} ) {
return IO::Socket::SSL->error("no support for SSL_ciphersuites in Net::SSLeay")
if ! $can_ciphersuites;
for (keys %ctx) {
Net::SSLeay::CTX_set_ciphersuites($ctx{$_}, ref($cl)
? $cl->{$_} || $cl->{''} || $DEFAULT_SSL_ARGS{SSL_cipher_list} || next
: $cl
) || return IO::Socket::SSL->error("Failed to set SSL cipher list");
}
}
# Main context is default context or any other if no default context.
my $ctx = $ctx{''} || (values %ctx)[0];
if (keys(%ctx) > 1 || ! exists $ctx{''}) {
$can_server_sni or return IO::Socket::SSL->_internal_error(
"Server side SNI not supported for this openssl/Net::SSLeay",9);
Net::SSLeay::CTX_set_tlsext_servername_callback($ctx, sub {
my $ssl = shift;
my $host = Net::SSLeay::get_servername($ssl);
$host = '' if ! defined $host;
my $snictx = $ctx{lc($host)} || $ctx{''} or do {
$DEBUG>1 and DEBUG(
"cannot get context from servername '$host'");
return 2; # SSL_TLSEXT_ERR_ALERT_FATAL
};
$DEBUG>1 and DEBUG("set context from servername $host");
Net::SSLeay::set_SSL_CTX($ssl,$snictx) if $snictx != $ctx;
return 0; # SSL_TLSEXT_ERR_OK
});
}
if ( my $cb = $arg_hash->{SSL_create_ctx_callback} ) {
$cb->($_) for values (%ctx);
}
$self->{context} = $ctx;
$self->{verify_mode} = $arg_hash->{SSL_verify_mode};
$self->{ocsp_mode} =
defined($arg_hash->{SSL_ocsp_mode}) ? $arg_hash->{SSL_ocsp_mode} :
$self->{verify_mode} ? IO::Socket::SSL::SSL_OCSP_TRY_STAPLE() :
0;
$DEBUG>=3 && DEBUG( "new ctx $ctx" );
if ( my $cache = $arg_hash->{SSL_session_cache} ) {
# use predefined cache
$self->{session_cache} = $cache
} elsif ( my $size = $arg_hash->{SSL_session_cache_size}) {
$self->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size );
}
if ($self->{session_cache} and %sess_cb) {
Net::SSLeay::CTX_set_session_cache_mode($ctx,
Net::SSLeay::SESS_CACHE_CLIENT());
my $cache = $self->{session_cache};
$sess_cb{new}($ctx, sub {
my ($ssl,$session) = @_;
my $self = ($SSL_OBJECT{$ssl} || do {
warn "callback session new: no known SSL object for $ssl";
return;
})->[0];
my $args = ${*$self}{_SSL_arguments};
my $key = $args->{SSL_session_key} or do {
warn "callback session new: no known SSL_session_key for $ssl";
return;
};
$DEBUG>=3 && DEBUG("callback session new <$key> $session");
Net::SSLeay::SESSION_up_ref($session);
$cache->add_session($key,$session);
});
$sess_cb{remove}($ctx, sub {
my ($ctx,$session) = @_;
$DEBUG>=3 && DEBUG("callback session remove $session");
$cache->del_session(undef,$session);
});
}
return $self;
}
sub has_session_cache {
return defined shift->{session_cache};
}
sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); }
sub DESTROY {
my $self = shift;
if ( my $ctx = $self->{context} ) {
$DEBUG>=3 && DEBUG("free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD ));
if (!$use_threads or delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) {
# remove any verify callback for this context
if ( $self->{verify_mode}) {
$DEBUG>=3 && DEBUG("free ctx $ctx callback" );
Net::SSLeay::CTX_set_verify($ctx, 0,undef);
}
if ( $self->{ocsp_error_ref}) {
$DEBUG>=3 && DEBUG("free ctx $ctx tlsext_status_cb" );
Net::SSLeay::CTX_set_tlsext_status_cb($ctx,undef);
}
$DEBUG>=3 && DEBUG("OK free ctx $ctx" );
Net::SSLeay::CTX_free($ctx);
}
}
delete(@{$self}{'context','session_cache'});
}
package IO::Socket::SSL::Session_Cache;
*DEBUG = *IO::Socket::SSL::DEBUG;
# The cache is consisting of one list which contains all sessions and then
# for each session key another list containing all sessions for same key.
# The order of the list is by use, i.e. last used are put on top.
# self.ghead points to the top of the global list while
# self.shead{key} to the top of the session key specific list
# All lists are cyclic
# Each element in the list consists of an array with slots for ...
use constant {
SESSION => 0, # session object
KEY => 1, # key for object
GNEXT => 2, # next element in global list
GPREV => 3, # previous element in global list
SNEXT => 4, # next element for same session key
SPREV => 5, # previous element for same session key
};
sub new {
my ($class, $size) = @_;
$size>0 or return;
return bless {
room => $size, # free space regarding to max size
ghead => undef, # top of global list
shead => {}, # top of key specific list
}, $class;
}
sub add_session {
my ($self, $key, $session) = @_;
# create new
my $v = [];
$v->[SESSION] = $session;
$v->[KEY] = $key;
$DEBUG>=3 && DEBUG("add_session($key,$session)");
_add_entry($self,$v);
}
sub replace_session {
my ($self, $key, $session) = @_;
$self->del_session($key);
$self->add_session($key, $session);
}
sub del_session {
my ($self, $key, $session) = @_;
# find all sessions which match given key and session and add to @del
# if key is given scan only sessions for the key, else all sessions
my ($head,$inext) = $key
? ($self->{shead}{$key},SNEXT) : ($self->{ghead},GNEXT);
my $v = $head;
my @del;
while ($v) {
if (!$session) {
push @del,$v
} elsif ($v->[SESSION] == $session) {
push @del, $v;
last;
}
lib/IO/Socket/SSL.pm view on Meta::CPAN
# add on top - like _add_entry
$v->[$inext] = $$rhead;
$v->[$iprev] = ${$rhead}->[$iprev];
${$rhead}->[$iprev][$inext] = $v;
${$rhead}->[$iprev] = $v;
$$rhead = $v;
}
}
sub _dump {
my $self = shift;
my %v2i;
my $v = $self->{ghead};
while ($v) {
exists $v2i{$v} and die;
$v2i{$v} = int(keys %v2i);
$v = $v->[GNEXT];
last if $v == $self->{ghead};
}
my $out = "room: $self->{room}\nghead:\n";
$v = $self->{ghead};
while ($v) {
$out .= sprintf(" - [%d] <%d,%d> '%s' <%s>\n",
$v2i{$v}, $v2i{$v->[GPREV]}, $v2i{$v->[GNEXT]},
$v->[KEY], $v->[SESSION]);
$v = $v->[GNEXT];
last if $v == $self->{ghead};
}
$out .= "shead:\n";
for my $key (sort keys %{$self->{shead}}) {
$out .= " - '$key'\n";
my $shead = $self->{shead}{$key};
my $v = $shead;
while ($v) {
$out .= sprintf(" - [%d] <%d,%d> '%s' <%s>\n",
$v2i{$v}, $v2i{$v->[SPREV]}, $v2i{$v->[SNEXT]},
$v->[KEY], $v->[SESSION]);
$v = $v->[SNEXT];
last if $v == $shead;
}
}
return $out;
}
sub DESTROY {
my $self = shift;
delete $self->{shead};
my $v = delete $self->{ghead};
while ($v) {
Net::SSLeay::SESSION_free($v->[SESSION]) if $v->[SESSION];
my $next = $v->[GNEXT];
@$v = ();
$v = $next;
}
}
package IO::Socket::SSL::OCSP_Cache;
sub new {
my ($class,$size) = @_;
return bless {
'' => { _lru => 0, size => $size || 100 }
},$class;
}
sub get {
my ($self,$id) = @_;
my $e = $self->{$id} or return;
$e->{_lru} = $self->{''}{_lru}++;
if ( $e->{expire} && time()<$e->{expire}) {
delete $self->{$id};
return;
}
if ( $e->{nextUpdate} && time()<$e->{nextUpdate} ) {
delete $self->{$id};
return;
}
return $e;
}
sub put {
my ($self,$id,$e) = @_;
$self->{$id} = $e;
$e->{_lru} = $self->{''}{_lru}++;
my $del = keys(%$self) - $self->{''}{size};
if ($del>0) {
my @k = sort { $self->{$a}{_lru} <=> $self->{$b}{_lru} } keys %$self;
delete @{$self}{ splice(@k,0,$del) };
}
return $e;
}
package IO::Socket::SSL::OCSP_Resolver;
*DEBUG = *IO::Socket::SSL::DEBUG;
# create a new resolver
# $ssl - the ssl object
# $cache - OCSP_Cache object (put,get)
# $failhard - flag if we should fail hard on OCSP problems
# $certs - list of certs to verify
sub new {
my ($class,$ssl,$cache,$failhard,$certs) = @_;
my (%todo,$done,$hard_error,@soft_error);
for my $cert (@$certs) {
# skip entries which have no OCSP uri or where we cannot get a certid
# (e.g. self-signed or where we don't have the issuer)
my $subj = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert));
my $uri = Net::SSLeay::P_X509_get_ocsp_uri($cert) or do {
$DEBUG>2 && DEBUG("no URI for certificate $subj");
push @soft_error,"no ocsp_uri for $subj";
next;
};
my $certid = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) } or do {
$DEBUG>2 && DEBUG("no OCSP_CERTID for certificate $subj: $@");
push @soft_error,"no certid for $subj: $@";
next;
};
if (!($done = $cache->get($certid))) {
push @{ $todo{$uri}{ids} }, $certid;
push @{ $todo{$uri}{subj} }, $subj;
} elsif ( $done->{hard_error} ) {
# one error is enough to fail validation
$hard_error = $done->{hard_error};
%todo = ();
last;
} elsif ( $done->{soft_error} ) {
push @soft_error,$done->{soft_error};
}
}
while ( my($uri,$v) = each %todo) {
my $ids = $v->{ids};
$v->{req} = Net::SSLeay::i2d_OCSP_REQUEST(
Net::SSLeay::OCSP_ids2req(@$ids));
}
$hard_error ||= '' if ! %todo;
return bless {
ssl => $ssl,
cache => $cache,
failhard => $failhard,
hard_error => $hard_error,
soft_error => @soft_error ? join("; ",@soft_error) : undef,
todo => \%todo,
},$class;
}
# return current result, e.g. '' for no error, else error
# if undef we have no final result yet
sub hard_error { return shift->{hard_error} }
sub soft_error { return shift->{soft_error} }
# return hash with uri => ocsp_request_data for open requests
sub requests {
my $todo = shift()->{todo};
return map { ($_,$todo->{$_}{req}) } keys %$todo;
lib/IO/Socket/SSL.pm view on Meta::CPAN
if (@miss && @found) {
# we sent multiple responses, but server answered only to one
# try again
$self->{todo}{$uri} = $todo;
$todo->{ids} = \@miss;
$todo->{req} = Net::SSLeay::i2d_OCSP_REQUEST(
Net::SSLeay::OCSP_ids2req(@miss));
$DEBUG>=2 && DEBUG("$uri just answered ".@found." of ".(@found+@miss)." requests");
}
} else {
@soft_error = "no data in response; subject: ".
join("; ",@{$todo->{subj}});
# probably configuration problem
$self->{cache}->put($_,{
soft_error => "@soft_error",
expire => time()+120,
}) for (@{$todo->{ids}});
}
Net::SSLeay::OCSP_REQUEST_free($req) if $req;
if ($self->{failhard}) {
push @hard_error,@soft_error;
@soft_error = ();
}
if (@soft_error) {
$self->{soft_error} .= "; " if $self->{soft_error};
$self->{soft_error} .= "$uri: ".join('; ',@soft_error);
}
if (@hard_error) {
$self->{hard_error} = "$uri: ".join('; ',@hard_error);
%{$self->{todo}} = ();
} elsif ( ! %{$self->{todo}} ) {
$self->{hard_error} = ''
}
return $self->{hard_error};
}
# make all necessary requests to get OCSP responses blocking
sub resolve_blocking {
my ($self,%args) = @_;
while ( my %todo = $self->requests ) {
eval { require HTTP::Tiny } or die "need HTTP::Tiny installed";
# OCSP responses have their own signature, so we don't need SSL verification
my $ua = HTTP::Tiny->new(verify_SSL => 0,%args);
while (my ($uri,$reqdata) = each %todo) {
$DEBUG && DEBUG("sending OCSP request to $uri");
my $resp = $ua->request('POST',$uri, {
headers => { 'Content-type' => 'application/ocsp-request' },
content => $reqdata
});
$DEBUG && DEBUG("got OCSP response from $uri code=$resp->{status}");
defined ($self->add_response($uri,
$resp->{success} && $resp->{content}))
&& last;
}
}
$DEBUG>=2 && DEBUG("no more open OCSP requests");
return $self->{hard_error};
}
package IO::Socket::SSL::Trace;
*DEBUG = *IO::Socket::SSL::DEBUG;
# Exhaustive list of constants we need for tracing
my %trace_constants = map { $_ => eval { Net::SSLeay->$_ } || -1 } qw(
SSL2_VERSION
SSL3_VERSION
TLS1_VERSION
TLS1_1_VERSION
TLS1_2_VERSION
TLS1_3_VERSION
DTLS1_VERSION
DTLS1_2_VERSION
DTLS1_BAD_VER
SSL3_RT_INNER_CONTENT_TYPE
SSL3_RT_CHANGE_CIPHER_SPEC
SSL3_RT_ALERT
SSL3_RT_HEADER
SSL3_RT_HANDSHAKE
SSL3_RT_APPLICATION_DATA
SSL2_MT_ERROR
SSL2_MT_CLIENT_HELLO
SSL2_MT_CLIENT_MASTER_KEY
SSL2_MT_CLIENT_FINISHED
SSL2_MT_SERVER_HELLO
SSL2_MT_SERVER_VERIFY
SSL2_MT_SERVER_FINISHED
SSL2_MT_REQUEST_CERTIFICATE
SSL2_MT_CLIENT_CERTIFICATE
SSL3_MT_HELLO_REQUEST
SSL3_MT_CLIENT_HELLO
SSL3_MT_SERVER_HELLO
SSL3_MT_NEWSESSION_TICKET
SSL3_MT_CERTIFICATE
SSL3_MT_SERVER_KEY_EXCHANGE
SSL3_MT_CLIENT_KEY_EXCHANGE
SSL3_MT_CERTIFICATE_REQUEST
SSL3_MT_SERVER_DONE
SSL3_MT_CERTIFICATE_VERIFY
SSL3_MT_FINISHED
SSL3_MT_CERTIFICATE_STATUS
SSL3_MT_ENCRYPTED_EXTENSIONS
SSL3_MT_SUPPLEMENTAL_DATA
SSL3_MT_END_OF_EARLY_DATA
SSL3_MT_KEY_UPDATE
SSL3_MT_NEXT_PROTO
SSL3_MT_MESSAGE_HASH
);
#
# Major versions
#
$trace_constants{SSL2_VERSION_MAJOR} = $trace_constants{SSL2_VERSION} >> 8;
$trace_constants{SSL3_VERSION_MAJOR} = $trace_constants{SSL3_VERSION} >> 8;
#
# Mapping between trace constant and version string
#
my %tc_ver2s;
for (
[ SSL2_VERSION => "SSLv2" ],
[ SSL2_VERSION => "SSLv2" ],
( run in 1.116 second using v1.01-cache-2.11-cpan-39bf76dae61 )