1package Net::SSL; 2 3use strict; 4use MIME::Base64; 5use Socket; 6use Carp; 7 8use vars qw(@ISA $VERSION $NEW_ARGS); 9$VERSION = '2.85'; 10 11require IO::Socket; 12@ISA=qw(IO::Socket::INET); 13 14my %REAL; # private to this package only 15my $DEFAULT_VERSION = '23'; 16my $CRLF = "\015\012"; 17my $SEND_USERAGENT_TO_PROXY = 0; 18 19require Crypt::SSLeay; 20 21sub _default_context { 22 require Crypt::SSLeay::MainContext; 23 Crypt::SSLeay::MainContext::main_ctx(@_); 24} 25 26sub _alarm_set { 27 return if $^O eq 'MSWin32' or $^O eq 'NetWare'; 28 alarm(shift); 29} 30 31sub new { 32 my($class, %arg) = @_; 33 local $NEW_ARGS = \%arg; 34 $class->SUPER::new(%arg); 35} 36 37sub DESTROY { 38 my $self = shift; 39 delete $REAL{$self}; 40 local $@; 41 eval { $self->SUPER::DESTROY; }; 42} 43 44sub configure { 45 my($self, $arg) = @_; 46 my $ssl_version = delete $arg->{SSL_Version} || 47 $ENV{HTTPS_VERSION} || $DEFAULT_VERSION; 48 my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0; 49 50 my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version); 51 52 *$self->{ssl_ctx} = $ctx; 53 *$self->{ssl_version} = $ssl_version; 54 *$self->{ssl_debug} = $ssl_debug; 55 *$self->{ssl_arg} = $arg; 56 *$self->{ssl_peer_addr} = $arg->{PeerAddr}; 57 *$self->{ssl_peer_port} = $arg->{PeerPort}; 58 *$self->{ssl_new_arg} = $NEW_ARGS; 59 *$self->{ssl_peer_verify} = 0; 60 61 ## Crypt::SSLeay must also aware the SSL Proxy before calling 62 ## $socket->configure($args). Because the $sock->configure() will 63 ## die when failed to resolve the destination server IP address, 64 ## whether the SSL proxy is used or not! 65 ## - dqbai, 2003-05-10 66 if (my $proxy = $self->proxy) { 67 ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy); 68 $arg->{PeerPort} || croak("no port given for proxy server $proxy"); 69 } 70 71 $self->SUPER::configure($arg); 72} 73 74# override to make sure there is really a timeout 75sub timeout { 76 shift->SUPER::timeout || 60; 77} 78 79sub blocking { 80 my $self = shift; 81 $self->SUPER::blocking(@_); 82} 83 84sub connect { 85 my $self = shift; 86 87 # configure certs on connect() time, so we can throw an undef 88 # and have LWP understand the error 89 eval { $self->configure_certs() }; 90 if($@) { 91 $@ = "configure certs failed: $@; $!"; 92 $self->die_with_error($@); 93 } 94 95 # finished, update set_verify status 96 if(my $rv = *$self->{ssl_ctx}->set_verify()) { 97 *$self->{ssl_peer_verify} = $rv; 98 } 99 100 if ($self->proxy) { 101 # don't die() in connect, just return undef and set $@ 102 my $proxy_connect = eval { $self->proxy_connect_helper(@_) }; 103 if(! $proxy_connect || $@) { 104 $@ = "proxy connect failed: $@; $!"; 105 croak($@); 106 } 107 } 108 else { 109 *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_); 110 if(!$self->SUPER::connect(@_)) { 111 # better to die than return here 112 $@ = "Connect failed: $@; $!"; 113 croak($@); 114 } 115 } 116 117 my $debug = *$self->{ssl_debug} || 0; 118 my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self); 119 my $arg = *$self->{ssl_arg}; 120 my $new_arg = *$self->{ssl_new_arg}; 121 $arg->{SSL_Debug} = $debug; 122 123 # setup SNI if available 124 $ssl->can("set_tlsext_host_name") and 125 $ssl->set_tlsext_host_name(*$self->{ssl_peer_addr}); 126 127 eval { 128 local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") }; 129 # timeout / 2 because we have 3 possible connects here 130 _alarm_set($self->timeout / 2); 131 132 my $rv; 133 { 134 local $SIG{PIPE} = \¨ 135 $rv = eval { $ssl->connect; }; 136 } 137 if (not defined $rv or $rv <= 0) { 138 _alarm_set(0); 139 $ssl = undef; 140 # See RT #59312 141 my %args = (%$arg, %$new_arg); 142 if(*$self->{ssl_version} == 23) { 143 $args{SSL_Version} = 3; 144 # the new connect might itself be overridden with a REAL SSL 145 my $new_ssl = Net::SSL->new(%args); 146 $REAL{$self} = $REAL{$new_ssl} || $new_ssl; 147 return $REAL{$self}; 148 } 149 elsif(*$self->{ssl_version} == 3) { 150 # $self->die_with_error("SSL negotiation failed"); 151 $args{SSL_Version} = 2; 152 my $new_ssl = Net::SSL->new(%args); 153 $REAL{$self} = $new_ssl; 154 return $new_ssl; 155 } 156 else { 157 # don't die, but do set $@, and return undef 158 eval { $self->die_with_error("SSL negotiation failed") }; 159 croak($@); 160 } 161 } 162 _alarm_set(0); 163 }; 164 165 # odd error in eval {} block, maybe alarm outside the evals 166 if($@) { 167 $@ = "$@; $!"; 168 croak($@); 169 } 170 171 # successful SSL connection gets stored 172 *$self->{ssl_ssl} = $ssl; 173 $self; 174} 175 176# Delegate these calls to the Crypt::SSLeay::Conn object 177sub get_peer_certificate { 178 my $self = shift; 179 $self = $REAL{$self} || $self; 180 *$self->{ssl_ssl}->get_peer_certificate(@_); 181} 182 183sub get_peer_verify { 184 my $self = shift; 185 $self = $REAL{$self} || $self; 186 *$self->{ssl_peer_verify}; 187} 188 189sub get_shared_ciphers { 190 my $self = shift; 191 $self = $REAL{$self} || $self; 192 *$self->{ssl_ssl}->get_shared_ciphers(@_); 193} 194 195sub get_cipher { 196 my $self = shift; 197 $self = $REAL{$self} || $self; 198 *$self->{ssl_ssl}->get_cipher(@_); 199} 200 201sub ssl_context { 202 my $self = shift; 203 $self = $REAL{$self} || $self; 204 *$self->{ssl_ctx}; 205} 206 207sub die_with_error { 208 my $self=shift; 209 my $reason=shift; 210 211 my @err; 212 while(my $err=Crypt::SSLeay::Err::get_error_string()) { 213 push @err, $err; 214 } 215 croak("$reason: " . join( ' | ', @err )); 216} 217 218sub read { 219 my $self = shift; 220 $self = $REAL{$self} || $self; 221 222 local $SIG{__DIE__} = \&Carp::confess; 223 local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") }; 224 225 _alarm_set($self->timeout); 226 my $n = *$self->{ssl_ssl}->read(@_); 227 _alarm_set(0); 228 $self->die_with_error("read failed") if !defined $n; 229 230 $n; 231} 232 233sub write { 234 my $self = shift; 235 $self = $REAL{$self} || $self; 236 my $n = *$self->{ssl_ssl}->write(@_); 237 $self->die_with_error("write failed") if !defined $n; 238 $n; 239} 240 241*sysread = \&read; 242*syswrite = \&write; 243 244sub print { 245 my $self = shift; 246 $self = $REAL{$self} || $self; 247 # should we care about $, and $\?? 248 # I think it is too expensive... 249 $self->write(join("", @_)); 250} 251 252sub printf { 253 my $self = shift; 254 $self = $REAL{$self} || $self; 255 my $fmt = shift; 256 $self->write(sprintf($fmt, @_)); 257} 258 259sub getchunk { 260 my $self = shift; 261 $self = $REAL{$self} || $self; 262 my $buf = ''; # warnings 263 my $n = $self->read($buf, 32768); 264 return unless defined $n; 265 $buf; 266} 267 268# This is really inefficient, but we only use it for reading the proxy response 269# so that does not really matter. 270sub getline { 271 my $self = shift; 272 $self = $REAL{$self} || $self; 273 my $val=""; 274 my $buf; 275 do { 276 $self->SUPER::recv($buf, 1); 277 $val .= $buf; 278 } until ($buf eq "\n"); 279 280 $val; 281} 282 283# XXX: no way to disable <$sock>?? (tied handle perhaps?) 284 285sub get_lwp_object { 286 my $self = shift; 287 288 my $lwp_object; 289 my $i = 0; 290 while(1) { 291 package DB; 292 my @stack = caller($i++); 293 last unless @stack; 294 my @stack_args = @DB::args; 295 my $stack_object = $stack_args[0] || next; 296 return $stack_object 297 if ref($stack_object) 298 and $stack_object->isa('LWP::UserAgent'); 299 } 300 return undef; 301} 302 303sub send_useragent_to_proxy { 304 if (my $val = shift) { 305 $SEND_USERAGENT_TO_PROXY = $val; 306 } 307 return $SEND_USERAGENT_TO_PROXY; 308} 309 310sub proxy_connect_helper { 311 my $self = shift; 312 313 my $proxy = $self->proxy; 314 my ($proxy_host, $proxy_port) = split(':',$proxy); 315 $proxy_port || croak("no port given for proxy server $proxy"); 316 317 my $proxy_addr = gethostbyname($proxy_host); 318 $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!"); 319 320 my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr}); 321 $peer_addr || croak("no peer addr given"); 322 $peer_port || croak("no peer port given"); 323 324 # see if the proxy should be bypassed 325 my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || ''); 326 my $is_proxied = 1; 327 my $domain; 328 for $domain (@no_proxy) { 329 if ($peer_addr =~ /\Q$domain\E$/) { 330 $is_proxied = 0; 331 last; 332 } 333 } 334 335 if ($is_proxied) { 336 $self->SUPER::connect($proxy_port, $proxy_addr) 337 || croak("proxy connect to $proxy_host:$proxy_port failed: $!"); 338 } 339 else { 340 # see RT #57836 341 my $peer_addr_packed = gethostbyname($peer_addr); 342 $self->SUPER::connect($peer_port, $peer_addr_packed) 343 || croak("proxy bypass to $peer_addr:$peer_addr failed: $!"); 344 } 345 346 my $connect_string; 347 if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) { 348 my $user = $ENV{"HTTPS_PROXY_USERNAME"}; 349 my $pass = $ENV{"HTTPS_PROXY_PASSWORD"}; 350 351 my $credentials = encode_base64("$user:$pass", ""); 352 $connect_string = join($CRLF, 353 "CONNECT $peer_addr:$peer_port HTTP/1.0", 354 "Proxy-authorization: Basic $credentials" 355 ); 356 } 357 else { 358 $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0"; 359 } 360 $connect_string .= $CRLF; 361 362 if (send_useragent_to_proxy()) { 363 my $lwp_object = $self->get_lwp_object; 364 if($lwp_object && $lwp_object->agent) { 365 $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF; 366 } 367 } 368 369 $connect_string .= $CRLF; 370 $self->SUPER::send($connect_string); 371 372 my $timeout; 373 my $header = ''; 374 375 # See RT #33954 376 # See also RT #64054 377 # Handling incomplete reads and writes better (for some values of 378 # better) may actually make this problem go away, but either way, 379 # there is no good reason to use \d when checking for 0-9 380 381 while ($header !~ m{HTTP/[0-9][.][0-9]\s+200\s+.*$CRLF$CRLF}) { 382 $timeout = $self->timeout(5) unless length $header; 383 my $n = $self->SUPER::sysread($header, 8192, length $header); 384 last if $n <= 0; 385 } 386 387 $self->timeout($timeout) if defined $timeout; 388 my $conn_ok = ($header =~ m{HTTP/[0-9]+[.][0-9]+\s+200\s+}is) ? 1 : 0; 389 390 if (not $conn_ok) { 391 croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header"); 392 } 393 394 $conn_ok; 395} 396 397# code adapted from LWP::UserAgent, with $ua->env_proxy API 398# see also RT #57836 399sub proxy { 400 my $self = shift; 401 my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy}; 402 return unless $proxy_server; 403 404 my($peer_port, $peer_addr) = ( 405 *$self->{ssl_peer_port}, 406 *$self->{ssl_peer_addr} 407 ); 408 $peer_addr || croak("no peer addr given"); 409 $peer_port || croak("no peer port given"); 410 411 # see if the proxy should be bypassed 412 my @no_proxy = split( /\s*,\s*/, 413 $ENV{NO_PROXY} || $ENV{no_proxy} || '' 414 ); 415 my $is_proxied = 1; 416 for my $domain (@no_proxy) { 417 if ($peer_addr =~ /\Q$domain\E\z/) { 418 return; 419 } 420 } 421 422 $proxy_server =~ s|\Ahttps?://||i; 423 $proxy_server; 424} 425 426sub configure_certs { 427 my $self = shift; 428 my $ctx = *$self->{ssl_ctx}; 429 430 my $count = 0; 431 for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) { 432 my $file = $ENV{$_}; 433 if ($file) { 434 (-e $file) or croak("$file file does not exist: $!"); 435 (-r $file) or croak("$file file is not readable"); 436 $count++; 437 if (/PKCS12/) { 438 $count++; 439 $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!"); 440 last; 441 } 442 elsif (/CERT/) { 443 $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!"); 444 } 445 elsif (/KEY/) { 446 $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!"); 447 } 448 else { 449 croak("setting $_ not supported"); 450 } 451 } 452 } 453 454 # if both configs are set, then verify them 455 if ($count == 2) { 456 if (! $ctx->check_private_key) { 457 croak("Private key and certificate do not match"); 458 } 459 } 460 461 $count; # number of successful cert loads/checks 462} 463 464sub accept { shift->_unimpl("accept") } 465sub getc { shift->_unimpl("getc") } 466sub ungetc { shift->_unimpl("ungetc") } 467sub getlines { shift->_unimpl("getlines"); } 468 469sub _unimpl { 470 my($self, $meth) = @_; 471 croak("$meth not implemented for Net::SSL sockets"); 472} 473 4741; 475 476__END__ 477 478=head1 NAME 479 480Net::SSL - support for Secure Sockets Layer 481 482=head1 METHODS 483 484=over 4 485 486=item new 487 488Creates a new C<Net::SSL> object. 489 490=item configure 491 492Configures a C<Net::SSL> socket for operation. 493 494=item configure_certs 495 496Sets up a certificate file to use for communicating with on 497the socket. 498 499=item connect 500 501=item die_with_error 502 503=item get_cipher 504 505=item get_lwp_object 506 507Walks up the caller stack and looks for something blessed into 508the C<LWP::UserAgent> namespace and returns it. Vaguely deprecated. 509 510=item get_peer_certificate 511 512Gets the peer certificate from the underlying C<Crypt::SSLeay::Conn> 513object. 514 515=item get_peer_verify 516 517=item get_shared_ciphers 518 519=item getchunk 520 521Attempts to read up to 32KiB of data from the socket. Returns 522C<undef> if nothing was read, otherwise returns the data as 523a scalar. 524 525=item getline 526 527Reads one character at a time until a newline is encountered, 528and returns the line, including the newline. Grossly 529inefficient. 530 531=item print 532 533Concatenates the input parameters and writes them to the socket. 534Does not honour C<$,> nor C<$/>. Returns the number of bytes written. 535 536=item printf 537 538Performs a C<sprintf> of the input parameters (thus, the first 539parameter must be the format), and writes the result to the socket. 540Returns the number of bytes written. 541 542=item proxy 543 544Returns the hostname of an https proxy server, as specified by the 545C<HTTPS_PROXY> environment variable. 546 547=item proxy_connect_helper 548 549Helps set up a connection through a proxy. 550 551=item read 552 553Performs a read on the socket and returns the result. 554 555=item ssl_context 556 557=item sysread 558 559Is an alias of C<read>. 560 561=item timeout 562 563Returns the timeout value of the socket as defined by the implementing 564class or 60 seconds by default. 565 566=item blocking 567 568Returns a boolean indicating whether the underlying socket is in 569blocking mode. By default, Net::SSL sockets are in blocking mode. 570 571 $sock->blocking(0); # set to non-blocking mode 572 573This method simply calls the underlying C<blocking> method of the 574IO::Socket object. 575 576=item write 577 578Writes the parameters passed in (thus, a list) to the socket. Returns 579the number of bytes written. 580 581=item syswrite 582 583Is an alias of C<write>. 584 585=item accept 586 587Not yet implemented. Will die if called. 588 589=item getc 590 591Not yet implemented. Will die if called. 592 593=item getlines 594 595Not yet implemented. Will die if called. 596 597=item ungetc 598 599Not yet implemented. Will die if called. 600 601=item send_useragent_to_proxy 602 603By default (as of version 2.80 of C<Net::SSL> in the 0.54 distribution 604of Crypt::SSLeay), the user agent string is no longer sent to the 605proxy (but will continue to be sent to the remote host). 606 607The previous behaviour was of marginal benefit, and could cause 608fatal errors in certain scenarios (see CPAN bug #4759) and so no 609longer happens by default. 610 611To reinstate the old behaviour, call C<Net::SSL::send_useragent_to_proxy> 612with a true value (usually 1). 613 614=back 615 616=head1 DIAGNOSTICS 617 618 "no port given for proxy server <proxy>" 619 620A proxy was specified for configuring a socket, but no port number 621was given. Ensure that the proxy is specified as a host:port pair, 622such as C<proxy.example.com:8086>. 623 624 "configure certs failed: <contents of $@>; <contents of $!>" 625 626 "proxy connect failed: <contents of $@>; <contents of $!>" 627 628 "Connect failed: <contents of $@>; <contents of $!>" 629 630During connect(). 631 632=head2 SEE ALSO 633 634=over 4 635 636=item IO::Socket::INET 637 638C<Net::SSL> is implemented by subclassing C<IO::Socket::INET>, hence 639methods not specifically overridden are defined by that package. 640 641=item Net::SSLeay 642 643A package that provides a Perl-level interface to the C<openssl> 644secure sockets layer library. 645 646=back 647 648=cut 649 650