1#vim: set sts=4 sw=4 ts=8 ai: 2# 3# IO::Socket::SSL: 4# provide an interface to SSL connections similar to IO::Socket modules 5# 6# Current Code Shepherd: Steffen Ullrich <sullr at cpan.org> 7# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu> 8# 9# The original version of this module was written by 10# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from 11# Crypt::SSLeay (Net::SSL) by Gisle Aas. 12# 13 14package IO::Socket::SSL; 15 16our $VERSION = '2.073'; 17 18use IO::Socket; 19use Net::SSLeay 1.46; 20use IO::Socket::SSL::PublicSuffix; 21use Exporter (); 22use Errno qw( EWOULDBLOCK EAGAIN ETIMEDOUT EINTR EPIPE ); 23use Carp; 24use strict; 25 26my $use_threads; 27BEGIN { 28 die "no support for weaken - please install Scalar::Util" if ! do { 29 local $SIG{__DIE__}; 30 eval { require Scalar::Util; Scalar::Util->import("weaken"); 1 } 31 || eval { require WeakRef; WeakRef->import("weaken"); 1 } 32 }; 33 require Config; 34 $use_threads = $Config::Config{usethreads}; 35} 36 37 38# results from commonly used constant functions from Net::SSLeay for fast access 39my $Net_SSLeay_ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ(); 40my $Net_SSLeay_ERROR_WANT_WRITE = Net::SSLeay::ERROR_WANT_WRITE(); 41my $Net_SSLeay_ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL(); 42my $Net_SSLeay_ERROR_SSL = Net::SSLeay::ERROR_SSL(); 43my $Net_SSLeay_VERIFY_NONE = Net::SSLeay::VERIFY_NONE(); 44my $Net_SSLeay_VERIFY_PEER = Net::SSLeay::VERIFY_PEER(); 45 46 47use constant SSL_VERIFY_NONE => &Net::SSLeay::VERIFY_NONE; 48use constant SSL_VERIFY_PEER => &Net::SSLeay::VERIFY_PEER; 49use constant SSL_VERIFY_FAIL_IF_NO_PEER_CERT => Net::SSLeay::VERIFY_FAIL_IF_NO_PEER_CERT(); 50use constant SSL_VERIFY_CLIENT_ONCE => Net::SSLeay::VERIFY_CLIENT_ONCE(); 51 52# from openssl/ssl.h; should be better in Net::SSLeay 53use constant SSL_SENT_SHUTDOWN => 1; 54use constant SSL_RECEIVED_SHUTDOWN => 2; 55 56use constant SSL_OCSP_NO_STAPLE => 0b00001; 57use constant SSL_OCSP_MUST_STAPLE => 0b00010; 58use constant SSL_OCSP_FAIL_HARD => 0b00100; 59use constant SSL_OCSP_FULL_CHAIN => 0b01000; 60use constant SSL_OCSP_TRY_STAPLE => 0b10000; 61 62# capabilities of underlying Net::SSLeay/openssl 63my $can_client_sni; # do we support SNI on the client side 64my $can_server_sni; # do we support SNI on the server side 65my $can_multi_cert; # RSA and ECC certificate in same context 66my $can_npn; # do we support NPN (obsolete) 67my $can_alpn; # do we support ALPN 68my $can_ecdh; # do we support ECDH key exchange 69my $set_groups_list; # SSL_CTX_set1_groups_list || SSL_CTX_set1_curves_list || undef 70my $can_ocsp; # do we support OCSP 71my $can_ocsp_staple; # do we support OCSP stapling 72my $can_tckt_keycb; # TLS ticket key callback 73my $can_pha; # do we support PHA 74my $session_upref; # SSL_SESSION_up_ref is implemented 75my %sess_cb; # SSL_CTX_sess_set_(new|remove)_cb 76my $check_partial_chain; # use X509_V_FLAG_PARTIAL_CHAIN if available 77my $auto_retry; # (clear|set)_mode SSL_MODE_AUTO_RETRY with OpenSSL 1.1.1+ with non-blocking 78my $ssl_mode_release_buffers = 0; # SSL_MODE_RELEASE_BUFFERS if available 79 80my $openssl_version; 81my $netssleay_version; 82 83BEGIN { 84 $openssl_version = Net::SSLeay::OPENSSL_VERSION_NUMBER(); 85 $netssleay_version = do { no warnings; $Net::SSLeay::VERSION + 0.0; }; 86 $can_client_sni = $openssl_version >= 0x10000000; 87 $can_server_sni = defined &Net::SSLeay::get_servername; 88 $can_npn = defined &Net::SSLeay::P_next_proto_negotiated && 89 ! Net::SSLeay::constant("LIBRESSL_VERSION_NUMBER"); 90 # LibreSSL 2.6.1 disabled NPN by keeping the relevant functions 91 # available but removed the actual functionality from these functions. 92 $can_alpn = defined &Net::SSLeay::CTX_set_alpn_protos; 93 $can_ecdh = 94 ($openssl_version >= 0x1010000f) ? 'auto' : 95 defined(&Net::SSLeay::CTX_set_ecdh_auto) ? 'can_auto' : 96 (defined &Net::SSLeay::CTX_set_tmp_ecdh && 97 # There is a regression with elliptic curves on 1.0.1d with 64bit 98 # http://rt.openssl.org/Ticket/Display.html?id=2975 99 ( $openssl_version != 0x1000104f 100 || length(pack("P",0)) == 4 )) ? 'tmp_ecdh' : 101 ''; 102 $set_groups_list = 103 defined &Net::SSLeay::CTX_set1_groups_list ? \&Net::SSLeay::CTX_set1_groups_list : 104 defined &Net::SSLeay::CTX_set1_curves_list ? \&Net::SSLeay::CTX_set1_curves_list : 105 undef; 106 $can_multi_cert = $can_ecdh 107 && $openssl_version >= 0x10002000; 108 $can_ocsp = defined &Net::SSLeay::OCSP_cert2ids 109 # OCSP got broken in 1.75..1.77 110 && ($netssleay_version < 1.75 || $netssleay_version > 1.77); 111 $can_ocsp_staple = $can_ocsp 112 && defined &Net::SSLeay::set_tlsext_status_type; 113 $can_tckt_keycb = defined &Net::SSLeay::CTX_set_tlsext_ticket_getkey_cb 114 && $netssleay_version >= 1.80; 115 $can_pha = defined &Net::SSLeay::CTX_set_post_handshake_auth; 116 117 if (defined &Net::SSLeay::SESSION_up_ref) { 118 $session_upref = 1; 119 } 120 121 if ($session_upref 122 && defined &Net::SSLeay::CTX_sess_set_new_cb 123 && defined &Net::SSLeay::CTX_sess_set_remove_cb) { 124 %sess_cb = ( 125 new => \&Net::SSLeay::CTX_sess_set_new_cb, 126 remove => \&Net::SSLeay::CTX_sess_set_remove_cb, 127 ); 128 } 129 130 if (my $c = defined &Net::SSLeay::CTX_get0_param 131 && eval { Net::SSLeay::X509_V_FLAG_PARTIAL_CHAIN() }) { 132 $check_partial_chain = sub { 133 my $ctx = shift; 134 my $param = Net::SSLeay::CTX_get0_param($ctx); 135 Net::SSLeay::X509_VERIFY_PARAM_set_flags($param, $c); 136 }; 137 } 138 139 if (!defined &Net::SSLeay::clear_mode) { 140 # assume SSL_CTRL_CLEAR_MODE being 78 since it was always this way 141 *Net::SSLeay::clear_mode = sub { 142 my ($ctx,$opt) = @_; 143 Net::SSLeay::ctrl($ctx,78,$opt,0); 144 }; 145 } 146 147 if ($openssl_version >= 0x10101000) { 148 # openssl 1.1.1 enabled SSL_MODE_AUTO_RETRY by default, which is bad for 149 # non-blocking sockets 150 my $mode_auto_retry = 151 # was always 0x00000004 152 eval { Net::SSLeay::MODE_AUTO_RETRY() } || 0x00000004; 153 $auto_retry = sub { 154 my ($ssl,$on) = @_; 155 if ($on) { 156 Net::SSLeay::set_mode($ssl, $mode_auto_retry); 157 } else { 158 Net::SSLeay::clear_mode($ssl, $mode_auto_retry); 159 } 160 } 161 } 162 if ($openssl_version >= 0x10000000) { 163 # ssl/ssl.h:#define SSL_MODE_RELEASE_BUFFERS 0x00000010L 164 $ssl_mode_release_buffers = 0x00000010; 165 } 166} 167 168my $algo2digest = do { 169 my %digest; 170 sub { 171 my $digest_name = shift; 172 return $digest{$digest_name} ||= do { 173 Net::SSLeay::SSLeay_add_ssl_algorithms(); 174 Net::SSLeay::EVP_get_digestbyname($digest_name) 175 or die "Digest algorithm $digest_name is not available"; 176 }; 177 } 178}; 179 180my $CTX_tlsv1_3_new; 181if ( defined &Net::SSLeay::CTX_set_min_proto_version 182 and defined &Net::SSLeay::CTX_set_max_proto_version 183 and my $tls13 = eval { Net::SSLeay::TLS1_3_VERSION() } 184) { 185 $CTX_tlsv1_3_new = sub { 186 my $ctx = Net::SSLeay::CTX_new(); 187 return $ctx if Net::SSLeay::CTX_set_min_proto_version($ctx,$tls13) 188 && Net::SSLeay::CTX_set_max_proto_version($ctx,$tls13); 189 Net::SSLeay::CTX_free($ctx); 190 return; 191 }; 192} 193 194 195# global defaults 196my %DEFAULT_SSL_ARGS = ( 197 SSL_check_crl => 0, 198 SSL_version => 'SSLv23:!SSLv3:!SSLv2', # consider both SSL3.0 and SSL2.0 as broken 199 SSL_verify_callback => undef, 200 SSL_verifycn_scheme => undef, # fallback cn verification 201 SSL_verifycn_publicsuffix => undef, # fallback default list verification 202 #SSL_verifycn_name => undef, # use from PeerAddr/PeerHost - do not override in set_args_filter_hack 'use_defaults' 203 SSL_npn_protocols => undef, # meaning depends whether on server or client side 204 SSL_alpn_protocols => undef, # list of protocols we'll accept/send, for example ['http/1.1','spdy/3.1'] 205 206 # https://wiki.mozilla.org/Security/Server_Side_TLS, 2019/03/05 207 # "Old backward compatibility" for best compatibility 208 # .. "Most ciphers that are not clearly broken and dangerous to use are supported" 209 # slightly reordered to prefer AES since it is cheaper when hardware accelerated 210 SSL_cipher_list => 'ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:DHE-RSA-AES128-GCM-SHA256:DHE-DSS-AES128-GCM-SHA256:kEDH+AESGCM:ECDHE-RSA-AES128-SHA256:ECDHE-ECDSA-AES128-SHA256:ECDHE-RSA-AES128-SHA:ECDHE-ECDSA-AES128-SHA:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA:ECDHE-ECDSA-AES256-SHA:DHE-RSA-AES128-SHA256:DHE-RSA-AES128-SHA:DHE-DSS-AES128-SHA256:DHE-RSA-AES256-SHA256:DHE-DSS-AES256-SHA:DHE-RSA-AES256-SHA:ECDHE-RSA-DES-CBC3-SHA:ECDHE-ECDSA-DES-CBC3-SHA:EDH-RSA-DES-CBC3-SHA:AES128-GCM-SHA256:AES256-GCM-SHA384:AES128-SHA256:AES256-SHA256:AES128-SHA:AES256-SHA:AES:DES-CBC3-SHA:HIGH:SEED:!aNULL:!eNULL:!EXPORT:!DES:!RC4:!MD5:!PSK:!RSAPSK:!aDH:!aECDH:!EDH-DSS-DES-CBC3-SHA:!KRB5-DES-CBC3-SHA:!SRP', 211); 212 213my %DEFAULT_SSL_CLIENT_ARGS = ( 214 %DEFAULT_SSL_ARGS, 215 SSL_verify_mode => SSL_VERIFY_PEER, 216 217 SSL_ca_file => undef, 218 SSL_ca_path => undef, 219 220 # older versions of F5 BIG-IP hang when getting SSL client hello >255 bytes 221 # http://support.f5.com/kb/en-us/solutions/public/13000/000/sol13037.html 222 # http://guest:guest@rt.openssl.org/Ticket/Display.html?id=2771 223 # Ubuntu worked around this by disabling TLSv1_2 on the client side for 224 # a while. Later a padding extension was added to OpenSSL to work around 225 # broken F5 but then IronPort croaked because it did not understand this 226 # extension so it was disabled again :( 227 # Firefox, Chrome and IE11 use TLSv1_2 but use only a few ciphers, so 228 # that packet stays small enough. We try the same here. 229 230 SSL_cipher_list => join(" ", 231 232 # SSLabs report for Chrome 48/OSX. 233 # This also includes the fewer ciphers Firefox uses. 234 'ECDHE-ECDSA-AES128-GCM-SHA256', 235 'ECDHE-RSA-AES128-GCM-SHA256', 236 'DHE-RSA-AES128-GCM-SHA256', 237 'ECDHE-ECDSA-CHACHA20-POLY1305', 238 'ECDHE-RSA-CHACHA20-POLY1305', 239 'ECDHE-ECDSA-AES256-SHA', 240 'ECDHE-RSA-AES256-SHA', 241 'DHE-RSA-AES256-SHA', 242 'ECDHE-ECDSA-AES128-SHA', 243 'ECDHE-RSA-AES128-SHA', 244 'DHE-RSA-AES128-SHA', 245 'AES128-GCM-SHA256', 246 'AES256-SHA', 247 'AES128-SHA', 248 'DES-CBC3-SHA', 249 250 # IE11/Edge has some more ciphers, notably SHA384 and DSS 251 # we don't offer the *-AES128-SHA256 and *-AES256-SHA384 non-GCM 252 # ciphers IE/Edge offers because they look like a large mismatch 253 # between a very strong HMAC and a comparably weak (but sufficient) 254 # encryption. Similar all browsers which do SHA384 can do ECDHE 255 # so skip the DHE*SHA384 ciphers. 256 'ECDHE-RSA-AES256-GCM-SHA384', 257 'ECDHE-ECDSA-AES256-GCM-SHA384', 258 # 'ECDHE-RSA-AES256-SHA384', 259 # 'ECDHE-ECDSA-AES256-SHA384', 260 # 'ECDHE-RSA-AES128-SHA256', 261 # 'ECDHE-ECDSA-AES128-SHA256', 262 # 'DHE-RSA-AES256-GCM-SHA384', 263 # 'AES256-GCM-SHA384', 264 'AES256-SHA256', 265 # 'AES128-SHA256', 266 'DHE-DSS-AES256-SHA256', 267 # 'DHE-DSS-AES128-SHA256', 268 'DHE-DSS-AES256-SHA', 269 'DHE-DSS-AES128-SHA', 270 'EDH-DSS-DES-CBC3-SHA', 271 272 # Just to make sure, that we don't accidentally add bad ciphers above. 273 # This includes dropping RC4 which is no longer supported by modern 274 # browsers and also excluded in the SSL libraries of Python and Ruby. 275 "!EXP !MEDIUM !LOW !eNULL !aNULL !RC4 !DES !MD5 !PSK !SRP" 276 ) 277); 278 279# set values inside _init to work with perlcc, RT#95452 280my %DEFAULT_SSL_SERVER_ARGS; 281 282# Initialization of OpenSSL internals 283# This will be called once during compilation - perlcc users might need to 284# call it again by hand, see RT#95452 285{ 286 sub init { 287 # library_init returns false if the library was already initialized. 288 # This way we can find out if the library needs to be re-initialized 289 # inside code compiled with perlcc 290 Net::SSLeay::library_init() or return; 291 292 Net::SSLeay::load_error_strings(); 293 Net::SSLeay::OpenSSL_add_all_digests(); 294 Net::SSLeay::randomize(); 295 296 %DEFAULT_SSL_SERVER_ARGS = ( 297 %DEFAULT_SSL_ARGS, 298 SSL_verify_mode => SSL_VERIFY_NONE, 299 SSL_honor_cipher_order => 1, # trust server to know the best cipher 300 SSL_dh => do { 301 my $bio = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem()); 302 # generated with: openssl dhparam 2048 303 Net::SSLeay::BIO_write($bio,<<'DH'); 304-----BEGIN DH PARAMETERS----- 305MIIBCAKCAQEAr8wskArj5+1VCVsnWt/RUR7tXkHJ7mGW7XxrLSPOaFyKyWf8lZht 306iSY2Lc4oa4Zw8wibGQ3faeQu/s8fvPq/aqTxYmyHPKCMoze77QJHtrYtJAosB9SY 307CN7s5Hexxb5/vQ4qlQuOkVrZDiZO9GC4KaH9mJYnCoAsXDhDft6JT0oRVSgtZQnU 308gWFKShIm+JVjN94kGs0TcBEesPTK2g8XVHK9H8AtSUb9BwW2qD/T5RmgNABysApO 309Ps2vlkxjAHjJcqc3O+OiImKik/X2rtBTZjpKmzN3WWTB0RJZCOWaLlDO81D01o1E 310aZecz3Np9KIYey900f+X7zC2bJxEHp95ywIBAg== 311-----END DH PARAMETERS----- 312DH 313 my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio); 314 Net::SSLeay::BIO_free($bio); 315 $dh or die "no DH"; 316 $dh; 317 }, 318 ( 319 $can_ecdh eq 'auto' ? () : # automatically enabled by openssl 320 $can_ecdh eq 'can_auto' ? (SSL_ecdh_curve => 'auto') : 321 $can_ecdh eq 'tmp_ecdh' ? ( SSL_ecdh_curve => 'prime256v1' ) : 322 (), 323 ) 324 ); 325 } 326 # Call it once at compile time and try it at INIT. 327 # This should catch all cases of including the module, e.g. 'use' (INIT) or 328 # 'require' (compile time) and works also with perlcc 329 { 330 no warnings; 331 INIT { init() } 332 init(); 333 } 334} 335 336# global defaults which can be changed using set_defaults 337# either key/value can be set or it can just be set to an external hash 338my $GLOBAL_SSL_ARGS = {}; 339my $GLOBAL_SSL_CLIENT_ARGS = {}; 340my $GLOBAL_SSL_SERVER_ARGS = {}; 341 342# hack which is used to filter bad settings from used modules 343my $FILTER_SSL_ARGS = undef; 344 345# non-XS Versions of Scalar::Util will fail 346BEGIN{ 347 die "You need the XS Version of Scalar::Util for dualvar() support" if !do { 348 local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent 349 eval { use Scalar::Util 'dualvar'; dualvar(0,''); 1 }; 350 }; 351} 352 353# get constants for SSL_OP_NO_* now, instead calling the related functions 354# every time we setup a connection 355my %SSL_OP_NO; 356for(qw( SSLv2 SSLv3 TLSv1 TLSv1_1 TLSv11:TLSv1_1 TLSv1_2 TLSv12:TLSv1_2 357 TLSv1_3 TLSv13:TLSv1_3 )) { 358 my ($k,$op) = m{:} ? split(m{:},$_,2) : ($_,$_); 359 my $sub = "Net::SSLeay::OP_NO_$op"; 360 local $SIG{__DIE__}; 361 $SSL_OP_NO{$k} = eval { no strict 'refs'; &$sub } || 0; 362} 363 364# Make SSL_CTX_clear_options accessible through SSL_CTX_ctrl unless it is 365# already implemented in Net::SSLeay 366if (!defined &Net::SSLeay::CTX_clear_options) { 367 *Net::SSLeay::CTX_clear_options = sub { 368 my ($ctx,$opt) = @_; 369 # 77 = SSL_CTRL_CLEAR_OPTIONS 370 Net::SSLeay::CTX_ctrl($ctx,77,$opt,0); 371 }; 372} 373 374# Try to work around problems with alternative trust path by default, RT#104759 375my $DEFAULT_X509_STORE_flags = 0; 376{ 377 local $SIG{__DIE__}; 378 eval { $DEFAULT_X509_STORE_flags |= Net::SSLeay::X509_V_FLAG_TRUSTED_FIRST() }; 379} 380 381our $DEBUG; 382use vars qw(@ISA $SSL_ERROR @EXPORT); 383 384{ 385 # These constants will be used in $! at return from SSL_connect, 386 # SSL_accept, _generic_(read|write), thus notifying the caller 387 # the usual way of problems. Like with EWOULDBLOCK, EINPROGRESS.. 388 # these are especially important for non-blocking sockets 389 390 my $x = $Net_SSLeay_ERROR_WANT_READ; 391 use constant SSL_WANT_READ => dualvar( \$x, 'SSL wants a read first' ); 392 my $y = $Net_SSLeay_ERROR_WANT_WRITE; 393 use constant SSL_WANT_WRITE => dualvar( \$y, 'SSL wants a write first' ); 394 395 @EXPORT = qw( 396 SSL_WANT_READ SSL_WANT_WRITE SSL_VERIFY_NONE SSL_VERIFY_PEER 397 SSL_VERIFY_FAIL_IF_NO_PEER_CERT SSL_VERIFY_CLIENT_ONCE 398 SSL_OCSP_NO_STAPLE SSL_OCSP_TRY_STAPLE SSL_OCSP_MUST_STAPLE 399 SSL_OCSP_FAIL_HARD SSL_OCSP_FULL_CHAIN 400 $SSL_ERROR GEN_DNS GEN_IPADD 401 ); 402} 403 404my @caller_force_inet4; # in case inet4 gets forced we store here who forced it 405 406my $IOCLASS; 407my $family_key; # 'Domain'||'Family' 408BEGIN { 409 # declare @ISA depending of the installed socket class 410 411 # try to load inet_pton from Socket or Socket6 and make sure it is usable 412 local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent 413 my $ip6 = eval { 414 require Socket; 415 Socket->VERSION(1.95); 416 Socket::inet_pton( AF_INET6(),'::1') && AF_INET6() or die; 417 Socket->import( qw/inet_pton NI_NUMERICHOST NI_NUMERICSERV/ ); 418 # behavior different to Socket6::getnameinfo - wrap 419 *_getnameinfo = sub { 420 my ($err,$host,$port) = Socket::getnameinfo(@_) or return; 421 return if $err; 422 return ($host,$port); 423 }; 424 'Socket'; 425 } || eval { 426 require Socket6; 427 Socket6::inet_pton( AF_INET6(),'::1') && AF_INET6() or die; 428 Socket6->import( qw/inet_pton NI_NUMERICHOST NI_NUMERICSERV/ ); 429 # behavior different to Socket::getnameinfo - wrap 430 *_getnameinfo = sub { return Socket6::getnameinfo(@_); }; 431 'Socket6'; 432 } || undef; 433 434 # try IO::Socket::IP or IO::Socket::INET6 for IPv6 support 435 $family_key = 'Domain'; # traditional 436 if ($ip6) { 437 # if we have IO::Socket::IP >= 0.31 we will use this in preference 438 # because it can handle both IPv4 and IPv6 439 if ( eval { 440 require IO::Socket::IP; 441 IO::Socket::IP->VERSION(0.31) 442 }) { 443 @ISA = qw(IO::Socket::IP); 444 constant->import( CAN_IPV6 => "IO::Socket::IP" ); 445 $family_key = 'Family'; 446 $IOCLASS = "IO::Socket::IP"; 447 448 # if we have IO::Socket::INET6 we will use this not IO::Socket::INET 449 # because it can handle both IPv4 and IPv6 450 # require at least 2.62 because of several problems before that version 451 } elsif( eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION(2.62) } ) { 452 @ISA = qw(IO::Socket::INET6); 453 constant->import( CAN_IPV6 => "IO::Socket::INET6" ); 454 $IOCLASS = "IO::Socket::INET6"; 455 } else { 456 $ip6 = '' 457 } 458 } 459 460 # fall back to IO::Socket::INET for IPv4 only 461 if (!$ip6) { 462 @ISA = qw(IO::Socket::INET); 463 $IOCLASS = "IO::Socket::INET"; 464 constant->import(CAN_IPV6 => ''); 465 if (!defined $ip6) { 466 constant->import(NI_NUMERICHOST => 1); 467 constant->import(NI_NUMERICSERV => 2); 468 } 469 } 470 471 #Make $DEBUG another name for $Net::SSLeay::trace 472 *DEBUG = \$Net::SSLeay::trace; 473 474 #Compatibility 475 *ERROR = \$SSL_ERROR; 476} 477 478 479sub DEBUG { 480 $DEBUG or return; 481 my (undef,$file,$line,$sub) = caller(1); 482 if ($sub =~m{^IO::Socket::SSL::(?:error|(_internal_error))$}) { 483 (undef,$file,$line) = caller(2) if $1; 484 } else { 485 (undef,$file,$line) = caller; 486 } 487 my $msg = shift; 488 $file = '...'.substr( $file,-17 ) if length($file)>20; 489 $msg = sprintf $msg,@_ if @_; 490 print STDERR "DEBUG: $file:$line: $msg\n"; 491} 492 493BEGIN { 494 # import some constants from Net::SSLeay or use hard-coded defaults 495 # if Net::SSLeay isn't recent enough to provide the constants 496 my %const = ( 497 NID_CommonName => 13, 498 GEN_DNS => 2, 499 GEN_IPADD => 7, 500 ); 501 while ( my ($name,$value) = each %const ) { 502 no strict 'refs'; 503 *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; 504 } 505 506 *idn_to_ascii = \&IO::Socket::SSL::PublicSuffix::idn_to_ascii; 507 *idn_to_unicode = \&IO::Socket::SSL::PublicSuffix::idn_to_unicode; 508} 509 510my $OPENSSL_LIST_SEPARATOR = $^O =~m{^(?:(dos|os2|mswin32|netware)|vms)$}i 511 ? $1 ? ';' : ',' : ':'; 512my $CHECK_SSL_PATH = sub { 513 my %args = (@_ == 1) ? ('',@_) : @_; 514 for my $type (keys %args) { 515 my $path = $args{$type}; 516 if (!$type) { 517 delete $args{$type}; 518 $type = (ref($path) || -d $path) ? 'SSL_ca_path' : 'SSL_ca_file'; 519 $args{$type} = $path; 520 } 521 522 next if ref($path) eq 'SCALAR' && ! $$path; 523 if ($type eq 'SSL_ca_file') { 524 die "SSL_ca_file $path can't be used: $!" 525 if ! open(my $fh,'<',$path); 526 } elsif ($type eq 'SSL_ca_path') { 527 $path = [ split($OPENSSL_LIST_SEPARATOR,$path) ] if !ref($path); 528 my @err; 529 for my $d (ref($path) ? @$path : $path) { 530 if (! -d $d) { 531 push @err, "SSL_ca_path $d does not exist"; 532 } elsif (! opendir(my $dh,$d)) { 533 push @err, "SSL_ca_path $d is not accessible: $!" 534 } else { 535 @err = (); 536 last 537 } 538 } 539 die "@err" if @err; 540 } 541 } 542 return %args; 543}; 544 545 546{ 547 my %default_ca; 548 my $ca_detected; # 0: never detect, undef: need to (re)detect 549 my $openssldir; 550 551 sub default_ca { 552 if (@_) { 553 # user defined default CA or reset 554 if ( @_ > 1 ) { 555 %default_ca = @_; 556 $ca_detected = 0; 557 } elsif ( my $path = shift ) { 558 %default_ca = $CHECK_SSL_PATH->($path); 559 $ca_detected = 0; 560 } else { 561 $ca_detected = undef; 562 } 563 } 564 return %default_ca if defined $ca_detected; 565 566 # SSLEAY_DIR was 5 up to OpenSSL 1.1, then switched to 4 and got 567 # renamed to OPENSSL_DIR. Unfortunately it is not exported as constant 568 # by Net::SSLeay so we use the fixed number. 569 $openssldir ||= 570 Net::SSLeay::SSLeay_version(5) =~m{^OPENSSLDIR: "(.+)"$} ? $1 : 571 Net::SSLeay::SSLeay_version(4) =~m{^OPENSSLDIR: "(.+)"$} ? $1 : 572 'cannot-determine-openssldir-from-ssleay-version'; 573 574 # (re)detect according to openssl crypto/cryptlib.h 575 my $dir = $ENV{SSL_CERT_DIR} 576 || ( $^O =~m{vms}i ? "SSLCERTS:":"$openssldir/certs" ); 577 if ( opendir(my $dh,$dir)) { 578 FILES: for my $f ( grep { m{^[a-f\d]{8}(\.\d+)?$} } readdir($dh) ) { 579 open( my $fh,'<',"$dir/$f") or next; 580 while (my $line = <$fh>) { 581 $line =~m{^-+BEGIN (X509 |TRUSTED |)CERTIFICATE-} or next; 582 $default_ca{SSL_ca_path} = $dir; 583 last FILES; 584 } 585 } 586 } 587 my $file = $ENV{SSL_CERT_FILE} 588 || ( $^O =~m{vms}i ? "SSLCERTS:cert.pem":"$openssldir/cert.pem" ); 589 if ( open(my $fh,'<',$file)) { 590 while (my $line = <$fh>) { 591 $line =~m{^-+BEGIN (X509 |TRUSTED |)CERTIFICATE-} or next; 592 $default_ca{SSL_ca_file} = $file; 593 last; 594 } 595 } 596 597 $default_ca{SSL_ca_file} = Mozilla::CA::SSL_ca_file() if ! %default_ca && do { 598 local $SIG{__DIE__}; 599 eval { require Mozilla::CA; 1 }; 600 }; 601 602 $ca_detected = 1; 603 return %default_ca; 604 } 605} 606 607 608# Export some stuff 609# inet4|inet6|debug will be handled by myself, everything 610# else will be handled the Exporter way 611sub import { 612 my $class = shift; 613 614 my @export; 615 foreach (@_) { 616 if ( /^inet4$/i ) { 617 # explicitly fall back to inet4 618 @ISA = 'IO::Socket::INET'; 619 @caller_force_inet4 = caller(); # save for warnings for 'inet6' case 620 } elsif ( /^inet6$/i ) { 621 # check if we have already ipv6 as base 622 if ( ! UNIVERSAL::isa( $class, 'IO::Socket::INET6') 623 and ! UNIVERSAL::isa( $class, 'IO::Socket::IP' )) { 624 # either we don't support it or we disabled it by explicitly 625 # loading it with 'inet4'. In this case re-enable but warn 626 # because this is probably an error 627 if ( CAN_IPV6 ) { 628 @ISA = ( CAN_IPV6 ); 629 warn "IPv6 support re-enabled in __PACKAGE__, got disabled in file $caller_force_inet4[1] line $caller_force_inet4[2]"; 630 } else { 631 die "INET6 is not supported, install IO::Socket::IP"; 632 } 633 } 634 } elsif ( /^:?debug(\d+)/ ) { 635 $DEBUG=$1; 636 } else { 637 push @export,$_ 638 } 639 } 640 641 @_ = ( $class,@export ); 642 goto &Exporter::import; 643} 644 645my %SSL_OBJECT; 646my %CREATED_IN_THIS_THREAD; 647sub CLONE { %CREATED_IN_THIS_THREAD = (); } 648 649# all keys used internally, these should be cleaned up at end 650my @all_my_keys = qw( 651 _SSL_arguments 652 _SSL_certificate 653 _SSL_ctx 654 _SSL_fileno 655 _SSL_in_DESTROY 656 _SSL_ioclass_downgrade 657 _SSL_ioclass_upgraded 658 _SSL_last_err 659 _SSL_object 660 _SSL_ocsp_verify 661 _SSL_opened 662 _SSL_opening 663 _SSL_servername 664); 665 666 667# we have callbacks associated with contexts, but have no way to access the 668# current SSL object from these callbacks. To work around this 669# CURRENT_SSL_OBJECT will be set before calling Net::SSLeay::{connect,accept} 670# and reset afterwards, so we have access to it inside _internal_error. 671my $CURRENT_SSL_OBJECT; 672 673# You might be expecting to find a new() subroutine here, but that is 674# not how IO::Socket::INET works. All configuration gets performed in 675# the calls to configure() and either connect() or accept(). 676 677#Call to configure occurs when a new socket is made using 678#IO::Socket::INET. Returns false (empty list) on failure. 679sub configure { 680 my ($self, $arg_hash) = @_; 681 return _invalid_object() unless($self); 682 683 # force initial blocking 684 # otherwise IO::Socket::SSL->new might return undef if the 685 # socket is nonblocking and it fails to connect immediately 686 # for real nonblocking behavior one should create a nonblocking 687 # socket and later call connect explicitly 688 my $blocking = delete $arg_hash->{Blocking}; 689 690 # because Net::HTTPS simple redefines blocking() to {} (e.g. 691 # return undef) and IO::Socket::INET does not like this we 692 # set Blocking only explicitly if it was set 693 $arg_hash->{Blocking} = 1 if defined ($blocking); 694 695 $self->configure_SSL($arg_hash) || return; 696 697 if ($arg_hash->{$family_key} ||= $arg_hash->{Domain} || $arg_hash->{Family}) { 698 # Hack to work around the problem that IO::Socket::IP defaults to 699 # AI_ADDRCONFIG which creates problems if we have only the loopback 700 # interface. If we already know the family this flag is more harmful 701 # then useful. 702 $arg_hash->{GetAddrInfoFlags} = 0 if $IOCLASS eq 'IO::Socket::IP' 703 && ! defined $arg_hash->{GetAddrInfoFlags}; 704 } 705 return $self->_internal_error("@ISA configuration failed",0) 706 if ! $self->SUPER::configure($arg_hash); 707 708 $self->blocking(0) if defined $blocking && !$blocking; 709 return $self; 710} 711 712sub configure_SSL { 713 my ($self, $arg_hash) = @_; 714 715 $arg_hash->{Proto} ||= 'tcp'; 716 my $is_server = $arg_hash->{SSL_server}; 717 if ( ! defined $is_server ) { 718 $is_server = $arg_hash->{SSL_server} = $arg_hash->{Listen} || 0; 719 } 720 721 # add user defined defaults, maybe after filtering 722 $FILTER_SSL_ARGS->($is_server,$arg_hash) if $FILTER_SSL_ARGS; 723 724 delete @{*$self}{@all_my_keys}; 725 ${*$self}{_SSL_opened} = $is_server; 726 ${*$self}{_SSL_arguments} = $arg_hash; 727 728 # this adds defaults to $arg_hash as a side effect! 729 ${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) 730 or return; 731 732 return $self; 733} 734 735 736sub _skip_rw_error { 737 my ($self,$ssl,$rv) = @_; 738 my $err = Net::SSLeay::get_error($ssl,$rv); 739 if ( $err == $Net_SSLeay_ERROR_WANT_READ) { 740 $SSL_ERROR = SSL_WANT_READ; 741 } elsif ( $err == $Net_SSLeay_ERROR_WANT_WRITE) { 742 $SSL_ERROR = SSL_WANT_WRITE; 743 } else { 744 return $err; 745 } 746 $! ||= EWOULDBLOCK; 747 ${*$self}{_SSL_last_err} = [$SSL_ERROR,4] if ref($self); 748 Net::SSLeay::ERR_clear_error(); 749 return 0; 750} 751 752 753# Call to connect occurs when a new client socket is made using IO::Socket::* 754sub connect { 755 my $self = shift || return _invalid_object(); 756 return $self if ${*$self}{'_SSL_opened'}; # already connected 757 758 if ( ! ${*$self}{'_SSL_opening'} ) { 759 # call SUPER::connect if the underlying socket is not connected 760 # if this fails this might not be an error (e.g. if $! = EINPROGRESS 761 # and socket is nonblocking this is normal), so keep any error 762 # handling to the client 763 $DEBUG>=2 && DEBUG('socket not yet connected' ); 764 $self->SUPER::connect(@_) || return; 765 $DEBUG>=2 && DEBUG('socket connected' ); 766 767 # IO::Socket works around systems, which return EISCONN or similar 768 # on non-blocking re-connect by returning true, even if $! is set 769 # but it does not clear $!, so do it here 770 $! = undef; 771 772 # don't continue with connect_SSL if SSL_startHandshake is set to 0 773 my $sh = ${*$self}{_SSL_arguments}{SSL_startHandshake}; 774 return $self if defined $sh && ! $sh; 775 } 776 return $self->connect_SSL; 777} 778 779 780sub connect_SSL { 781 my $self = shift; 782 my $args = @_>1 ? {@_}: $_[0]||{}; 783 return $self if ${*$self}{'_SSL_opened'}; # already connected 784 785 my ($ssl,$ctx); 786 if ( ! ${*$self}{'_SSL_opening'} ) { 787 # start ssl connection 788 $DEBUG>=2 && DEBUG('ssl handshake not started' ); 789 ${*$self}{'_SSL_opening'} = 1; 790 my $arg_hash = ${*$self}{'_SSL_arguments'}; 791 792 my $fileno = ${*$self}{'_SSL_fileno'} = fileno($self); 793 return $self->_internal_error("Socket has no fileno",9) 794 if ! defined $fileno; 795 796 $ctx = ${*$self}{'_SSL_ctx'}; # Reference to real context 797 $ssl = ${*$self}{'_SSL_object'} = Net::SSLeay::new($ctx->{context}) 798 || return $self->error("SSL structure creation failed"); 799 $CREATED_IN_THIS_THREAD{$ssl} = 1 if $use_threads; 800 $SSL_OBJECT{$ssl} = [$self,0]; 801 weaken($SSL_OBJECT{$ssl}[0]); 802 803 if ($ctx->{session_cache}) { 804 $arg_hash->{SSL_session_key} ||= do { 805 my $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} 806 || $self->_update_peer; 807 my $port = $arg_hash->{PeerPort} || $arg_hash->{PeerService}; 808 $port ? "$host:$port" : $host; 809 } 810 } 811 812 Net::SSLeay::set_fd($ssl, $fileno) 813 || return $self->error("SSL filehandle association failed"); 814 815 if ( $can_client_sni ) { 816 my $host; 817 if ( exists $arg_hash->{SSL_hostname} ) { 818 # explicitly given 819 # can be set to undef/'' to not use extension 820 $host = $arg_hash->{SSL_hostname} 821 } elsif ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) { 822 # implicitly given 823 $host =~s{:[a-zA-Z0-9_\-]+$}{}; 824 # should be hostname, not IPv4/6 825 $host = undef if $host !~m{[a-z_]}i or $host =~m{:}; 826 } 827 # define SSL_CTRL_SET_TLSEXT_HOSTNAME 55 828 # define TLSEXT_NAMETYPE_host_name 0 829 if ($host) { 830 $DEBUG>=2 && DEBUG("using SNI with hostname $host"); 831 Net::SSLeay::ctrl($ssl,55,0,$host); 832 } else { 833 $DEBUG>=2 && DEBUG("not using SNI because hostname is unknown"); 834 } 835 } elsif ( $arg_hash->{SSL_hostname} ) { 836 return $self->_internal_error( 837 "Client side SNI not supported for this openssl",9); 838 } else { 839 $DEBUG>=2 && DEBUG("not using SNI because openssl is too old"); 840 } 841 842 $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} || $self->_update_peer; 843 if ( $ctx->{verify_name_ref} ) { 844 # need target name for update 845 my $host = $arg_hash->{SSL_verifycn_name} 846 || $arg_hash->{SSL_hostname}; 847 if ( ! defined $host ) { 848 if ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) { 849 $host =~s{:[a-zA-Z0-9_\-]+$}{}; 850 } 851 } 852 ${$ctx->{verify_name_ref}} = $host; 853 } 854 855 my $ocsp = $ctx->{ocsp_mode}; 856 if ( $ocsp & SSL_OCSP_NO_STAPLE ) { 857 # don't try stapling 858 } elsif ( ! $can_ocsp_staple ) { 859 croak("OCSP stapling not support") if $ocsp & SSL_OCSP_MUST_STAPLE; 860 } elsif ( $ocsp & (SSL_OCSP_TRY_STAPLE|SSL_OCSP_MUST_STAPLE)) { 861 # staple by default if verification enabled 862 ${*$self}{_SSL_ocsp_verify} = undef; 863 Net::SSLeay::set_tlsext_status_type($ssl, 864 Net::SSLeay::TLSEXT_STATUSTYPE_ocsp()); 865 $DEBUG>=2 && DEBUG("request OCSP stapling"); 866 } 867 868 if ($ctx->{session_cache} and my $session = 869 $ctx->{session_cache}->get_session($arg_hash->{SSL_session_key}) 870 ) { 871 Net::SSLeay::set_session($ssl, $session); 872 } 873 } 874 875 $ssl ||= ${*$self}{'_SSL_object'}; 876 877 $SSL_ERROR = $! = undef; 878 my $timeout = exists $args->{Timeout} 879 ? $args->{Timeout} 880 : ${*$self}{io_socket_timeout}; # from IO::Socket 881 if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) { 882 $DEBUG>=2 && DEBUG( "set socket to non-blocking to enforce timeout=$timeout" ); 883 # timeout was given and socket was blocking 884 # enforce timeout with now non-blocking socket 885 } else { 886 # timeout does not apply because invalid or socket non-blocking 887 $timeout = undef; 888 $auto_retry && $auto_retry->($ssl,$self->blocking); 889 } 890 891 my $start = defined($timeout) && time(); 892 { 893 $SSL_ERROR = undef; 894 $CURRENT_SSL_OBJECT = $self; 895 $DEBUG>=3 && DEBUG("call Net::SSLeay::connect" ); 896 my $rv = Net::SSLeay::connect($ssl); 897 $CURRENT_SSL_OBJECT = undef; 898 $DEBUG>=3 && DEBUG("done Net::SSLeay::connect -> $rv" ); 899 if ( $rv < 0 ) { 900 if ( my $err = $self->_skip_rw_error( $ssl,$rv )) { 901 $self->error("SSL connect attempt failed"); 902 delete ${*$self}{'_SSL_opening'}; 903 ${*$self}{'_SSL_opened'} = -1; 904 $DEBUG>=1 && DEBUG( "fatal SSL error: $SSL_ERROR" ); 905 return $self->fatal_ssl_error(); 906 } 907 908 $DEBUG>=2 && DEBUG('ssl handshake in progress' ); 909 # connect failed because handshake needs to be completed 910 # if socket was non-blocking or no timeout was given return with this error 911 return if ! defined($timeout); 912 913 # wait until socket is readable or writable 914 my $rv; 915 if ( $timeout>0 ) { 916 my $vec = ''; 917 vec($vec,$self->fileno,1) = 1; 918 $DEBUG>=2 && DEBUG( "waiting for fd to become ready: $SSL_ERROR" ); 919 $rv = 920 $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : 921 $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : 922 undef; 923 } else { 924 $DEBUG>=2 && DEBUG("handshake failed because no more time" ); 925 $! = ETIMEDOUT 926 } 927 if ( ! $rv ) { 928 $DEBUG>=2 && DEBUG("handshake failed because socket did not became ready" ); 929 # failed because of timeout, return 930 $! ||= ETIMEDOUT; 931 delete ${*$self}{'_SSL_opening'}; 932 ${*$self}{'_SSL_opened'} = -1; 933 $self->blocking(1); # was blocking before 934 return 935 } 936 937 # socket is ready, try non-blocking connect again after recomputing timeout 938 $DEBUG>=2 && DEBUG("socket ready, retrying connect" ); 939 my $now = time(); 940 $timeout -= $now - $start; 941 $start = $now; 942 redo; 943 944 } elsif ( $rv == 0 ) { 945 delete ${*$self}{'_SSL_opening'}; 946 $DEBUG>=2 && DEBUG("connection failed - connect returned 0" ); 947 $self->error("SSL connect attempt failed because of handshake problems" ); 948 ${*$self}{'_SSL_opened'} = -1; 949 return $self->fatal_ssl_error(); 950 } 951 } 952 953 $DEBUG>=2 && DEBUG('ssl handshake done' ); 954 # ssl connect successful 955 delete ${*$self}{'_SSL_opening'}; 956 ${*$self}{'_SSL_opened'}=1; 957 if (defined($timeout)) { 958 $self->blocking(1); # reset back to blocking 959 $! = undef; # reset errors from non-blocking 960 } 961 962 $ctx ||= ${*$self}{'_SSL_ctx'}; 963 964 if ( my $ocsp_result = ${*$self}{_SSL_ocsp_verify} ) { 965 # got result from OCSP stapling 966 if ( $ocsp_result->[0] > 0 ) { 967 $DEBUG>=3 && DEBUG("got OCSP success with stapling"); 968 # successful validated 969 } elsif ( $ocsp_result->[0] < 0 ) { 970 # Permanent problem with validation because certificate 971 # is either self-signed or the issuer cannot be found. 972 # Ignore here, because this will cause other errors too. 973 $DEBUG>=3 && DEBUG("got OCSP failure with stapling: %s", 974 $ocsp_result->[1]); 975 } else { 976 # definitely revoked 977 $DEBUG>=3 && DEBUG("got OCSP revocation with stapling: %s", 978 $ocsp_result->[1]); 979 $self->_internal_error($ocsp_result->[1],5); 980 return $self->fatal_ssl_error(); 981 } 982 } elsif ( $ctx->{ocsp_mode} & SSL_OCSP_MUST_STAPLE ) { 983 $self->_internal_error("did not receive the required stapled OCSP response",5); 984 return $self->fatal_ssl_error(); 985 } 986 987 if (!%sess_cb and $ctx->{session_cache} 988 and my $session = Net::SSLeay::get1_session($ssl)) { 989 $ctx->{session_cache}->add_session( 990 ${*$self}{_SSL_arguments}{SSL_session_key}, 991 $session 992 ); 993 } 994 995 tie *{$self}, "IO::Socket::SSL::SSL_HANDLE", $self; 996 997 return $self; 998} 999 1000# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'} 1001# this can be the case if start_SSL is called with a normal IO::Socket::INET 1002# so that PeerAddr|PeerPort are not set from args 1003# returns PeerAddr 1004sub _update_peer { 1005 my $self = shift; 1006 my $arg_hash = ${*$self}{'_SSL_arguments'}; 1007 eval { 1008 my $sockaddr = getpeername( $self ); 1009 my $af = sockaddr_family($sockaddr); 1010 if( CAN_IPV6 && $af == AF_INET6 ) { 1011 my (undef, $host, $port) = _getnameinfo($sockaddr, 1012 NI_NUMERICHOST | NI_NUMERICSERV); 1013 $arg_hash->{PeerPort} = $port; 1014 $arg_hash->{PeerAddr} = $host; 1015 } else { 1016 my ($port,$addr) = sockaddr_in( $sockaddr); 1017 $arg_hash->{PeerPort} = $port; 1018 $arg_hash->{PeerAddr} = inet_ntoa( $addr ); 1019 } 1020 } 1021} 1022 1023#Call to accept occurs when a new client connects to a server using 1024#IO::Socket::SSL 1025sub accept { 1026 my $self = shift || return _invalid_object(); 1027 my $class = shift || 'IO::Socket::SSL'; 1028 1029 my $socket = ${*$self}{'_SSL_opening'}; 1030 if ( ! $socket ) { 1031 # underlying socket not done 1032 $DEBUG>=2 && DEBUG('no socket yet' ); 1033 $socket = $self->SUPER::accept($class) || return; 1034 $DEBUG>=2 && DEBUG('accept created normal socket '.$socket ); 1035 1036 # don't continue with accept_SSL if SSL_startHandshake is set to 0 1037 my $sh = ${*$self}{_SSL_arguments}{SSL_startHandshake}; 1038 if (defined $sh && ! $sh) { 1039 ${*$socket}{_SSL_ctx} = ${*$self}{_SSL_ctx}; 1040 ${*$socket}{_SSL_arguments} = { 1041 %{${*$self}{_SSL_arguments}}, 1042 SSL_server => 0, 1043 }; 1044 $DEBUG>=2 && DEBUG('will not start SSL handshake yet'); 1045 return wantarray ? ($socket, getpeername($socket) ) : $socket 1046 } 1047 } 1048 1049 $self->accept_SSL($socket) || return; 1050 $DEBUG>=2 && DEBUG('accept_SSL ok' ); 1051 1052 return wantarray ? ($socket, getpeername($socket) ) : $socket; 1053} 1054 1055sub accept_SSL { 1056 my $self = shift; 1057 my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self; 1058 my $args = @_>1 ? {@_}: $_[0]||{}; 1059 1060 my $ssl; 1061 if ( ! ${*$self}{'_SSL_opening'} ) { 1062 $DEBUG>=2 && DEBUG('starting sslifying' ); 1063 ${*$self}{'_SSL_opening'} = $socket; 1064 if ($socket != $self) { 1065 ${*$socket}{_SSL_ctx} = ${*$self}{_SSL_ctx}; 1066 ${*$socket}{_SSL_arguments} = { 1067 %{${*$self}{_SSL_arguments}}, 1068 SSL_server => 0 1069 }; 1070 } 1071 1072 my $fileno = ${*$socket}{'_SSL_fileno'} = fileno($socket); 1073 return $socket->_internal_error("Socket has no fileno",9) 1074 if ! defined $fileno; 1075 1076 $ssl = ${*$socket}{_SSL_object} = 1077 Net::SSLeay::new(${*$socket}{_SSL_ctx}{context}) 1078 || return $socket->error("SSL structure creation failed"); 1079 $CREATED_IN_THIS_THREAD{$ssl} = 1 if $use_threads; 1080 $SSL_OBJECT{$ssl} = [$socket,1]; 1081 weaken($SSL_OBJECT{$ssl}[0]); 1082 1083 Net::SSLeay::set_fd($ssl, $fileno) 1084 || return $socket->error("SSL filehandle association failed"); 1085 } 1086 1087 $ssl ||= ${*$socket}{'_SSL_object'}; 1088 1089 $SSL_ERROR = $! = undef; 1090 #$DEBUG>=2 && DEBUG('calling ssleay::accept' ); 1091 1092 my $timeout = exists $args->{Timeout} 1093 ? $args->{Timeout} 1094 : ${*$self}{io_socket_timeout}; # from IO::Socket 1095 if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) { 1096 # timeout was given and socket was blocking 1097 # enforce timeout with now non-blocking socket 1098 } else { 1099 # timeout does not apply because invalid or socket non-blocking 1100 $timeout = undef; 1101 $auto_retry && $auto_retry->($ssl,$socket->blocking); 1102 } 1103 1104 my $start = defined($timeout) && time(); 1105 { 1106 $SSL_ERROR = undef; 1107 $CURRENT_SSL_OBJECT = $self; 1108 my $rv = Net::SSLeay::accept($ssl); 1109 $CURRENT_SSL_OBJECT = undef; 1110 $DEBUG>=3 && DEBUG( "Net::SSLeay::accept -> $rv" ); 1111 if ( $rv < 0 ) { 1112 if ( my $err = $socket->_skip_rw_error( $ssl,$rv )) { 1113 $socket->error("SSL accept attempt failed"); 1114 delete ${*$self}{'_SSL_opening'}; 1115 ${*$socket}{'_SSL_opened'} = -1; 1116 return $socket->fatal_ssl_error(); 1117 } 1118 1119 # accept failed because handshake needs to be completed 1120 # if socket was non-blocking or no timeout was given return with this error 1121 return if ! defined($timeout); 1122 1123 # wait until socket is readable or writable 1124 my $rv; 1125 if ( $timeout>0 ) { 1126 my $vec = ''; 1127 vec($vec,$socket->fileno,1) = 1; 1128 $rv = 1129 $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : 1130 $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : 1131 undef; 1132 } else { 1133 $! = ETIMEDOUT 1134 } 1135 if ( ! $rv ) { 1136 # failed because of timeout, return 1137 $! ||= ETIMEDOUT; 1138 delete ${*$self}{'_SSL_opening'}; 1139 ${*$socket}{'_SSL_opened'} = -1; 1140 $socket->blocking(1); # was blocking before 1141 return 1142 } 1143 1144 # socket is ready, try non-blocking accept again after recomputing timeout 1145 my $now = time(); 1146 $timeout -= $now - $start; 1147 $start = $now; 1148 redo; 1149 1150 } elsif ( $rv == 0 ) { 1151 $socket->error("SSL accept attempt failed because of handshake problems" ); 1152 delete ${*$self}{'_SSL_opening'}; 1153 ${*$socket}{'_SSL_opened'} = -1; 1154 return $socket->fatal_ssl_error(); 1155 } 1156 } 1157 1158 $DEBUG>=2 && DEBUG('handshake done, socket ready' ); 1159 # socket opened 1160 delete ${*$self}{'_SSL_opening'}; 1161 ${*$socket}{'_SSL_opened'} = 1; 1162 if (defined($timeout)) { 1163 $socket->blocking(1); # reset back to blocking 1164 $! = undef; # reset errors from non-blocking 1165 } 1166 1167 tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket; 1168 1169 return $socket; 1170} 1171 1172 1173####### I/O subroutines ######################## 1174 1175if ($auto_retry) { 1176 *blocking = sub { 1177 my $self = shift; 1178 { @_ && $auto_retry->(${*$self}{_SSL_object} || last, @_); } 1179 return $self->SUPER::blocking(@_); 1180 }; 1181} 1182 1183sub _generic_read { 1184 my ($self, $read_func, undef, $length, $offset) = @_; 1185 my $ssl = ${*$self}{_SSL_object} || return; 1186 my $buffer=\$_[2]; 1187 1188 $SSL_ERROR = $! = undef; 1189 my ($data,$rwerr) = $read_func->($ssl, $length); 1190 while ( ! defined($data)) { 1191 if ( my $err = $self->_skip_rw_error( $ssl, defined($rwerr) ? $rwerr:-1 )) { 1192 # OpenSSL 1.1.0c+ : EOF can now result in SSL_read returning -1 and SSL_ERROR_SYSCALL 1193 # OpenSSL 3.0 : EOF can now result in SSL_read returning -1 and SSL_ERROR_SSL 1194 if (not $! and $err == $Net_SSLeay_ERROR_SSL || $err == $Net_SSLeay_ERROR_SYSCALL) { 1195 # treat as EOF 1196 $data = ''; 1197 last; 1198 } 1199 $self->error("SSL read error"); 1200 } 1201 return; 1202 } 1203 1204 $length = length($data); 1205 $$buffer = '' if !defined $$buffer; 1206 $offset ||= 0; 1207 if ($offset>length($$buffer)) { 1208 $$buffer.="\0" x ($offset-length($$buffer)); #mimic behavior of read 1209 } 1210 1211 substr($$buffer, $offset, length($$buffer), $data); 1212 return $length; 1213} 1214 1215sub read { 1216 my $self = shift; 1217 ${*$self}{_SSL_object} && return _generic_read($self, 1218 $self->blocking ? \&Net::SSLeay::ssl_read_all : \&Net::SSLeay::read, 1219 @_ 1220 ); 1221 1222 # fall back to plain read if we are not required to use SSL yet 1223 return $self->SUPER::read(@_); 1224} 1225 1226# contrary to the behavior of read sysread can read partial data 1227sub sysread { 1228 my $self = shift; 1229 ${*$self}{_SSL_object} && return _generic_read( $self, 1230 \&Net::SSLeay::read, @_ ); 1231 1232 # fall back to plain sysread if we are not required to use SSL yet 1233 my $rv = $self->SUPER::sysread(@_); 1234 return $rv; 1235} 1236 1237sub peek { 1238 my $self = shift; 1239 ${*$self}{_SSL_object} && return _generic_read( $self, 1240 \&Net::SSLeay::peek, @_ ); 1241 1242 # fall back to plain peek if we are not required to use SSL yet 1243 # emulate peek with recv(...,MS_PEEK) - peek(buf,len,offset) 1244 return if ! defined recv($self,my $buf,$_[1],MSG_PEEK); 1245 $_[0] = $_[2] ? substr($_[0],0,$_[2]).$buf : $buf; 1246 return length($buf); 1247} 1248 1249 1250sub _generic_write { 1251 my ($self, $write_all, undef, $length, $offset) = @_; 1252 1253 my $ssl = ${*$self}{_SSL_object} || return; 1254 my $buffer = \$_[2]; 1255 1256 my $buf_len = length($$buffer); 1257 $length ||= $buf_len; 1258 $offset ||= 0; 1259 return $self->_internal_error("Invalid offset for SSL write",9) 1260 if $offset>$buf_len; 1261 return 0 if ($offset == $buf_len); 1262 1263 $SSL_ERROR = $! = undef; 1264 my $written; 1265 if ( $write_all ) { 1266 my $data = $length < $buf_len-$offset ? substr($$buffer, $offset, $length) : $$buffer; 1267 ($written, my $errs) = Net::SSLeay::ssl_write_all($ssl, $data); 1268 # ssl_write_all returns number of bytes written 1269 $written = undef if ! $written && $errs; 1270 } else { 1271 $written = Net::SSLeay::write_partial( $ssl,$offset,$length,$$buffer ); 1272 # write_partial does SSL_write which returns -1 on error 1273 $written = undef if $written < 0; 1274 } 1275 if ( !defined($written) ) { 1276 if ( my $err = $self->_skip_rw_error( $ssl,-1 )) { 1277 # if $! is not set with ERROR_SYSCALL then report as EPIPE 1278 $! ||= EPIPE if $err == $Net_SSLeay_ERROR_SYSCALL; 1279 $self->error("SSL write error ($err)"); 1280 } 1281 return; 1282 } 1283 1284 return $written; 1285} 1286 1287# if socket is blocking write() should return only on error or 1288# if all data are written 1289sub write { 1290 my $self = shift; 1291 ${*$self}{_SSL_object} && return _generic_write( $self, 1292 scalar($self->blocking),@_ ); 1293 1294 # fall back to plain write if we are not required to use SSL yet 1295 return $self->SUPER::write(@_); 1296} 1297 1298# contrary to write syswrite() returns already if only 1299# a part of the data is written 1300sub syswrite { 1301 my $self = shift; 1302 ${*$self}{_SSL_object} && return _generic_write($self,0,@_); 1303 1304 # fall back to plain syswrite if we are not required to use SSL yet 1305 return $self->SUPER::syswrite(@_); 1306} 1307 1308sub print { 1309 my $self = shift; 1310 my $string = join(($, or ''), @_, ($\ or '')); 1311 return $self->write( $string ); 1312} 1313 1314sub printf { 1315 my ($self,$format) = (shift,shift); 1316 return $self->write(sprintf($format, @_)); 1317} 1318 1319sub getc { 1320 my ($self, $buffer) = (shift, undef); 1321 return $buffer if $self->read($buffer, 1, 0); 1322} 1323 1324sub readline { 1325 my $self = shift; 1326 ${*$self}{_SSL_object} or return $self->SUPER::getline; 1327 1328 if ( not defined $/ or wantarray) { 1329 # read all and split 1330 1331 my $buf = ''; 1332 while (1) { 1333 my $rv = $self->sysread($buf,2**16,length($buf)); 1334 if ( ! defined $rv ) { 1335 next if $! == EINTR; # retry 1336 last if $! == EWOULDBLOCK || $! == EAGAIN; # use everything so far 1337 return; # return error 1338 } elsif ( ! $rv ) { 1339 last 1340 } 1341 } 1342 1343 if ( ! defined $/ ) { 1344 return $buf 1345 } elsif ( ref($/)) { 1346 my $size = ${$/}; 1347 die "bad value in ref \$/: $size" unless $size>0; 1348 return $buf=~m{\G(.{1,$size})}g; 1349 } elsif ( $/ eq '' ) { 1350 return $buf =~m{\G(.*\n\n+|.+)}g; 1351 } else { 1352 return $buf =~m{\G(.*$/|.+)}g; 1353 } 1354 } 1355 1356 # read only one line 1357 if ( ref($/) ) { 1358 my $size = ${$/}; 1359 # read record of $size bytes 1360 die "bad value in ref \$/: $size" unless $size>0; 1361 my $buf = ''; 1362 while ( $size>length($buf)) { 1363 my $rv = $self->sysread($buf,$size-length($buf),length($buf)); 1364 if ( ! defined $rv ) { 1365 next if $! == EINTR; # retry 1366 last if $! == EWOULDBLOCK || $! == EAGAIN; # use everything so far 1367 return; # return error 1368 } elsif ( ! $rv ) { 1369 last 1370 } 1371 } 1372 return $buf; 1373 } 1374 1375 my ($delim0,$delim1) = $/ eq '' ? ("\n\n","\n"):($/,''); 1376 1377 # find first occurrence of $delim0 followed by as much as possible $delim1 1378 my $buf = ''; 1379 my $eod = 0; # pointer into $buf after $delim0 $delim1* 1380 my $ssl = $self->_get_ssl_object or return; 1381 while (1) { 1382 1383 # wait until we have more data or eof 1384 my $poke = Net::SSLeay::peek($ssl,1); 1385 if ( ! defined $poke or $poke eq '' ) { 1386 next if $! == EINTR; 1387 } 1388 1389 my $skip = 0; 1390 1391 # peek into available data w/o reading 1392 my $pending = Net::SSLeay::pending($ssl); 1393 if ( $pending and 1394 ( my $pb = Net::SSLeay::peek( $ssl,$pending )) ne '' ) { 1395 $buf .= $pb 1396 } else { 1397 return $buf eq '' ? ():$buf; 1398 } 1399 if ( !$eod ) { 1400 my $pos = index( $buf,$delim0 ); 1401 if ( $pos<0 ) { 1402 $skip = $pending 1403 } else { 1404 $eod = $pos + length($delim0); # pos after delim0 1405 } 1406 } 1407 1408 if ( $eod ) { 1409 if ( $delim1 ne '' ) { 1410 # delim0 found, check for as much delim1 as possible 1411 while ( index( $buf,$delim1,$eod ) == $eod ) { 1412 $eod+= length($delim1); 1413 } 1414 } 1415 $skip = $pending - ( length($buf) - $eod ); 1416 } 1417 1418 # remove data from $self which I already have in buf 1419 while ( $skip>0 ) { 1420 if ($self->sysread(my $p,$skip,0)) { 1421 $skip -= length($p); 1422 next; 1423 } 1424 $! == EINTR or last; 1425 } 1426 1427 if ( $eod and ( $delim1 eq '' or $eod < length($buf))) { 1428 # delim0 found and there can be no more delim1 pending 1429 last 1430 } 1431 } 1432 return substr($buf,0,$eod); 1433} 1434 1435sub close { 1436 my $self = shift || return _invalid_object(); 1437 my $close_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 1438 1439 return if ! $self->stop_SSL( 1440 SSL_fast_shutdown => 1, 1441 %$close_args, 1442 _SSL_ioclass_downgrade => 0, 1443 ); 1444 1445 if ( ! $close_args->{_SSL_in_DESTROY} ) { 1446 untie( *$self ); 1447 undef ${*$self}{_SSL_fileno}; 1448 return $self->SUPER::close; 1449 } 1450 return 1; 1451} 1452 1453sub is_SSL { 1454 my $self = pop; 1455 return ${*$self}{_SSL_object} && 1 1456} 1457 1458sub stop_SSL { 1459 my $self = shift || return _invalid_object(); 1460 my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 1461 $stop_args->{SSL_no_shutdown} = 1 if ! ${*$self}{_SSL_opened}; 1462 1463 if (my $ssl = ${*$self}{'_SSL_object'}) { 1464 if (delete ${*$self}{'_SSL_opening'}) { 1465 # just destroy the object further below 1466 } elsif ( ! $stop_args->{SSL_no_shutdown} ) { 1467 my $status = Net::SSLeay::get_shutdown($ssl); 1468 1469 my $timeout = 1470 not($self->blocking) ? undef : 1471 exists $stop_args->{Timeout} ? $stop_args->{Timeout} : 1472 ${*$self}{io_socket_timeout}; # from IO::Socket 1473 if ($timeout) { 1474 $self->blocking(0); 1475 $timeout += time(); 1476 } 1477 1478 while (1) { 1479 if ( $status & SSL_SENT_SHUTDOWN and 1480 # don't care for received if fast shutdown 1481 $status & SSL_RECEIVED_SHUTDOWN 1482 || $stop_args->{SSL_fast_shutdown}) { 1483 # shutdown complete 1484 last; 1485 } 1486 if ((${*$self}{'_SSL_opened'}||0) <= 0) { 1487 # not really open, thus don't expect shutdown to return 1488 # something meaningful 1489 last; 1490 } 1491 1492 # initiate or complete shutdown 1493 local $SIG{PIPE} = 'IGNORE'; 1494 my $rv = Net::SSLeay::shutdown($ssl); 1495 if ( $rv < 0 ) { 1496 # non-blocking socket? 1497 if ( ! $timeout ) { 1498 $self->_skip_rw_error( $ssl,$rv ); 1499 # need to try again 1500 return; 1501 } 1502 1503 # don't use _skip_rw_error so that existing error does 1504 # not get cleared 1505 my $wait = $timeout - time(); 1506 last if $wait<=0; 1507 vec(my $vec = '',fileno($self),1) = 1; 1508 my $err = Net::SSLeay::get_error($ssl,$rv); 1509 if ( $err == $Net_SSLeay_ERROR_WANT_READ) { 1510 select($vec,undef,undef,$wait) 1511 } elsif ( $err == $Net_SSLeay_ERROR_WANT_READ) { 1512 select(undef,$vec,undef,$wait) 1513 } else { 1514 last; 1515 } 1516 } 1517 1518 $status |= SSL_SENT_SHUTDOWN; 1519 $status |= SSL_RECEIVED_SHUTDOWN if $rv>0; 1520 } 1521 $self->blocking(1) if $timeout; 1522 } 1523 1524 # destroy allocated objects for SSL and untie 1525 # do not destroy CTX unless explicitly specified 1526 Net::SSLeay::free($ssl); 1527 if (my $cert = delete ${*$self}{'_SSL_certificate'}) { 1528 Net::SSLeay::X509_free($cert); 1529 } 1530 delete ${*$self}{_SSL_object}; 1531 ${*$self}{'_SSL_opened'} = 0; 1532 delete $SSL_OBJECT{$ssl}; 1533 delete $CREATED_IN_THIS_THREAD{$ssl}; 1534 untie(*$self); 1535 } 1536 1537 if ($stop_args->{'SSL_ctx_free'}) { 1538 my $ctx = delete ${*$self}{'_SSL_ctx'}; 1539 $ctx && $ctx->DESTROY(); 1540 } 1541 1542 1543 if ( ! $stop_args->{_SSL_in_DESTROY} ) { 1544 1545 my $downgrade = $stop_args->{_SSL_ioclass_downgrade}; 1546 if ( $downgrade || ! defined $downgrade ) { 1547 # rebless to original class from start_SSL 1548 if ( my $orig_class = delete ${*$self}{'_SSL_ioclass_upgraded'} ) { 1549 bless $self,$orig_class; 1550 # FIXME: if original class was tied too we need to restore the tie 1551 # remove all _SSL related from *$self 1552 my @sslkeys = grep { m{^_?SSL_} } keys %{*$self}; 1553 delete @{*$self}{@sslkeys} if @sslkeys; 1554 } 1555 } 1556 } 1557 return 1; 1558} 1559 1560 1561sub fileno { 1562 my $self = shift; 1563 my $fn = ${*$self}{'_SSL_fileno'}; 1564 return defined($fn) ? $fn : $self->SUPER::fileno(); 1565} 1566 1567 1568####### IO::Socket::SSL specific functions ####### 1569# _get_ssl_object is for internal use ONLY! 1570sub _get_ssl_object { 1571 my $self = shift; 1572 return ${*$self}{'_SSL_object'} || 1573 IO::Socket::SSL->_internal_error("Undefined SSL object",9); 1574} 1575 1576# _get_ctx_object is for internal use ONLY! 1577sub _get_ctx_object { 1578 my $self = shift; 1579 my $ctx_object = ${*$self}{_SSL_ctx}; 1580 return $ctx_object && $ctx_object->{context}; 1581} 1582 1583# default error for undefined arguments 1584sub _invalid_object { 1585 return IO::Socket::SSL->_internal_error("Undefined IO::Socket::SSL object",9); 1586} 1587 1588 1589sub pending { 1590 my $ssl = shift()->_get_ssl_object || return; 1591 return Net::SSLeay::pending($ssl); 1592} 1593 1594sub start_SSL { 1595 my ($class,$socket) = (shift,shift); 1596 return $class->_internal_error("Not a socket",9) if ! ref($socket); 1597 my $arg_hash = @_ == 1 ? $_[0] : {@_}; 1598 my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :(); 1599 my $original_class = ref($socket); 1600 if ( ! $original_class ) { 1601 $socket = ($original_class = $ISA[0])->new_from_fd($socket,'<+') 1602 or return $class->_internal_error( 1603 "creating $original_class from file handle failed",9); 1604 } 1605 my $original_fileno = (UNIVERSAL::can($socket, "fileno")) 1606 ? $socket->fileno : CORE::fileno($socket); 1607 return $class->_internal_error("Socket has no fileno",9) 1608 if ! defined $original_fileno; 1609 1610 bless $socket, $class; 1611 $socket->configure_SSL($arg_hash) or bless($socket, $original_class) && return; 1612 1613 ${*$socket}{'_SSL_fileno'} = $original_fileno; 1614 ${*$socket}{'_SSL_ioclass_upgraded'} = $original_class 1615 if $class ne $original_class; 1616 1617 my $start_handshake = $arg_hash->{SSL_startHandshake}; 1618 if ( ! defined($start_handshake) || $start_handshake ) { 1619 # if we have no callback force blocking mode 1620 $DEBUG>=2 && DEBUG( "start handshake" ); 1621 my $was_blocking = $socket->blocking(1); 1622 my $result = ${*$socket}{'_SSL_arguments'}{SSL_server} 1623 ? $socket->accept_SSL(%to) 1624 : $socket->connect_SSL(%to); 1625 if ( $result ) { 1626 $socket->blocking(0) if ! $was_blocking; 1627 return $socket; 1628 } else { 1629 # upgrade to SSL failed, downgrade socket to original class 1630 if ( $original_class ) { 1631 bless($socket,$original_class); 1632 $socket->blocking(0) if ! $was_blocking 1633 && $socket->can('blocking'); 1634 } 1635 return; 1636 } 1637 } else { 1638 $DEBUG>=2 && DEBUG( "don't start handshake: $socket" ); 1639 return $socket; # just return upgraded socket 1640 } 1641 1642} 1643 1644sub new_from_fd { 1645 my ($class, $fd) = (shift,shift); 1646 # Check for accidental inclusion of MODE in the argument list 1647 if (length($_[0]) < 4) { 1648 (my $mode = $_[0]) =~ tr/+<>//d; 1649 shift unless length($mode); 1650 } 1651 my $handle = $ISA[0]->new_from_fd($fd, '+<') 1652 || return($class->error("Could not create socket from file descriptor.")); 1653 1654 # Annoying workaround for Perl 5.6.1 and below: 1655 $handle = $ISA[0]->new_from_fd($handle, '+<'); 1656 1657 return $class->start_SSL($handle, @_); 1658} 1659 1660 1661sub dump_peer_certificate { 1662 my $ssl = shift()->_get_ssl_object || return; 1663 return Net::SSLeay::dump_peer_certificate($ssl); 1664} 1665 1666if ( defined &Net::SSLeay::get_peer_cert_chain 1667 && $netssleay_version >= 1.58 ) { 1668 *peer_certificates = sub { 1669 my $self = shift; 1670 my $ssl = $self->_get_ssl_object || return; 1671 my @chain = Net::SSLeay::get_peer_cert_chain($ssl); 1672 @chain = () if @chain && !$self->peer_certificate; # work around #96013 1673 if ( ${*$self}{_SSL_arguments}{SSL_server} ) { 1674 # in the client case the chain contains the peer certificate, 1675 # in the server case not 1676 # this one has an increased reference counter, the other not 1677 if ( my $peer = Net::SSLeay::get_peer_certificate($ssl)) { 1678 Net::SSLeay::X509_free($peer); 1679 unshift @chain, $peer; 1680 } 1681 } 1682 return @chain; 1683 1684 } 1685} else { 1686 *peer_certificates = sub { 1687 die "peer_certificates needs Net::SSLeay>=1.58"; 1688 } 1689} 1690 1691{ 1692 my %dispatcher = ( 1693 issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 1694 subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, 1695 commonName => sub { 1696 my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( 1697 Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); 1698 $cn; 1699 }, 1700 subjectAltNames => sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }, 1701 ); 1702 1703 # alternative names 1704 $dispatcher{authority} = $dispatcher{issuer}; 1705 $dispatcher{owner} = $dispatcher{subject}; 1706 $dispatcher{cn} = $dispatcher{commonName}; 1707 1708 sub peer_certificate { 1709 my ($self,$field,$reload) = @_; 1710 my $ssl = $self->_get_ssl_object or return; 1711 1712 Net::SSLeay::X509_free(delete ${*$self}{_SSL_certificate}) 1713 if $reload && ${*$self}{_SSL_certificate}; 1714 my $cert = ${*$self}{_SSL_certificate} 1715 ||= Net::SSLeay::get_peer_certificate($ssl) 1716 or return $self->error("Could not retrieve peer certificate"); 1717 1718 if ($field) { 1719 my $sub = $dispatcher{$field} or croak 1720 "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). 1721 "\nMaybe you need to upgrade your Net::SSLeay"; 1722 return $sub->($cert); 1723 } else { 1724 return $cert 1725 } 1726 } 1727 1728 sub sock_certificate { 1729 my ($self,$field) = @_; 1730 my $ssl = $self->_get_ssl_object || return; 1731 my $cert = Net::SSLeay::get_certificate( $ssl ) || return; 1732 if ($field) { 1733 my $sub = $dispatcher{$field} or croak 1734 "invalid argument for sock_certificate, valid are: ".join( " ",keys %dispatcher ). 1735 "\nMaybe you need to upgrade your Net::SSLeay"; 1736 return $sub->($cert); 1737 } else { 1738 return $cert 1739 } 1740 } 1741 1742 1743 # known schemes, possible attributes are: 1744 # - wildcards_in_alt (0, 'full_label', 'anywhere') 1745 # - wildcards_in_cn (0, 'full_label', 'anywhere') 1746 # - check_cn (0, 'always', 'when_only') 1747 # unfortunately there are a lot of different schemes used, see RFC 6125 for a 1748 # summary, which references all of the following except RFC4217/ftp 1749 1750 my %scheme = ( 1751 none => {}, # do not check 1752 # default set is a superset of all the others and thus worse than a more 1753 # specific set, but much better than not verifying name at all 1754 default => { 1755 wildcards_in_cn => 'anywhere', 1756 wildcards_in_alt => 'anywhere', 1757 check_cn => 'always', 1758 ip_in_cn => 1, 1759 }, 1760 ); 1761 1762 for(qw( 1763 rfc2818 1764 rfc3920 xmpp 1765 rfc4217 ftp 1766 )) { 1767 $scheme{$_} = { 1768 wildcards_in_cn => 'anywhere', 1769 wildcards_in_alt => 'anywhere', 1770 check_cn => 'when_only', 1771 } 1772 } 1773 1774 for(qw(www http)) { 1775 $scheme{$_} = { 1776 wildcards_in_cn => 'anywhere', 1777 wildcards_in_alt => 'anywhere', 1778 check_cn => 'when_only', 1779 ip_in_cn => 4, 1780 } 1781 } 1782 1783 for(qw( 1784 rfc4513 ldap 1785 )) { 1786 $scheme{$_} = { 1787 wildcards_in_cn => 0, 1788 wildcards_in_alt => 'full_label', 1789 check_cn => 'always', 1790 }; 1791 } 1792 1793 for(qw( 1794 rfc2595 smtp 1795 rfc4642 imap pop3 acap 1796 rfc5539 nntp 1797 rfc5538 netconf 1798 rfc5425 syslog 1799 rfc5953 snmp 1800 )) { 1801 $scheme{$_} = { 1802 wildcards_in_cn => 'full_label', 1803 wildcards_in_alt => 'full_label', 1804 check_cn => 'always' 1805 }; 1806 } 1807 for(qw( 1808 rfc5971 gist 1809 )) { 1810 $scheme{$_} = { 1811 wildcards_in_cn => 'full_label', 1812 wildcards_in_alt => 'full_label', 1813 check_cn => 'when_only', 1814 }; 1815 } 1816 1817 for(qw( 1818 rfc5922 sip 1819 )) { 1820 $scheme{$_} = { 1821 wildcards_in_cn => 0, 1822 wildcards_in_alt => 0, 1823 check_cn => 'always', 1824 }; 1825 } 1826 1827 1828 # function to verify the hostname 1829 # 1830 # as every application protocol has its own rules to do this 1831 # we provide some default rules as well as a user-defined 1832 # callback 1833 1834 sub verify_hostname_of_cert { 1835 my $identity = shift; 1836 my $cert = shift; 1837 my $scheme = shift || 'default'; 1838 my $publicsuffix = shift; 1839 if ( ! ref($scheme) ) { 1840 $DEBUG>=3 && DEBUG( "scheme=$scheme cert=$cert" ); 1841 $scheme = $scheme{$scheme} || croak("scheme $scheme not defined"); 1842 } 1843 1844 return 1 if ! %$scheme; # 'none' 1845 $identity =~s{\.+$}{}; # ignore absolutism 1846 1847 # get data from certificate 1848 my $commonName = $dispatcher{cn}->($cert); 1849 my @altNames = $dispatcher{subjectAltNames}->($cert); 1850 $DEBUG>=3 && DEBUG("identity=$identity cn=$commonName alt=@altNames" ); 1851 1852 if ( my $sub = $scheme->{callback} ) { 1853 # use custom callback 1854 return $sub->($identity,$commonName,@altNames); 1855 } 1856 1857 # is the given hostname an IP address? Then we have to convert to network byte order [RFC791][RFC2460] 1858 1859 my $ipn; 1860 if ( CAN_IPV6 and $identity =~m{:} ) { 1861 # no IPv4 or hostname have ':' in it, try IPv6. 1862 $identity =~m{[^\da-fA-F:\.]} and return; # invalid characters in name 1863 $ipn = inet_pton(AF_INET6,$identity) or return; # invalid name 1864 } elsif ( my @ip = $identity =~m{^(\d+)(?:\.(\d+)\.(\d+)\.(\d+)|[\d\.]*)$} ) { 1865 # check for invalid IP/hostname 1866 return if 4 != @ip or 4 != grep { defined($_) && $_<256 } @ip; 1867 $ipn = pack("CCCC",@ip); 1868 } else { 1869 # assume hostname, check for umlauts etc 1870 if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { 1871 $identity =~m{\0} and return; # $identity has \\0 byte 1872 $identity = idn_to_ascii($identity) 1873 or return; # conversation to IDNA failed 1874 $identity =~m{[^a-zA-Z0-9_.\-]} 1875 and return; # still junk inside 1876 } 1877 } 1878 1879 # do the actual verification 1880 my $check_name = sub { 1881 my ($name,$identity,$wtyp,$publicsuffix) = @_; 1882 $name =~s{\.+$}{}; # ignore absolutism 1883 $name eq '' and return; 1884 $wtyp ||= ''; 1885 my $pattern; 1886 ### IMPORTANT! 1887 # We accept only a single wildcard and only for a single part of the FQDN 1888 # e.g. *.example.org does match www.example.org but not bla.www.example.org 1889 # The RFCs are in this regard unspecific but we don't want to have to 1890 # deal with certificates like *.com, *.co.uk or even * 1891 # see also http://nils.toedtmann.net/pub/subjectAltName.txt . 1892 # Also, we fall back to full_label matches if the identity is an IDNA 1893 # name, see RFC6125 and the discussion at 1894 # http://bugs.python.org/issue17997#msg194950 1895 if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { 1896 return if $1 ne '' and substr($identity,0,4) eq 'xn--'; # IDNA 1897 $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]+\Q$2\E$}i; 1898 } elsif ( $wtyp =~ m{^(?:full_label|leftmost)$} 1899 and $name =~m{^\*(\..+)$} ) { 1900 $pattern = qr{^[a-zA-Z0-9_\-]+\Q$1\E$}i; 1901 } else { 1902 return lc($identity) eq lc($name); 1903 } 1904 if ( $identity =~ $pattern ) { 1905 $publicsuffix = IO::Socket::SSL::PublicSuffix->default 1906 if ! defined $publicsuffix; 1907 return 1 if $publicsuffix eq ''; 1908 my @labels = split( m{\.+}, $identity ); 1909 my $tld = $publicsuffix->public_suffix(\@labels,+1); 1910 return 1 if @labels > ( $tld ? 0+@$tld : 1 ); 1911 } 1912 return; 1913 }; 1914 1915 1916 my $alt_dnsNames = 0; 1917 while (@altNames) { 1918 my ($type, $name) = splice (@altNames, 0, 2); 1919 if ( $ipn and $type == GEN_IPADD ) { 1920 # exact match needed for IP 1921 # $name is already packed format (inet_xton) 1922 return 1 if $ipn eq $name; 1923 1924 } elsif ( ! $ipn and $type == GEN_DNS ) { 1925 $name =~s/\s+$//; $name =~s/^\s+//; 1926 $alt_dnsNames++; 1927 $check_name->($name,$identity,$scheme->{wildcards_in_alt},$publicsuffix) 1928 and return 1; 1929 } 1930 } 1931 1932 if ( $scheme->{check_cn} eq 'always' or 1933 $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames ) { 1934 if ( ! $ipn ) { 1935 $check_name->($commonName,$identity,$scheme->{wildcards_in_cn},$publicsuffix) 1936 and return 1; 1937 } elsif ( $scheme->{ip_in_cn} ) { 1938 if ( $identity eq $commonName ) { 1939 return 1 if 1940 $scheme->{ip_in_cn} == 4 ? length($ipn) == 4 : 1941 $scheme->{ip_in_cn} == 6 ? length($ipn) == 16 : 1942 1; 1943 } 1944 } 1945 } 1946 1947 return 0; # no match 1948 } 1949} 1950 1951sub verify_hostname { 1952 my $self = shift; 1953 my $host = shift; 1954 my $cert = $self->peer_certificate; 1955 return verify_hostname_of_cert( $host,$cert,@_ ); 1956} 1957 1958 1959sub get_servername { 1960 my $self = shift; 1961 return ${*$self}{_SSL_servername} ||= do { 1962 my $ssl = $self->_get_ssl_object or return; 1963 Net::SSLeay::get_servername($ssl); 1964 }; 1965} 1966 1967sub get_fingerprint_bin { 1968 my ($self,$algo,$cert,$key_only) = @_; 1969 $cert ||= $self->peer_certificate; 1970 return $key_only 1971 ? Net::SSLeay::X509_pubkey_digest($cert, $algo2digest->($algo || 'sha256')) 1972 : Net::SSLeay::X509_digest($cert, $algo2digest->($algo || 'sha256')); 1973} 1974 1975sub get_fingerprint { 1976 my ($self,$algo,$cert,$key_only) = @_; 1977 $algo ||= 'sha256'; 1978 my $fp = get_fingerprint_bin($self,$algo,$cert,$key_only) or return; 1979 return $algo.'$'.($key_only ? 'pub$':'').unpack('H*',$fp); 1980} 1981 1982sub get_cipher { 1983 my $ssl = shift()->_get_ssl_object || return; 1984 return Net::SSLeay::get_cipher($ssl); 1985} 1986 1987sub get_sslversion { 1988 my $ssl = shift()->_get_ssl_object || return; 1989 my $version = Net::SSLeay::version($ssl) or return; 1990 return 1991 $version == 0x0304 ? 'TLSv1_3' : 1992 $version == 0x0303 ? 'TLSv1_2' : 1993 $version == 0x0302 ? 'TLSv1_1' : 1994 $version == 0x0301 ? 'TLSv1' : 1995 $version == 0x0300 ? 'SSLv3' : 1996 $version == 0x0002 ? 'SSLv2' : 1997 $version == 0xfeff ? 'DTLS1' : 1998 undef; 1999} 2000 2001sub get_sslversion_int { 2002 my $ssl = shift()->_get_ssl_object || return; 2003 return Net::SSLeay::version($ssl); 2004} 2005 2006sub get_session_reused { 2007 return Net::SSLeay::session_reused( 2008 shift()->_get_ssl_object || return); 2009} 2010 2011if ($can_ocsp) { 2012 no warnings 'once'; 2013 *ocsp_resolver = sub { 2014 my $self = shift; 2015 my $ssl = $self->_get_ssl_object || return; 2016 my $ctx = ${*$self}{_SSL_ctx}; 2017 return IO::Socket::SSL::OCSP_Resolver->new( 2018 $ssl, 2019 $ctx->{ocsp_cache} ||= IO::Socket::SSL::OCSP_Cache->new, 2020 $ctx->{ocsp_mode} & SSL_OCSP_FAIL_HARD, 2021 @_ ? \@_ : 2022 $ctx->{ocsp_mode} & SSL_OCSP_FULL_CHAIN ? [ $self->peer_certificates ]: 2023 [ $self->peer_certificate ] 2024 ); 2025 }; 2026} 2027 2028sub errstr { 2029 my $self = shift; 2030 my $oe = ref($self) && ${*$self}{_SSL_last_err}; 2031 return $oe ? $oe->[0] : $SSL_ERROR || ''; 2032} 2033 2034sub fatal_ssl_error { 2035 my $self = shift; 2036 my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'}; 2037 $@ = $self->errstr; 2038 if (defined $error_trap and ref($error_trap) eq 'CODE') { 2039 $error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error()); 2040 } elsif ( ${*$self}{'_SSL_ioclass_upgraded'} 2041 || ${*$self}{_SSL_arguments}{SSL_keepSocketOnError}) { 2042 # downgrade only 2043 $DEBUG>=3 && DEBUG('downgrading SSL only, not closing socket' ); 2044 $self->stop_SSL; 2045 } else { 2046 # kill socket 2047 $self->close 2048 } 2049 return; 2050} 2051 2052sub get_ssleay_error { 2053 #Net::SSLeay will print out the errors itself unless we explicitly 2054 #undefine $Net::SSLeay::trace while running print_errs() 2055 local $Net::SSLeay::trace; 2056 return Net::SSLeay::print_errs('SSL error: ') || ''; 2057} 2058 2059# internal errors, e.g. unsupported features, hostname check failed etc 2060# _SSL_last_err contains severity so that on error chains we can decide if one 2061# error should replace the previous one or if this is just a less specific 2062# follow-up error, e.g. configuration failed because certificate failed because 2063# hostname check went wrong: 2064# 0 - fallback errors 2065# 4 - errors bubbled up from OpenSSL (sub error, r/w error) 2066# 5 - hostname or OCSP verification failed 2067# 9 - fatal problems, e.g. missing feature, no fileno... 2068# _SSL_last_err and SSL_ERROR are only replaced if the error has a higher 2069# severity than the previous one 2070 2071sub _internal_error { 2072 my ($self, $error, $severity) = @_; 2073 $error = dualvar( -1, $error ); 2074 $self = $CURRENT_SSL_OBJECT if !ref($self) && $CURRENT_SSL_OBJECT; 2075 if (ref($self)) { 2076 my $oe = ${*$self}{_SSL_last_err}; 2077 if (!$oe || $oe->[1] <= $severity) { 2078 ${*$self}{_SSL_last_err} = [$error,$severity]; 2079 $SSL_ERROR = $error; 2080 $DEBUG && DEBUG("local error: $error"); 2081 } else { 2082 $DEBUG && DEBUG("ignoring less severe local error '$error', keep '$oe->[0]'"); 2083 } 2084 } else { 2085 $SSL_ERROR = $error; 2086 $DEBUG && DEBUG("global error: $error"); 2087 } 2088 return; 2089} 2090 2091# OpenSSL errors 2092sub error { 2093 my ($self, $error) = @_; 2094 my @err; 2095 while ( my $err = Net::SSLeay::ERR_get_error()) { 2096 push @err, Net::SSLeay::ERR_error_string($err); 2097 $DEBUG>=2 && DEBUG( $error."\n".$self->get_ssleay_error()); 2098 } 2099 $error .= ' '.join(' ',@err) if @err; 2100 return $self->_internal_error($error,4) if $error; 2101 return; 2102} 2103 2104sub _errstack { 2105 my @err; 2106 while (my $err = Net::SSLeay::ERR_get_error()) { 2107 push @err, Net::SSLeay::ERR_error_string($err); 2108 } 2109 return @err; 2110} 2111 2112sub can_client_sni { return $can_client_sni } 2113sub can_server_sni { return $can_server_sni } 2114sub can_multi_cert { return $can_multi_cert } 2115sub can_npn { return $can_npn } 2116sub can_alpn { return $can_alpn } 2117sub can_ecdh { return $can_ecdh } 2118sub can_ipv6 { return CAN_IPV6 } 2119sub can_ocsp { return $can_ocsp } 2120sub can_ticket_keycb { return $can_tckt_keycb } 2121sub can_pha { return $can_pha } 2122sub can_partial_chain { return $check_partial_chain && 1 } 2123 2124sub DESTROY { 2125 my $self = shift or return; 2126 if (my $ssl = ${*$self}{_SSL_object}) { 2127 delete $SSL_OBJECT{$ssl}; 2128 if (!$use_threads or delete $CREATED_IN_THIS_THREAD{$ssl}) { 2129 $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1); 2130 } 2131 } 2132 delete @{*$self}{@all_my_keys}; 2133} 2134 2135 2136#######Extra Backwards Compatibility Functionality####### 2137sub socket_to_SSL { IO::Socket::SSL->start_SSL(@_); } 2138sub socketToSSL { IO::Socket::SSL->start_SSL(@_); } 2139sub kill_socket { shift->close } 2140 2141sub issuer_name { return(shift()->peer_certificate("issuer")) } 2142sub subject_name { return(shift()->peer_certificate("subject")) } 2143sub get_peer_certificate { return shift() } 2144 2145sub context_init { 2146 return($GLOBAL_SSL_ARGS = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}); 2147} 2148 2149sub set_default_context { 2150 $GLOBAL_SSL_ARGS->{'SSL_reuse_ctx'} = shift; 2151} 2152 2153sub set_default_session_cache { 2154 $GLOBAL_SSL_ARGS->{SSL_session_cache} = shift; 2155} 2156 2157 2158{ 2159 my $set_defaults = sub { 2160 my $args = shift; 2161 for(my $i=0;$i<@$args;$i+=2 ) { 2162 my ($k,$v) = @{$args}[$i,$i+1]; 2163 if ( $k =~m{^SSL_} ) { 2164 $_->{$k} = $v for(@_); 2165 } elsif ( $k =~m{^(name|scheme)$} ) { 2166 $_->{"SSL_verifycn_$k"} = $v for (@_); 2167 } elsif ( $k =~m{^(callback|mode)$} ) { 2168 $_->{"SSL_verify_$k"} = $v for(@_); 2169 } else { 2170 $_->{"SSL_$k"} = $v for(@_); 2171 } 2172 } 2173 }; 2174 sub set_defaults { 2175 my %args = @_; 2176 $set_defaults->(\@_, 2177 $GLOBAL_SSL_ARGS, 2178 $GLOBAL_SSL_CLIENT_ARGS, 2179 $GLOBAL_SSL_SERVER_ARGS 2180 ); 2181 } 2182 { # deprecated API 2183 no warnings; 2184 *set_ctx_defaults = \&set_defaults; 2185 } 2186 sub set_client_defaults { 2187 my %args = @_; 2188 $set_defaults->(\@_, $GLOBAL_SSL_CLIENT_ARGS ); 2189 } 2190 sub set_server_defaults { 2191 my %args = @_; 2192 $set_defaults->(\@_, $GLOBAL_SSL_SERVER_ARGS ); 2193 } 2194} 2195 2196sub set_args_filter_hack { 2197 my $sub = shift; 2198 if ( ref $sub ) { 2199 $FILTER_SSL_ARGS = $sub; 2200 } elsif ( $sub eq 'use_defaults' ) { 2201 # override args with defaults 2202 $FILTER_SSL_ARGS = sub { 2203 my ($is_server,$args) = @_; 2204 %$args = ( %$args, $is_server 2205 ? ( %DEFAULT_SSL_SERVER_ARGS, %$GLOBAL_SSL_SERVER_ARGS ) 2206 : ( %DEFAULT_SSL_CLIENT_ARGS, %$GLOBAL_SSL_CLIENT_ARGS ) 2207 ); 2208 } 2209 } 2210} 2211 2212sub next_proto_negotiated { 2213 my $self = shift; 2214 return $self->_internal_error("NPN not supported in Net::SSLeay",9) if ! $can_npn; 2215 my $ssl = $self->_get_ssl_object || return; 2216 return Net::SSLeay::P_next_proto_negotiated($ssl); 2217} 2218 2219sub alpn_selected { 2220 my $self = shift; 2221 return $self->_internal_error("ALPN not supported in Net::SSLeay",9) if ! $can_alpn; 2222 my $ssl = $self->_get_ssl_object || return; 2223 return Net::SSLeay::P_alpn_selected($ssl); 2224} 2225 2226sub opened { 2227 my $self = shift; 2228 return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'}; 2229} 2230 2231sub opening { 2232 my $self = shift; 2233 return ${*$self}{'_SSL_opening'}; 2234} 2235 2236sub want_read { shift->errstr == SSL_WANT_READ } 2237sub want_write { shift->errstr == SSL_WANT_WRITE } 2238 2239 2240#Redundant IO::Handle functionality 2241sub getline { return(scalar shift->readline()) } 2242sub getlines { 2243 return(shift->readline()) if wantarray(); 2244 croak("Use of getlines() not allowed in scalar context"); 2245} 2246 2247#Useless IO::Handle functionality 2248sub truncate { croak("Use of truncate() not allowed with SSL") } 2249sub stat { croak("Use of stat() not allowed with SSL" ) } 2250sub setbuf { croak("Use of setbuf() not allowed with SSL" ) } 2251sub setvbuf { croak("Use of setvbuf() not allowed with SSL" ) } 2252sub fdopen { croak("Use of fdopen() not allowed with SSL" ) } 2253 2254#Unsupported socket functionality 2255sub ungetc { croak("Use of ungetc() not implemented in IO::Socket::SSL") } 2256sub send { croak("Use of send() not implemented in IO::Socket::SSL; use print/printf/syswrite instead") } 2257sub recv { croak("Use of recv() not implemented in IO::Socket::SSL; use read/sysread instead") } 2258 2259package IO::Socket::SSL::SSL_HANDLE; 2260use strict; 2261use Errno 'EBADF'; 2262*weaken = *IO::Socket::SSL::weaken; 2263 2264sub TIEHANDLE { 2265 my ($class, $handle) = @_; 2266 weaken($handle); 2267 bless \$handle, $class; 2268} 2269 2270sub READ { ${shift()}->sysread(@_) } 2271sub READLINE { ${shift()}->readline(@_) } 2272sub GETC { ${shift()}->getc(@_) } 2273 2274sub PRINT { ${shift()}->print(@_) } 2275sub PRINTF { ${shift()}->printf(@_) } 2276sub WRITE { ${shift()}->syswrite(@_) } 2277 2278sub FILENO { ${shift()}->fileno(@_) } 2279 2280sub TELL { $! = EBADF; return -1 } 2281sub BINMODE { return 0 } # not perfect, but better than not implementing the method 2282 2283sub CLOSE { #<---- Do not change this function! 2284 my $ssl = ${$_[0]}; 2285 local @_; 2286 $ssl->close(); 2287} 2288 2289 2290package IO::Socket::SSL::SSL_Context; 2291use Carp; 2292use strict; 2293 2294my %CTX_CREATED_IN_THIS_THREAD; 2295*DEBUG = *IO::Socket::SSL::DEBUG; 2296*_errstack = \&IO::Socket::SSL::_errstack; 2297 2298use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1; 2299use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2; 2300 2301use constant FILETYPE_PEM => Net::SSLeay::FILETYPE_PEM(); 2302use constant FILETYPE_ASN1 => Net::SSLeay::FILETYPE_ASN1(); 2303 2304my $DEFAULT_SSL_OP = &Net::SSLeay::OP_ALL 2305 | &Net::SSLeay::OP_SINGLE_DH_USE 2306 | ($can_ecdh ? &Net::SSLeay::OP_SINGLE_ECDH_USE : 0); 2307 2308# Note that the final object will actually be a reference to the scalar 2309# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that 2310# it can be blessed. 2311sub new { 2312 my $class = shift; 2313 #DEBUG( "$class @_" ); 2314 my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 2315 2316 my $is_server = $arg_hash->{SSL_server}; 2317 my %defaults = $is_server 2318 ? (%DEFAULT_SSL_SERVER_ARGS, %$GLOBAL_SSL_ARGS, %$GLOBAL_SSL_SERVER_ARGS) 2319 : (%DEFAULT_SSL_CLIENT_ARGS, %$GLOBAL_SSL_ARGS, %$GLOBAL_SSL_CLIENT_ARGS); 2320 if ( $defaults{SSL_reuse_ctx} ) { 2321 # ignore default context if there are args to override it 2322 delete $defaults{SSL_reuse_ctx} 2323 if grep { m{^SSL_(?!verifycn_name|hostname)$} } keys %$arg_hash; 2324 } 2325 %$arg_hash = ( %defaults, %$arg_hash ) if %defaults; 2326 2327 if (my $ctx = $arg_hash->{'SSL_reuse_ctx'}) { 2328 if ($ctx->isa('IO::Socket::SSL::SSL_Context') and 2329 $ctx->{context}) { 2330 # valid context 2331 } elsif ( $ctx = ${*$ctx}{_SSL_ctx} ) { 2332 # reuse context from existing SSL object 2333 } 2334 return $ctx 2335 } 2336 2337 # common problem forgetting to set SSL_use_cert 2338 # if client cert is given by user but SSL_use_cert is undef, assume that it 2339 # should be set 2340 if ( ! $is_server && ! defined $arg_hash->{SSL_use_cert} 2341 && ( grep { $arg_hash->{$_} } qw(SSL_cert SSL_cert_file)) 2342 && ( grep { $arg_hash->{$_} } qw(SSL_key SSL_key_file)) ) { 2343 $arg_hash->{SSL_use_cert} = 1 2344 } 2345 2346 # if any of SSL_ca* is set don't set the other SSL_ca* 2347 # from defaults 2348 if ( $arg_hash->{SSL_ca} ) { 2349 $arg_hash->{SSL_ca_file} ||= undef 2350 $arg_hash->{SSL_ca_path} ||= undef 2351 } elsif ( $arg_hash->{SSL_ca_path} ) { 2352 $arg_hash->{SSL_ca_file} ||= undef 2353 } elsif ( $arg_hash->{SSL_ca_file} ) { 2354 $arg_hash->{SSL_ca_path} ||= undef; 2355 } 2356 2357 # add library defaults 2358 $arg_hash->{SSL_use_cert} = $is_server if ! defined $arg_hash->{SSL_use_cert}; 2359 2360 2361 # Avoid passing undef arguments to Net::SSLeay 2362 defined($arg_hash->{$_}) or delete($arg_hash->{$_}) for(keys %$arg_hash); 2363 2364 # check SSL CA, cert etc arguments 2365 # some apps set keys '' to signal that it is not set, replace with undef 2366 for (qw( SSL_cert SSL_cert_file SSL_key SSL_key_file 2367 SSL_ca SSL_ca_file SSL_ca_path 2368 SSL_fingerprint )) { 2369 $arg_hash->{$_} = undef if defined $arg_hash->{$_} 2370 and $arg_hash->{$_} eq ''; 2371 } 2372 for(qw(SSL_cert_file SSL_key_file)) { 2373 defined( my $file = $arg_hash->{$_} ) or next; 2374 for my $f (ref($file) eq 'HASH' ? values(%$file):$file ) { 2375 die "$_ $f can't be used: $!" if ! open(my $fh,'<',$f) 2376 } 2377 } 2378 2379 my $verify_mode = $arg_hash->{SSL_verify_mode} || 0; 2380 if ( $verify_mode != $Net_SSLeay_VERIFY_NONE) { 2381 for (qw(SSL_ca_file SSL_ca_path)) { 2382 $CHECK_SSL_PATH->($_ => $arg_hash->{$_} || next); 2383 } 2384 } elsif ( $verify_mode ne '0' ) { 2385 # some users use the string 'SSL_VERIFY_PEER' instead of the constant 2386 die "SSL_verify_mode must be a number and not a string"; 2387 } 2388 2389 my $self = bless {},$class; 2390 2391 my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme}; 2392 my $vcn_publicsuffix = delete $arg_hash->{SSL_verifycn_publicsuffix}; 2393 if ( ! $is_server and $verify_mode & 0x01 and 2394 ! $vcn_scheme || $vcn_scheme ne 'none' ) { 2395 2396 # gets updated during configure_SSL 2397 my $verify_name; 2398 $self->{verify_name_ref} = \$verify_name; 2399 2400 my $vcb = $arg_hash->{SSL_verify_callback}; 2401 $arg_hash->{SSL_verify_callback} = sub { 2402 my ($ok,$ctx_store,$certname,$error,$cert,$depth) = @_; 2403 $ok = $vcb->($ok,$ctx_store,$certname,$error,$cert,$depth) if $vcb; 2404 $ok or return 0; 2405 2406 return $ok if $depth != 0; 2407 2408 my $host = $verify_name || ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown'; 2409 if ( ! $host ) { 2410 if ( $vcn_scheme ) { 2411 IO::Socket::SSL->_internal_error( 2412 "Cannot determine peer hostname for verification",8); 2413 return 0; 2414 } 2415 warn "Cannot determine hostname of peer for verification. ". 2416 "Disabling default hostname verification for now. ". 2417 "Please specify hostname with SSL_verifycn_name and better set SSL_verifycn_scheme too.\n"; 2418 return $ok; 2419 } elsif ( ! $vcn_scheme && $host =~m{^[\d.]+$|:} ) { 2420 # don't try to verify IP by default 2421 return $ok; 2422 } 2423 2424 2425 # verify name 2426 my $rv = IO::Socket::SSL::verify_hostname_of_cert( 2427 $host,$cert,$vcn_scheme,$vcn_publicsuffix ); 2428 if ( ! $rv ) { 2429 IO::Socket::SSL->_internal_error( 2430 "hostname verification failed",5); 2431 } 2432 return $rv; 2433 }; 2434 } 2435 2436 if ($is_server) { 2437 if ($arg_hash->{SSL_ticket_keycb} && !$can_tckt_keycb) { 2438 warn "Ticket Key Callback is not supported - ignoring option SSL_ticket_keycb\n"; 2439 delete $arg_hash->{SSL_ticket_keycb}; 2440 } 2441 } 2442 2443 2444 my $ssl_op = $DEFAULT_SSL_OP; 2445 2446 my $ver; 2447 for (split(/\s*:\s*/,$arg_hash->{SSL_version})) { 2448 m{^(!?)(?:(SSL(?:v2|v3|v23|v2/3))|(TLSv1(?:_?[123])?))$}i 2449 or croak("invalid SSL_version specified"); 2450 my $not = $1; 2451 ( my $v = lc($2||$3) ) =~s{^(...)}{\U$1}; 2452 if ( $not ) { 2453 $ssl_op |= $SSL_OP_NO{$v}; 2454 } else { 2455 croak("cannot set multiple SSL protocols in SSL_version") 2456 if $ver && $v ne $ver; 2457 $ver = $v; 2458 $ver =~s{/}{}; # interpret SSLv2/3 as SSLv23 2459 $ver =~s{(TLSv1)(\d)}{$1\_$2}; # TLSv1_1 2460 } 2461 } 2462 2463 my $ctx_new_sub = 2464 $ver eq 'TLSv1_3' ? $CTX_tlsv1_3_new : 2465 UNIVERSAL::can( 'Net::SSLeay', 2466 $ver eq 'SSLv2' ? 'CTX_v2_new' : 2467 $ver eq 'SSLv3' ? 'CTX_v3_new' : 2468 $ver eq 'TLSv1' ? 'CTX_tlsv1_new' : 2469 $ver eq 'TLSv1_1' ? 'CTX_tlsv1_1_new' : 2470 $ver eq 'TLSv1_2' ? 'CTX_tlsv1_2_new' : 2471 'CTX_new' 2472 ) 2473 or return IO::Socket::SSL->_internal_error("SSL Version $ver not supported",9); 2474 2475 # For SNI in server mode we need a separate context for each certificate. 2476 my %ctx; 2477 if ($is_server) { 2478 my %sni; 2479 for my $opt (qw(SSL_key SSL_key_file SSL_cert SSL_cert_file)) { 2480 my $val = $arg_hash->{$opt} or next; 2481 if ( ref($val) eq 'HASH' ) { 2482 while ( my ($host,$v) = each %$val ) { 2483 $sni{lc($host)}{$opt} = $v; 2484 } 2485 } 2486 } 2487 while (my ($host,$v) = each %sni) { 2488 $ctx{$host} = $host =~m{%} ? $v : { %$arg_hash, %$v }; 2489 } 2490 } 2491 $ctx{''} = $arg_hash if ! %ctx; 2492 2493 for my $host (sort keys %ctx) { 2494 my $arg_hash = delete $ctx{$host}; 2495 my $ctx; 2496 if ($host =~m{^([^%]*)%}) { 2497 $ctx = $ctx{$1} or return IO::Socket::SSL->error( 2498 "SSL Context init for $host failed - no config for $1"); 2499 if (my @k = grep { !m{^SSL_(?:cert|key)(?:_file)?$} } 2500 keys %$arg_hash) { 2501 return IO::Socket::SSL->error( 2502 "invalid keys @k in configuration '$host' of additional certs"); 2503 } 2504 $can_multi_cert or return IO::Socket::SSL->error( 2505 "no support for both RSA and ECC certificate in same context"); 2506 $host = $1; 2507 goto just_configure_certs; 2508 } 2509 2510 $ctx = $ctx_new_sub->() or return 2511 IO::Socket::SSL->error("SSL Context init failed"); 2512 $CTX_CREATED_IN_THIS_THREAD{$ctx} = 1 if $use_threads; 2513 $ctx{$host} = $ctx; # replace value in %ctx with real context 2514 2515 # SSL_OP_CIPHER_SERVER_PREFERENCE 2516 $ssl_op |= 0x00400000 if $arg_hash->{SSL_honor_cipher_order}; 2517 2518 if ($ver eq 'SSLv23' && !($ssl_op & $SSL_OP_NO{SSLv3})) { 2519 # At least LibreSSL disables SSLv3 by default in SSL_CTX_new. 2520 # If we really want SSL3.0 we need to explicitly allow it with 2521 # SSL_CTX_clear_options. 2522 Net::SSLeay::CTX_clear_options($ctx,$SSL_OP_NO{SSLv3}); 2523 } 2524 2525 Net::SSLeay::CTX_set_options($ctx,$ssl_op); 2526 2527 # enable X509_V_FLAG_PARTIAL_CHAIN if possible (OpenSSL 1.1.0+) 2528 $check_partial_chain && $check_partial_chain->($ctx); 2529 2530 # if we don't set session_id_context if client certificate is expected 2531 # client session caching will fail 2532 # if user does not provide explicit id just use the stringification 2533 # of the context 2534 if($arg_hash->{SSL_server} and my $id = 2535 $arg_hash->{SSL_session_id_context} || 2536 ( $arg_hash->{SSL_verify_mode} & 0x01 ) && "$ctx" ) { 2537 Net::SSLeay::CTX_set_session_id_context($ctx,$id,length($id)); 2538 } 2539 2540 # SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER makes syswrite return if at least one 2541 # buffer was written and not block for the rest 2542 # SSL_MODE_ENABLE_PARTIAL_WRITE can be necessary for non-blocking because we 2543 # cannot guarantee, that the location of the buffer stays constant 2544 Net::SSLeay::CTX_set_mode( $ctx, 2545 SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER | 2546 SSL_MODE_ENABLE_PARTIAL_WRITE | 2547 ($arg_hash->{SSL_mode_release_buffers} ? $ssl_mode_release_buffers : 0) 2548 ); 2549 2550 if ( my $proto_list = $arg_hash->{SSL_npn_protocols} ) { 2551 return IO::Socket::SSL->_internal_error("NPN not supported in Net::SSLeay",9) 2552 if ! $can_npn; 2553 if($arg_hash->{SSL_server}) { 2554 # on server side SSL_npn_protocols means a list of advertised protocols 2555 Net::SSLeay::CTX_set_next_protos_advertised_cb($ctx, $proto_list); 2556 } else { 2557 # on client side SSL_npn_protocols means a list of preferred protocols 2558 # negotiation algorithm used is "as-openssl-implements-it" 2559 Net::SSLeay::CTX_set_next_proto_select_cb($ctx, $proto_list); 2560 } 2561 } 2562 2563 if ( my $proto_list = $arg_hash->{SSL_alpn_protocols} ) { 2564 return IO::Socket::SSL->_internal_error("ALPN not supported in Net::SSLeay",9) 2565 if ! $can_alpn; 2566 if($arg_hash->{SSL_server}) { 2567 Net::SSLeay::CTX_set_alpn_select_cb($ctx, $proto_list); 2568 } else { 2569 Net::SSLeay::CTX_set_alpn_protos($ctx, $proto_list); 2570 } 2571 } 2572 2573 if ($arg_hash->{SSL_ticket_keycb}) { 2574 my $cb = $arg_hash->{SSL_ticket_keycb}; 2575 ($cb,my $arg) = ref($cb) eq 'CODE' ? ($cb):@$cb; 2576 Net::SSLeay::CTX_set_tlsext_ticket_getkey_cb($ctx,$cb,$arg); 2577 } 2578 2579 # Try to apply SSL_ca even if SSL_verify_mode is 0, so that they can be 2580 # used to verify OCSP responses. 2581 # If applying fails complain only if verify_mode != VERIFY_NONE. 2582 if ( $arg_hash->{SSL_ca} 2583 || defined $arg_hash->{SSL_ca_file} 2584 || defined $arg_hash->{SSL_ca_path} ) { 2585 my $file = $arg_hash->{SSL_ca_file}; 2586 $file = undef if ref($file) eq 'SCALAR' && ! $$file; 2587 my $dir = $arg_hash->{SSL_ca_path}; 2588 $dir = undef if ref($dir) eq 'SCALAR' && ! $$dir; 2589 if ( $arg_hash->{SSL_ca} ) { 2590 my $store = Net::SSLeay::CTX_get_cert_store($ctx); 2591 for (@{$arg_hash->{SSL_ca}}) { 2592 Net::SSLeay::X509_STORE_add_cert($store,$_) or 2593 return IO::Socket::SSL->error( 2594 "Failed to add certificate to CA store"); 2595 } 2596 } 2597 $dir = join($OPENSSL_LIST_SEPARATOR,@$dir) if ref($dir); 2598 if ( $file || $dir and ! Net::SSLeay::CTX_load_verify_locations( 2599 $ctx, $file || '', $dir || '')) { 2600 return IO::Socket::SSL->error( 2601 "Invalid certificate authority locations") 2602 if $verify_mode != $Net_SSLeay_VERIFY_NONE; 2603 } 2604 } elsif ( my %ca = IO::Socket::SSL::default_ca()) { 2605 # no CA path given, continue with system defaults 2606 my $dir = $ca{SSL_ca_path}; 2607 $dir = join($OPENSSL_LIST_SEPARATOR,@$dir) if ref($dir); 2608 if (! Net::SSLeay::CTX_load_verify_locations( $ctx, 2609 $ca{SSL_ca_file} || '',$dir || '') 2610 && $verify_mode != $Net_SSLeay_VERIFY_NONE) { 2611 return IO::Socket::SSL->error( 2612 "Invalid default certificate authority locations") 2613 } 2614 } 2615 2616 if ($is_server && ($verify_mode & $Net_SSLeay_VERIFY_PEER)) { 2617 if ($arg_hash->{SSL_client_ca}) { 2618 for (@{$arg_hash->{SSL_client_ca}}) { 2619 return IO::Socket::SSL->error( 2620 "Failed to add certificate to client CA list") if 2621 ! Net::SSLeay::CTX_add_client_CA($ctx,$_); 2622 } 2623 } 2624 if ($arg_hash->{SSL_client_ca_file}) { 2625 my $list = Net::SSLeay::load_client_CA_file( 2626 $arg_hash->{SSL_client_ca_file}) or 2627 return IO::Socket::SSL->error( 2628 "Failed to load certificate to client CA list"); 2629 Net::SSLeay::CTX_set_client_CA_list($ctx,$list); 2630 } 2631 } 2632 2633 my $X509_STORE_flags = $DEFAULT_X509_STORE_flags; 2634 if ($arg_hash->{'SSL_check_crl'}) { 2635 $X509_STORE_flags |= Net::SSLeay::X509_V_FLAG_CRL_CHECK(); 2636 if ($arg_hash->{'SSL_crl_file'}) { 2637 my $bio = Net::SSLeay::BIO_new_file($arg_hash->{'SSL_crl_file'}, 'r'); 2638 my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio); 2639 Net::SSLeay::BIO_free($bio); 2640 if ( $crl ) { 2641 Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ctx), $crl); 2642 Net::SSLeay::X509_CRL_free($crl); 2643 } else { 2644 return IO::Socket::SSL->error("Invalid certificate revocation list"); 2645 } 2646 } 2647 } 2648 2649 Net::SSLeay::X509_STORE_set_flags( 2650 Net::SSLeay::CTX_get_cert_store($ctx), 2651 $X509_STORE_flags 2652 ) if $X509_STORE_flags; 2653 2654 Net::SSLeay::CTX_set_default_passwd_cb($ctx,$arg_hash->{SSL_passwd_cb}) 2655 if $arg_hash->{SSL_passwd_cb}; 2656 2657 just_configure_certs: 2658 my ($havekey,$havecert); 2659 if ( my $x509 = $arg_hash->{SSL_cert} ) { 2660 # binary, e.g. X509* 2661 # we have either a single certificate or a list with 2662 # a chain of certificates 2663 my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509); 2664 my $cert = shift @x509; 2665 Net::SSLeay::CTX_use_certificate( $ctx,$cert ) 2666 || return IO::Socket::SSL->error("Failed to use Certificate"); 2667 foreach my $ca (@x509) { 2668 Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca ) 2669 || return IO::Socket::SSL->error("Failed to use Certificate"); 2670 } 2671 $havecert = 'OBJ'; 2672 } elsif ( my $f = $arg_hash->{SSL_cert_file} ) { 2673 # try to load chain from PEM or certificate from ASN1 2674 my @err; 2675 if (Net::SSLeay::CTX_use_certificate_chain_file($ctx,$f)) { 2676 $havecert = 'PEM'; 2677 } elsif (do { 2678 push @err, [ PEM => _errstack() ]; 2679 Net::SSLeay::CTX_use_certificate_file($ctx,$f,FILETYPE_ASN1) 2680 }) { 2681 $havecert = 'DER'; 2682 } else { 2683 push @err, [ DER => _errstack() ]; 2684 # try to load certificate, key and chain from PKCS12 file 2685 my ($key,$cert,@chain) = Net::SSLeay::P_PKCS12_load_file($f,1); 2686 if (!$cert and $arg_hash->{SSL_passwd_cb} 2687 and defined( my $pw = $arg_hash->{SSL_passwd_cb}->(0))) { 2688 ($key,$cert,@chain) = Net::SSLeay::P_PKCS12_load_file($f,1,$pw); 2689 } 2690 PKCS12: while ($cert) { 2691 Net::SSLeay::CTX_use_certificate($ctx,$cert) or last; 2692 # Net::SSLeay::P_PKCS12_load_file is implemented using 2693 # OpenSSL PKCS12_parse which according to the source code 2694 # returns the chain with the last CA certificate first (i.e. 2695 # reverse order as in the PKCS12 file). This is not 2696 # documented but given the age of this function we'll assume 2697 # that this will stay this way in the future. 2698 while (my $ca = pop @chain) { 2699 Net::SSLeay::CTX_add_extra_chain_cert($ctx,$ca) 2700 or last PKCS12; 2701 } 2702 last if $key && ! Net::SSLeay::CTX_use_PrivateKey($ctx,$key); 2703 $havecert = 'PKCS12'; 2704 last; 2705 } 2706 $havekey = 'PKCS12' if $key; 2707 Net::SSLeay::X509_free($cert) if $cert; 2708 Net::SSLeay::EVP_PKEY_free($key) if $key; 2709 # don't free @chain, because CTX_add_extra_chain_cert 2710 # did not duplicate the certificates 2711 } 2712 if (!$havecert) { 2713 push @err, [ PKCS12 => _errstack() ]; 2714 my $err = "Failed to load certificate from file $f:"; 2715 for(@err) { 2716 my ($type,@e) = @$_; 2717 $err .= " [format:$type] @e **" if @e; 2718 } 2719 return IO::Socket::SSL->error($err); 2720 } 2721 } 2722 2723 if (!$havecert || $havekey) { 2724 # skip SSL_key_* 2725 } elsif ( my $pkey = $arg_hash->{SSL_key} ) { 2726 # binary, e.g. EVP_PKEY* 2727 Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey) 2728 || return IO::Socket::SSL->error("Failed to use Private Key"); 2729 $havekey = 'MEM'; 2730 } elsif ( my $f = $arg_hash->{SSL_key_file} 2731 || (($havecert eq 'PEM') ? $arg_hash->{SSL_cert_file}:undef) ) { 2732 for my $ft ( FILETYPE_PEM, FILETYPE_ASN1 ) { 2733 if (Net::SSLeay::CTX_use_PrivateKey_file($ctx,$f,$ft)) { 2734 $havekey = ($ft == FILETYPE_PEM) ? 'PEM':'DER'; 2735 last; 2736 } 2737 } 2738 $havekey or return IO::Socket::SSL->error( 2739 "Failed to load key from file (no PEM or DER)"); 2740 } 2741 2742 Net::SSLeay::CTX_set_post_handshake_auth($ctx,1) 2743 if (!$is_server && $can_pha && $havecert && $havekey); 2744 } 2745 2746 if ($arg_hash->{SSL_server}) { 2747 2748 if ( my $f = $arg_hash->{SSL_dh_file} ) { 2749 my $bio = Net::SSLeay::BIO_new_file( $f,'r' ) 2750 || return IO::Socket::SSL->error( "Failed to open DH file $f" ); 2751 my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio); 2752 Net::SSLeay::BIO_free($bio); 2753 $dh || return IO::Socket::SSL->error( "Failed to read PEM for DH from $f - wrong format?" ); 2754 my $rv; 2755 for (values (%ctx)) { 2756 $rv = Net::SSLeay::CTX_set_tmp_dh( $_,$dh ) or last; 2757 } 2758 Net::SSLeay::DH_free( $dh ); 2759 $rv || return IO::Socket::SSL->error( "Failed to set DH from $f" ); 2760 } elsif ( my $dh = $arg_hash->{SSL_dh} ) { 2761 # binary, e.g. DH* 2762 2763 for( values %ctx ) { 2764 Net::SSLeay::CTX_set_tmp_dh( $_,$dh ) || return 2765 IO::Socket::SSL->error( "Failed to set DH from SSL_dh" ); 2766 } 2767 } 2768 } 2769 2770 if ( my $curve = $arg_hash->{SSL_ecdh_curve} ) { 2771 return IO::Socket::SSL->_internal_error( 2772 "ECDH curve needs Net::SSLeay>=1.56 and OpenSSL>=1.0",9) 2773 if ! $can_ecdh; 2774 2775 for(values %ctx) { 2776 if ($arg_hash->{SSL_server} and $curve eq 'auto') { 2777 if ($can_ecdh eq 'can_auto') { 2778 Net::SSLeay::CTX_set_ecdh_auto($_,1) or 2779 return IO::Socket::SSL->error( 2780 "failed to set ECDH curve context"); 2781 } elsif ($can_ecdh eq 'auto') { 2782 # automatically enabled anyway 2783 } else { 2784 return IO::Socket::SSL->error( 2785 "SSL_CTX_set_ecdh_auto not implemented"); 2786 } 2787 2788 } elsif ($set_groups_list) { 2789 $set_groups_list->($_,$curve) or return IO::Socket::SSL->error( 2790 "failed to set ECDH groups/curves on context"); 2791 # needed for OpenSSL 1.0.2 if ($can_ecdh eq 'can_auto') { 2792 Net::SSLeay::CTX_set_ecdh_auto($_,1) if $can_ecdh eq 'can_auto'; 2793 } elsif ($curve =~m{:}) { 2794 return IO::Socket::SSL->error( 2795 "SSL_CTX_groups_list or SSL_CTX_curves_list not implemented"); 2796 2797 } elsif ($arg_hash->{SSL_server}) { 2798 if ( $curve !~ /^\d+$/ ) { 2799 # name of curve, find NID 2800 $curve = Net::SSLeay::OBJ_txt2nid($curve) 2801 || return IO::Socket::SSL->error( 2802 "cannot find NID for curve name '$curve'"); 2803 } 2804 my $ecdh = Net::SSLeay::EC_KEY_new_by_curve_name($curve) or 2805 return IO::Socket::SSL->error( 2806 "cannot create curve for NID $curve"); 2807 for( values %ctx ) { 2808 Net::SSLeay::CTX_set_tmp_ecdh($_,$ecdh) or 2809 return IO::Socket::SSL->error( 2810 "failed to set ECDH curve context"); 2811 } 2812 Net::SSLeay::EC_KEY_free($ecdh); 2813 } 2814 } 2815 } 2816 2817 my $verify_cb = $arg_hash->{SSL_verify_callback}; 2818 my @accept_fp; 2819 if ( my $fp = $arg_hash->{SSL_fingerprint} ) { 2820 for( ref($fp) ? @$fp : $fp) { 2821 my ($algo,$pubkey,$digest) = m{^(?:([\w-]+)\$)?(pub\$)?([a-f\d:]+)$}i 2822 or return IO::Socket::SSL->_internal_error("invalid fingerprint '$_'",9); 2823 ( $digest = lc($digest) ) =~s{:}{}g; 2824 $algo ||= 2825 length($digest) == 32 ? 'md5' : 2826 length($digest) == 40 ? 'sha1' : 2827 length($digest) == 64 ? 'sha256' : 2828 return IO::Socket::SSL->_internal_error( 2829 "cannot detect hash algorithm from fingerprint '$_'",9); 2830 $algo = lc($algo); 2831 push @accept_fp,[ $algo, $pubkey || '', pack('H*',$digest) ] 2832 } 2833 } 2834 my $verify_fingerprint = @accept_fp && do { 2835 my $fail; 2836 sub { 2837 my ($ok,$cert,$depth) = @_; 2838 $fail = 1 if ! $ok; 2839 return 1 if $depth>0; # to let us continue with verification 2840 # Check fingerprint only from top certificate. 2841 my %fp; 2842 for(@accept_fp) { 2843 my $fp = $fp{$_->[0],$_->[1]} ||= $_->[1] 2844 ? Net::SSLeay::X509_pubkey_digest($cert,$algo2digest->($_->[0])) 2845 : Net::SSLeay::X509_digest($cert,$algo2digest->($_->[0])); 2846 next if $fp ne $_->[2]; 2847 return 1; 2848 } 2849 return ! $fail; 2850 } 2851 }; 2852 my $verify_callback = ( $verify_cb || @accept_fp ) && sub { 2853 my ($ok, $ctx_store) = @_; 2854 my ($certname,$cert,$error,$depth); 2855 if ($ctx_store) { 2856 $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store); 2857 $error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store); 2858 $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store); 2859 $certname = 2860 Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)). 2861 Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)); 2862 $error &&= Net::SSLeay::ERR_error_string($error); 2863 } 2864 $DEBUG>=3 && DEBUG( "ok=$ok [$depth] $certname" ); 2865 $ok = $verify_cb->($ok,$ctx_store,$certname,$error,$cert,$depth) if $verify_cb; 2866 $ok = $verify_fingerprint->($ok,$cert,$depth) if $verify_fingerprint && $cert; 2867 return $ok; 2868 }; 2869 2870 if ( $^O eq 'darwin' ) { 2871 # explicitly set error code to disable use of apples TEA patch 2872 # https://hynek.me/articles/apple-openssl-verification-surprises/ 2873 my $vcb = $verify_callback; 2874 $verify_callback = sub { 2875 my $rv = $vcb ? &$vcb : $_[0]; 2876 if ( $rv != 1 ) { 2877 # 50 - X509_V_ERR_APPLICATION_VERIFICATION: application verification failure 2878 Net::SSLeay::X509_STORE_CTX_set_error($_[1], 50); 2879 } 2880 return $rv; 2881 }; 2882 } 2883 Net::SSLeay::CTX_set_verify($_, $verify_mode, $verify_callback) 2884 for (values %ctx); 2885 2886 my $staple_callback = $arg_hash->{SSL_ocsp_staple_callback}; 2887 if ( !$is_server && $can_ocsp_staple && ! $verify_fingerprint) { 2888 $self->{ocsp_cache} = $arg_hash->{SSL_ocsp_cache}; 2889 my $status_cb = sub { 2890 my ($ssl,$resp) = @_; 2891 my $iossl = $SSL_OBJECT{$ssl} or 2892 die "no IO::Socket::SSL object found for SSL $ssl"; 2893 $iossl->[1] and do { 2894 # we must return with 1 or it will be called again 2895 # and because we have no SSL object we must make the error global 2896 Carp::cluck($IO::Socket::SSL::SSL_ERROR 2897 = "OCSP callback on server side"); 2898 return 1; 2899 }; 2900 $iossl = $iossl->[0]; 2901 2902 # if we have a callback use this 2903 # callback must not free or copy $resp !! 2904 if ( $staple_callback ) { 2905 $staple_callback->($iossl,$resp); 2906 return 1; 2907 } 2908 2909 # default callback does verification 2910 if ( ! $resp ) { 2911 $DEBUG>=3 && DEBUG("did not get stapled OCSP response"); 2912 return 1; 2913 } 2914 $DEBUG>=3 && DEBUG("got stapled OCSP response"); 2915 my $status = Net::SSLeay::OCSP_response_status($resp); 2916 if ($status != Net::SSLeay::OCSP_RESPONSE_STATUS_SUCCESSFUL()) { 2917 $DEBUG>=3 && DEBUG("bad status of stapled OCSP response: ". 2918 Net::SSLeay::OCSP_response_status_str($status)); 2919 return 1; 2920 } 2921 if (!eval { Net::SSLeay::OCSP_response_verify($ssl,$resp) }) { 2922 $DEBUG>=3 && DEBUG("verify of stapled OCSP response failed"); 2923 return 1; 2924 } 2925 my (@results,$hard_error); 2926 my @chain = $iossl->peer_certificates; 2927 for my $cert (@chain) { 2928 my $certid = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) }; 2929 if (!$certid) { 2930 $DEBUG>=3 && DEBUG("cannot create OCSP_CERTID: $@"); 2931 push @results,[-1,$@]; 2932 last; 2933 } 2934 ($status) = Net::SSLeay::OCSP_response_results($resp,$certid); 2935 if ($status && $status->[2]) { 2936 my $cache = ${*$iossl}{_SSL_ctx}{ocsp_cache}; 2937 if (!$status->[1]) { 2938 push @results,[1,$status->[2]{nextUpdate}]; 2939 $cache && $cache->put($certid,$status->[2]); 2940 } elsif ( $status->[2]{statusType} == 2941 Net::SSLeay::V_OCSP_CERTSTATUS_GOOD()) { 2942 push @results,[1,$status->[2]{nextUpdate}]; 2943 $cache && $cache->put($certid,{ 2944 %{$status->[2]}, 2945 expire => time()+120, 2946 soft_error => $status->[1], 2947 }); 2948 } else { 2949 push @results,($hard_error = [0,$status->[1]]); 2950 $cache && $cache->put($certid,{ 2951 %{$status->[2]}, 2952 hard_error => $status->[1], 2953 }); 2954 } 2955 } 2956 } 2957 # return result of lead certificate, this should be in chain[0] and 2958 # thus result[0], but we better check. But if we had any hard_error 2959 # return this instead 2960 if ($hard_error) { 2961 ${*$iossl}{_SSL_ocsp_verify} = $hard_error; 2962 } elsif (@results and $chain[0] == $iossl->peer_certificate) { 2963 ${*$iossl}{_SSL_ocsp_verify} = $results[0]; 2964 } 2965 return 1; 2966 }; 2967 Net::SSLeay::CTX_set_tlsext_status_cb($_,$status_cb) for (values %ctx); 2968 } 2969 2970 if ( my $cl = $arg_hash->{SSL_cipher_list} ) { 2971 for (keys %ctx) { 2972 Net::SSLeay::CTX_set_cipher_list($ctx{$_}, ref($cl) 2973 ? $cl->{$_} || $cl->{''} || $DEFAULT_SSL_ARGS{SSL_cipher_list} || next 2974 : $cl 2975 ) || return IO::Socket::SSL->error("Failed to set SSL cipher list"); 2976 } 2977 } 2978 2979 # Main context is default context or any other if no default context. 2980 my $ctx = $ctx{''} || (values %ctx)[0]; 2981 if (keys(%ctx) > 1 || ! exists $ctx{''}) { 2982 $can_server_sni or return IO::Socket::SSL->_internal_error( 2983 "Server side SNI not supported for this openssl/Net::SSLeay",9); 2984 2985 Net::SSLeay::CTX_set_tlsext_servername_callback($ctx, sub { 2986 my $ssl = shift; 2987 my $host = Net::SSLeay::get_servername($ssl); 2988 $host = '' if ! defined $host; 2989 my $snictx = $ctx{lc($host)} || $ctx{''} or do { 2990 $DEBUG>1 and DEBUG( 2991 "cannot get context from servername '$host'"); 2992 return 2; # SSL_TLSEXT_ERR_ALERT_FATAL 2993 }; 2994 $DEBUG>1 and DEBUG("set context from servername $host"); 2995 Net::SSLeay::set_SSL_CTX($ssl,$snictx) if $snictx != $ctx; 2996 return 0; # SSL_TLSEXT_ERR_OK 2997 }); 2998 } 2999 3000 if ( my $cb = $arg_hash->{SSL_create_ctx_callback} ) { 3001 $cb->($_) for values (%ctx); 3002 } 3003 3004 $self->{context} = $ctx; 3005 $self->{verify_mode} = $arg_hash->{SSL_verify_mode}; 3006 $self->{ocsp_mode} = 3007 defined($arg_hash->{SSL_ocsp_mode}) ? $arg_hash->{SSL_ocsp_mode} : 3008 $self->{verify_mode} ? IO::Socket::SSL::SSL_OCSP_TRY_STAPLE() : 3009 0; 3010 $DEBUG>=3 && DEBUG( "new ctx $ctx" ); 3011 3012 if ( my $cache = $arg_hash->{SSL_session_cache} ) { 3013 # use predefined cache 3014 $self->{session_cache} = $cache 3015 } elsif ( my $size = $arg_hash->{SSL_session_cache_size}) { 3016 $self->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size ); 3017 } 3018 3019 3020 if ($self->{session_cache} and %sess_cb) { 3021 Net::SSLeay::CTX_set_session_cache_mode($ctx, 3022 Net::SSLeay::SESS_CACHE_CLIENT()); 3023 my $cache = $self->{session_cache}; 3024 $sess_cb{new}($ctx, sub { 3025 my ($ssl,$session) = @_; 3026 my $self = ($SSL_OBJECT{$ssl} || do { 3027 warn "callback session new: no known SSL object for $ssl"; 3028 return; 3029 })->[0]; 3030 my $args = ${*$self}{_SSL_arguments}; 3031 my $key = $args->{SSL_session_key} or do { 3032 warn "callback session new: no known SSL_session_key for $ssl"; 3033 return; 3034 }; 3035 $DEBUG>=3 && DEBUG("callback session new <$key> $session"); 3036 Net::SSLeay::SESSION_up_ref($session); 3037 $cache->add_session($key,$session); 3038 }); 3039 $sess_cb{remove}($ctx, sub { 3040 my ($ctx,$session) = @_; 3041 $DEBUG>=3 && DEBUG("callback session remove $session"); 3042 $cache->del_session(undef,$session); 3043 }); 3044 } 3045 3046 return $self; 3047} 3048 3049 3050sub has_session_cache { 3051 return defined shift->{session_cache}; 3052} 3053 3054 3055sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); } 3056sub DESTROY { 3057 my $self = shift; 3058 if ( my $ctx = $self->{context} ) { 3059 $DEBUG>=3 && DEBUG("free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD )); 3060 if (!$use_threads or delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) { 3061 # remove any verify callback for this context 3062 if ( $self->{verify_mode}) { 3063 $DEBUG>=3 && DEBUG("free ctx $ctx callback" ); 3064 Net::SSLeay::CTX_set_verify($ctx, 0,undef); 3065 } 3066 if ( $self->{ocsp_error_ref}) { 3067 $DEBUG>=3 && DEBUG("free ctx $ctx tlsext_status_cb" ); 3068 Net::SSLeay::CTX_set_tlsext_status_cb($ctx,undef); 3069 } 3070 $DEBUG>=3 && DEBUG("OK free ctx $ctx" ); 3071 Net::SSLeay::CTX_free($ctx); 3072 } 3073 } 3074 delete(@{$self}{'context','session_cache'}); 3075} 3076 3077package IO::Socket::SSL::Session_Cache; 3078*DEBUG = *IO::Socket::SSL::DEBUG; 3079use constant { 3080 SESSION => 0, 3081 KEY => 1, 3082 GNEXT => 2, 3083 GPREV => 3, 3084 SNEXT => 4, 3085 SPREV => 5, 3086}; 3087 3088sub new { 3089 my ($class, $size) = @_; 3090 $size>0 or return; 3091 return bless { 3092 room => $size, 3093 ghead => undef, 3094 shead => {}, 3095 }, $class; 3096} 3097 3098sub add_session { 3099 my ($self, $key, $session) = @_; 3100 3101 # create new 3102 my $v = []; 3103 $v->[SESSION] = $session; 3104 $v->[KEY] = $key; 3105 $DEBUG>=3 && DEBUG("add_session($key,$session)"); 3106 _add_entry($self,$v); 3107} 3108 3109sub replace_session { 3110 my ($self, $key, $session) = @_; 3111 $self->del_session($key); 3112 $self->add_session($key, $session); 3113} 3114 3115sub del_session { 3116 my ($self, $key, $session) = @_; 3117 my ($head,$inext) = $key 3118 ? ($self->{shead}{$key},SNEXT) : ($self->{ghead},GNEXT); 3119 my $v = $head; 3120 my @del; 3121 while ($v) { 3122 if (!$session) { 3123 push @del,$v 3124 } elsif ($v->[SESSION] == $session) { 3125 push @del, $v; 3126 last; 3127 } 3128 $v = $v->[$inext]; 3129 last if $v == $head; 3130 } 3131 $DEBUG>=3 && DEBUG("del_session(" 3132 . ($key ? $key : "undef") 3133 . ($session ? ",$session) -> " : ") -> ") 3134 . (~~@del || 'none')); 3135 for (@del) { 3136 _del_entry($self,$_); 3137 Net::SSLeay::SESSION_free($_->[SESSION]) if $_->[SESSION]; 3138 } 3139 return ~~@del; 3140} 3141 3142sub get_session { 3143 my ($self, $key, $session) = @_; 3144 my $v = $self->{shead}{$key}; 3145 if ($session) { 3146 my $shead = $v; 3147 while ($v) { 3148 $DEBUG>=3 && DEBUG("check $session - $v->[SESSION]"); 3149 last if $v->[SESSION] == $session; 3150 $v = $v->[SNEXT]; 3151 $v = undef if $v == $shead; # session not found 3152 } 3153 } 3154 if ($v) { 3155 _del_entry($self, $v); # remove 3156 _add_entry($self, $v); # and add back on top 3157 } 3158 $DEBUG>=3 && DEBUG("get_session($key" 3159 . ( $session ? ",$session) -> " : ") -> ") 3160 . ($v? $v->[SESSION]:"none")); 3161 return $v && $v->[SESSION]; 3162} 3163 3164sub _add_entry { 3165 my ($self,$v) = @_; 3166 for( 3167 [ SNEXT, SPREV, \$self->{shead}{$v->[KEY]} ], 3168 [ GNEXT, GPREV, \$self->{ghead} ], 3169 ) { 3170 my ($inext,$iprev,$rhead) = @$_; 3171 if ($$rhead) { 3172 $v->[$inext] = $$rhead; 3173 $v->[$iprev] = ${$rhead}->[$iprev]; 3174 ${$rhead}->[$iprev][$inext] = $v; 3175 ${$rhead}->[$iprev] = $v; 3176 } else { 3177 $v->[$inext] = $v->[$iprev] = $v; 3178 } 3179 $$rhead = $v; 3180 } 3181 3182 $self->{room}--; 3183 3184 # drop old entries if necessary 3185 if ($self->{room}<0) { 3186 my $l = $self->{ghead}[GPREV]; 3187 _del_entry($self,$l); 3188 Net::SSLeay::SESSION_free($l->[SESSION]) if $l->[SESSION]; 3189 } 3190} 3191 3192sub _del_entry { 3193 my ($self,$v) = @_; 3194 for( 3195 [ SNEXT, SPREV, \$self->{shead}{$v->[KEY]} ], 3196 [ GNEXT, GPREV, \$self->{ghead} ], 3197 ) { 3198 my ($inext,$iprev,$rhead) = @$_; 3199 $$rhead or return; 3200 $v->[$inext][$iprev] = $v->[$iprev]; 3201 $v->[$iprev][$inext] = $v->[$inext]; 3202 if ($v != $$rhead) { 3203 # not removed from top of list 3204 } elsif ($v->[$inext] == $v) { 3205 # was only element on list, drop list 3206 if ($inext == SNEXT) { 3207 delete $self->{shead}{$v->[KEY]}; 3208 } else { 3209 $$rhead = undef; 3210 } 3211 } else { 3212 # was top element, keep others 3213 $$rhead = $v->[$inext]; 3214 } 3215 } 3216 $self->{room}++; 3217} 3218 3219sub _dump { 3220 my $self = shift; 3221 3222 my %v2i; 3223 my $v = $self->{ghead}; 3224 while ($v) { 3225 exists $v2i{$v} and die; 3226 $v2i{$v} = int(keys %v2i); 3227 $v = $v->[GNEXT]; 3228 last if $v == $self->{ghead}; 3229 } 3230 3231 my $out = "room: $self->{room}\nghead:\n"; 3232 $v = $self->{ghead}; 3233 while ($v) { 3234 $out .= sprintf(" - [%d] <%d,%d> '%s' <%s>\n", 3235 $v2i{$v}, $v2i{$v->[GPREV]}, $v2i{$v->[GNEXT]}, 3236 $v->[KEY], $v->[SESSION]); 3237 $v = $v->[GNEXT]; 3238 last if $v == $self->{ghead}; 3239 } 3240 $out .= "shead:\n"; 3241 for my $key (sort keys %{$self->{shead}}) { 3242 $out .= " - '$key'\n"; 3243 my $shead = $self->{shead}{$key}; 3244 my $v = $shead; 3245 while ($v) { 3246 $out .= sprintf(" - [%d] <%d,%d> '%s' <%s>\n", 3247 $v2i{$v}, $v2i{$v->[SPREV]}, $v2i{$v->[SNEXT]}, 3248 $v->[KEY], $v->[SESSION]); 3249 $v = $v->[SNEXT]; 3250 last if $v == $shead; 3251 } 3252 } 3253 return $out; 3254} 3255 3256sub DESTROY { 3257 my $self = shift; 3258 delete $self->{shead}; 3259 my $v = delete $self->{ghead}; 3260 while ($v) { 3261 Net::SSLeay::SESSION_free($v->[SESSION]) if $v->[SESSION]; 3262 my $next = $v->[GNEXT]; 3263 @$v = (); 3264 $v = $next; 3265 } 3266} 3267 3268 3269 3270package IO::Socket::SSL::OCSP_Cache; 3271 3272sub new { 3273 my ($class,$size) = @_; 3274 return bless { 3275 '' => { _lru => 0, size => $size || 100 } 3276 },$class; 3277} 3278sub get { 3279 my ($self,$id) = @_; 3280 my $e = $self->{$id} or return; 3281 $e->{_lru} = $self->{''}{_lru}++; 3282 if ( $e->{expire} && time()<$e->{expire}) { 3283 delete $self->{$id}; 3284 return; 3285 } 3286 if ( $e->{nextUpdate} && time()<$e->{nextUpdate} ) { 3287 delete $self->{$id}; 3288 return; 3289 } 3290 return $e; 3291} 3292 3293sub put { 3294 my ($self,$id,$e) = @_; 3295 $self->{$id} = $e; 3296 $e->{_lru} = $self->{''}{_lru}++; 3297 my $del = keys(%$self) - $self->{''}{size}; 3298 if ($del>0) { 3299 my @k = sort { $self->{$a}{_lru} <=> $self->{$b}{_lru} } keys %$self; 3300 delete @{$self}{ splice(@k,0,$del) }; 3301 } 3302 return $e; 3303} 3304 3305package IO::Socket::SSL::OCSP_Resolver; 3306*DEBUG = *IO::Socket::SSL::DEBUG; 3307 3308# create a new resolver 3309# $ssl - the ssl object 3310# $cache - OCSP_Cache object (put,get) 3311# $failhard - flag if we should fail hard on OCSP problems 3312# $certs - list of certs to verify 3313sub new { 3314 my ($class,$ssl,$cache,$failhard,$certs) = @_; 3315 my (%todo,$done,$hard_error,@soft_error); 3316 for my $cert (@$certs) { 3317 # skip entries which have no OCSP uri or where we cannot get a certid 3318 # (e.g. self-signed or where we don't have the issuer) 3319 my $subj = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)); 3320 my $uri = Net::SSLeay::P_X509_get_ocsp_uri($cert) or do { 3321 $DEBUG>2 && DEBUG("no URI for certificate $subj"); 3322 push @soft_error,"no ocsp_uri for $subj"; 3323 next; 3324 }; 3325 my $certid = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) } or do { 3326 $DEBUG>2 && DEBUG("no OCSP_CERTID for certificate $subj: $@"); 3327 push @soft_error,"no certid for $subj: $@"; 3328 next; 3329 }; 3330 if (!($done = $cache->get($certid))) { 3331 push @{ $todo{$uri}{ids} }, $certid; 3332 push @{ $todo{$uri}{subj} }, $subj; 3333 } elsif ( $done->{hard_error} ) { 3334 # one error is enough to fail validation 3335 $hard_error = $done->{hard_error}; 3336 %todo = (); 3337 last; 3338 } elsif ( $done->{soft_error} ) { 3339 push @soft_error,$done->{soft_error}; 3340 } 3341 } 3342 while ( my($uri,$v) = each %todo) { 3343 my $ids = $v->{ids}; 3344 $v->{req} = Net::SSLeay::i2d_OCSP_REQUEST( 3345 Net::SSLeay::OCSP_ids2req(@$ids)); 3346 } 3347 $hard_error ||= '' if ! %todo; 3348 return bless { 3349 ssl => $ssl, 3350 cache => $cache, 3351 failhard => $failhard, 3352 hard_error => $hard_error, 3353 soft_error => @soft_error ? join("; ",@soft_error) : undef, 3354 todo => \%todo, 3355 },$class; 3356} 3357 3358# return current result, e.g. '' for no error, else error 3359# if undef we have no final result yet 3360sub hard_error { return shift->{hard_error} } 3361sub soft_error { return shift->{soft_error} } 3362 3363# return hash with uri => ocsp_request_data for open requests 3364sub requests { 3365 my $todo = shift()->{todo}; 3366 return map { ($_,$todo->{$_}{req}) } keys %$todo; 3367} 3368 3369# add new response 3370sub add_response { 3371 my ($self,$uri,$resp) = @_; 3372 my $todo = delete $self->{todo}{$uri}; 3373 return $self->{error} if ! $todo || $self->{error}; 3374 3375 my ($req,@soft_error,@hard_error); 3376 3377 # do we have a response 3378 if (!$resp) { 3379 @soft_error = "http request for OCSP failed; subject: ". 3380 join("; ",@{$todo->{subj}}); 3381 3382 # is it a valid OCSP_RESPONSE 3383 } elsif ( ! eval { $resp = Net::SSLeay::d2i_OCSP_RESPONSE($resp) }) { 3384 @soft_error = "invalid response (no OCSP_RESPONSE); subject: ". 3385 join("; ",@{$todo->{subj}}); 3386 # hopefully short-time error 3387 $self->{cache}->put($_,{ 3388 soft_error => "@soft_error", 3389 expire => time()+10, 3390 }) for (@{$todo->{ids}}); 3391 # is the OCSP response status success 3392 } elsif ( 3393 ( my $status = Net::SSLeay::OCSP_response_status($resp)) 3394 != Net::SSLeay::OCSP_RESPONSE_STATUS_SUCCESSFUL() 3395 ){ 3396 @soft_error = "OCSP response failed: ". 3397 Net::SSLeay::OCSP_response_status_str($status). 3398 "; subject: ".join("; ",@{$todo->{subj}}); 3399 # hopefully short-time error 3400 $self->{cache}->put($_,{ 3401 soft_error => "@soft_error", 3402 expire => time()+10, 3403 }) for (@{$todo->{ids}}); 3404 3405 # does nonce match the request and can the signature be verified 3406 } elsif ( ! eval { 3407 $req = Net::SSLeay::d2i_OCSP_REQUEST($todo->{req}); 3408 Net::SSLeay::OCSP_response_verify($self->{ssl},$resp,$req); 3409 }) { 3410 if ($@) { 3411 @soft_error = $@ 3412 } else { 3413 my @err; 3414 while ( my $err = Net::SSLeay::ERR_get_error()) { 3415 push @soft_error, Net::SSLeay::ERR_error_string($err); 3416 } 3417 @soft_error = 'failed to verify OCSP response; subject: '. 3418 join("; ",@{$todo->{subj}}) if ! @soft_error; 3419 } 3420 # configuration problem or we don't know the signer 3421 $self->{cache}->put($_,{ 3422 soft_error => "@soft_error", 3423 expire => time()+120, 3424 }) for (@{$todo->{ids}}); 3425 3426 # extract results from response 3427 } elsif ( my @result = 3428 Net::SSLeay::OCSP_response_results($resp,@{$todo->{ids}})) { 3429 my (@found,@miss); 3430 for my $rv (@result) { 3431 if ($rv->[2]) { 3432 push @found,$rv->[0]; 3433 if (!$rv->[1]) { 3434 # no error 3435 $self->{cache}->put($rv->[0],$rv->[2]); 3436 } elsif ( $rv->[2]{statusType} == 3437 Net::SSLeay::V_OCSP_CERTSTATUS_GOOD()) { 3438 # soft error, like response after nextUpdate 3439 push @soft_error,$rv->[1]."; subject: ". 3440 join("; ",@{$todo->{subj}}); 3441 $self->{cache}->put($rv->[0],{ 3442 %{$rv->[2]}, 3443 soft_error => "@soft_error", 3444 expire => time()+120, 3445 }); 3446 } else { 3447 # hard error 3448 $self->{cache}->put($rv->[0],$rv->[2]); 3449 push @hard_error, $rv->[1]."; subject: ". 3450 join("; ",@{$todo->{subj}}); 3451 } 3452 } else { 3453 push @miss,$rv->[0]; 3454 } 3455 } 3456 if (@miss && @found) { 3457 # we sent multiple responses, but server answered only to one 3458 # try again 3459 $self->{todo}{$uri} = $todo; 3460 $todo->{ids} = \@miss; 3461 $todo->{req} = Net::SSLeay::i2d_OCSP_REQUEST( 3462 Net::SSLeay::OCSP_ids2req(@miss)); 3463 $DEBUG>=2 && DEBUG("$uri just answered ".@found." of ".(@found+@miss)." requests"); 3464 } 3465 } else { 3466 @soft_error = "no data in response; subject: ". 3467 join("; ",@{$todo->{subj}}); 3468 # probably configuration problem 3469 $self->{cache}->put($_,{ 3470 soft_error => "@soft_error", 3471 expire => time()+120, 3472 }) for (@{$todo->{ids}}); 3473 } 3474 3475 Net::SSLeay::OCSP_REQUEST_free($req) if $req; 3476 if ($self->{failhard}) { 3477 push @hard_error,@soft_error; 3478 @soft_error = (); 3479 } 3480 if (@soft_error) { 3481 $self->{soft_error} .= "; " if $self->{soft_error}; 3482 $self->{soft_error} .= "$uri: ".join('; ',@soft_error); 3483 } 3484 if (@hard_error) { 3485 $self->{hard_error} = "$uri: ".join('; ',@hard_error); 3486 %{$self->{todo}} = (); 3487 } elsif ( ! %{$self->{todo}} ) { 3488 $self->{hard_error} = '' 3489 } 3490 return $self->{hard_error}; 3491} 3492 3493# make all necessary requests to get OCSP responses blocking 3494sub resolve_blocking { 3495 my ($self,%args) = @_; 3496 while ( my %todo = $self->requests ) { 3497 eval { require HTTP::Tiny } or die "need HTTP::Tiny installed"; 3498 # OCSP responses have their own signature, so we don't need SSL verification 3499 my $ua = HTTP::Tiny->new(verify_SSL => 0,%args); 3500 while (my ($uri,$reqdata) = each %todo) { 3501 $DEBUG && DEBUG("sending OCSP request to $uri"); 3502 my $resp = $ua->request('POST',$uri, { 3503 headers => { 'Content-type' => 'application/ocsp-request' }, 3504 content => $reqdata 3505 }); 3506 $DEBUG && DEBUG("got OCSP response from $uri code=$resp->{status}"); 3507 defined ($self->add_response($uri, 3508 $resp->{success} && $resp->{content})) 3509 && last; 3510 } 3511 } 3512 $DEBUG>=2 && DEBUG("no more open OCSP requests"); 3513 return $self->{hard_error}; 3514} 3515 35161; 3517 3518__END__ 3519