diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Net/SSL.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Net/SSL.pm | 607 |
1 files changed, 607 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Net/SSL.pm b/Master/tlpkg/tlperl0/lib/Net/SSL.pm new file mode 100755 index 00000000000..f14435aeb69 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Net/SSL.pm @@ -0,0 +1,607 @@ +package Net::SSL; + +use strict; +use MIME::Base64; +use Socket; +use Carp; + +use vars qw(@ISA $VERSION $NEW_ARGS); +$VERSION = '2.84'; + +require IO::Socket; +@ISA=qw(IO::Socket::INET); + +my %REAL; # private to this package only +my $DEFAULT_VERSION = '23'; +my $CRLF = "\015\012"; +my $SEND_USERAGENT_TO_PROXY = 0; + +require Crypt::SSLeay; + +sub _default_context { + require Crypt::SSLeay::MainContext; + Crypt::SSLeay::MainContext::main_ctx(@_); +} + +sub _alarm_set { + return if $^O eq 'MSWin32' or $^O eq 'NetWare'; + alarm(shift); +} + +sub new { + my($class, %arg) = @_; + local $NEW_ARGS = \%arg; + $class->SUPER::new(%arg); +} + +sub DESTROY { + my $self = shift; + delete $REAL{$self}; + local $@; + eval { $self->SUPER::DESTROY; }; +} + +sub configure { + my($self, $arg) = @_; + my $ssl_version = delete $arg->{SSL_Version} || + $ENV{HTTPS_VERSION} || $DEFAULT_VERSION; + my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0; + + my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version); + + *$self->{ssl_ctx} = $ctx; + *$self->{ssl_version} = $ssl_version; + *$self->{ssl_debug} = $ssl_debug; + *$self->{ssl_arg} = $arg; + *$self->{ssl_peer_addr} = $arg->{PeerAddr}; + *$self->{ssl_peer_port} = $arg->{PeerPort}; + *$self->{ssl_new_arg} = $NEW_ARGS; + *$self->{ssl_peer_verify} = 0; + + ## Crypt::SSLeay must also aware the SSL Proxy before calling + ## $socket->configure($args). Because the $sock->configure() will + ## die when failed to resolve the destination server IP address, + ## whether the SSL proxy is used or not! + ## - dqbai, 2003-05-10 + if (my $proxy = $self->proxy) { + ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy); + $arg->{PeerPort} || croak("no port given for proxy server $proxy"); + } + + $self->SUPER::configure($arg); +} + +# override to make sure there is really a timeout +sub timeout { + shift->SUPER::timeout || 60; +} + +sub blocking { + my $self = shift; + $self->SUPER::blocking(@_); +} + +sub connect { + my $self = shift; + + # configure certs on connect() time, so we can throw an undef + # and have LWP understand the error + eval { $self->configure_certs() }; + if($@) { + $@ = "configure certs failed: $@; $!"; + $self->die_with_error($@); + } + + # finished, update set_verify status + if(my $rv = *$self->{ssl_ctx}->set_verify()) { + *$self->{ssl_peer_verify} = $rv; + } + + if ($self->proxy) { + # don't die() in connect, just return undef and set $@ + my $proxy_connect = eval { $self->proxy_connect_helper(@_) }; + if(! $proxy_connect || $@) { + $@ = "proxy connect failed: $@; $!"; + croak($@); + } + } + else { + *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_); + if(!$self->SUPER::connect(@_)) { + # better to die than return here + $@ = "Connect failed: $@; $!"; + croak($@); + } + } + + my $debug = *$self->{ssl_debug} || 0; + my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self); + my $arg = *$self->{ssl_arg}; + my $new_arg = *$self->{ssl_new_arg}; + $arg->{SSL_Debug} = $debug; + + eval { + local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") }; + # timeout / 2 because we have 3 possible connects here + _alarm_set($self->timeout / 2); + + my $rv; + { + local $SIG{PIPE} = \¨ + $rv = eval { $ssl->connect; }; + } + if (not defined $rv or $rv <= 0) { + _alarm_set(0); + $ssl = undef; + my %args = (%$new_arg, %$arg); + if(*$self->{ssl_version} == 23) { + $args{SSL_Version} = 3; + # the new connect might itself be overridden with a REAL SSL + my $new_ssl = Net::SSL->new(%args); + $REAL{$self} = $REAL{$new_ssl} || $new_ssl; + return $REAL{$self}; + } + elsif(*$self->{ssl_version} == 3) { + # $self->die_with_error("SSL negotiation failed"); + $args{SSL_Version} = 2; + my $new_ssl = Net::SSL->new(%args); + $REAL{$self} = $new_ssl; + return $new_ssl; + } + else { + # don't die, but do set $@, and return undef + eval { $self->die_with_error("SSL negotiation failed") }; + croak($@); + } + } + _alarm_set(0); + }; + + # odd error in eval {} block, maybe alarm outside the evals + if($@) { + $@ = "$@; $!"; + croak($@); + } + + # successful SSL connection gets stored + *$self->{ssl_ssl} = $ssl; + $self; +} + +# Delegate these calls to the Crypt::SSLeay::Conn object +sub get_peer_certificate { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_peer_certificate(@_); +} + +sub get_peer_verify { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_peer_verify}; +} + +sub get_shared_ciphers { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_shared_ciphers(@_); +} + +sub get_cipher { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_cipher(@_); +} + +sub ssl_context { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ctx}; +} + +sub die_with_error { + my $self=shift; + my $reason=shift; + + my @err; + while(my $err=Crypt::SSLeay::Err::get_error_string()) { + push @err, $err; + } + croak("$reason: " . join( ' | ', @err )); +} + +sub read { + my $self = shift; + $self = $REAL{$self} || $self; + + local $SIG{__DIE__} = \&Carp::confess; + local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") }; + + _alarm_set($self->timeout); + my $n = *$self->{ssl_ssl}->read(@_); + _alarm_set(0); + $self->die_with_error("read failed") if !defined $n; + + $n; +} + +sub write { + my $self = shift; + $self = $REAL{$self} || $self; + my $n = *$self->{ssl_ssl}->write(@_); + $self->die_with_error("write failed") if !defined $n; + $n; +} + +*sysread = \&read; +*syswrite = \&write; + +sub print { + my $self = shift; + $self = $REAL{$self} || $self; + # should we care about $, and $\?? + # I think it is too expensive... + $self->write(join("", @_)); +} + +sub printf { + my $self = shift; + $self = $REAL{$self} || $self; + my $fmt = shift; + $self->write(sprintf($fmt, @_)); +} + +sub getchunk { + my $self = shift; + $self = $REAL{$self} || $self; + my $buf = ''; # warnings + my $n = $self->read($buf, 32768); + return unless defined $n; + $buf; +} + +# This is really inefficient, but we only use it for reading the proxy response +# so that does not really matter. +sub getline { + my $self = shift; + $self = $REAL{$self} || $self; + my $val=""; + my $buf; + do { + $self->SUPER::recv($buf, 1); + $val .= $buf; + } until ($buf eq "\n"); + + $val; +} + +# XXX: no way to disable <$sock>?? (tied handle perhaps?) + +sub get_lwp_object { + my $self = shift; + + my $lwp_object; + my $i = 0; + while(1) { + package DB; + my @stack = caller($i++); + last unless @stack; + my @stack_args = @DB::args; + my $stack_object = $stack_args[0] || next; + return $stack_object + if ref($stack_object) + and $stack_object->isa('LWP::UserAgent'); + } + return undef; +} + +sub send_useragent_to_proxy { + if (my $val = shift) { + $SEND_USERAGENT_TO_PROXY = $val; + } + return $SEND_USERAGENT_TO_PROXY; +} + +sub proxy_connect_helper { + my $self = shift; + + my $proxy = $self->proxy; + my ($proxy_host, $proxy_port) = split(':',$proxy); + $proxy_port || croak("no port given for proxy server $proxy"); + + my $proxy_addr = gethostbyname($proxy_host); + $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!"); + + my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr}); + $peer_addr || croak("no peer addr given"); + $peer_port || croak("no peer port given"); + + # see if the proxy should be bypassed + my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || ''); + my $is_proxied = 1; + my $domain; + for $domain (@no_proxy) { + if ($peer_addr =~ /\Q$domain\E$/) { + $is_proxied = 0; + last; + } + } + + if ($is_proxied) { + $self->SUPER::connect($proxy_port, $proxy_addr) + || croak("proxy connect to $proxy_host:$proxy_port failed: $!"); + } + else { + $self->SUPER::connect($peer_port, $peer_addr) + || croak("proxy bypass to $peer_addr:$peer_addr failed: $!"); + } + + my $connect_string; + if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) { + my $user = $ENV{"HTTPS_PROXY_USERNAME"}; + my $pass = $ENV{"HTTPS_PROXY_PASSWORD"}; + + my $credentials = encode_base64("$user:$pass", ""); + $connect_string = join($CRLF, + "CONNECT $peer_addr:$peer_port HTTP/1.0", + "Proxy-authorization: Basic $credentials" + ); + } + else { + $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0"; + } + $connect_string .= $CRLF; + + if (send_useragent_to_proxy()) { + my $lwp_object = $self->get_lwp_object; + if($lwp_object && $lwp_object->agent) { + $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF; + } + } + + $connect_string .= $CRLF; + $self->SUPER::send($connect_string); + my $header; + my $n = $self->SUPER::sysread($header, 8192); + my $conn_ok = ($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) ? 1 : 0; + + if (not $conn_ok) { + croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header"); + } + + $conn_ok; +} + +# code adapted from LWP::UserAgent, with $ua->env_proxy API +sub proxy { + my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy}; + return unless $proxy_server; + + $proxy_server =~ s|\Ahttps?://||i; + $proxy_server; +} + +sub configure_certs { + my $self = shift; + my $ctx = *$self->{ssl_ctx}; + + my $count = 0; + for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) { + my $file = $ENV{$_}; + if ($file) { + (-e $file) or croak("$file file does not exist: $!"); + (-r $file) or croak("$file file is not readable"); + $count++; + if (/PKCS12/) { + $count++; + $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!"); + last; + } + elsif (/CERT/) { + $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!"); + } + elsif (/KEY/) { + $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!"); + } + else { + croak("setting $_ not supported"); + } + } + } + + # if both configs are set, then verify them + if ($count == 2) { + if (! $ctx->check_private_key) { + croak("Private key and certificate do not match"); + } + } + + $count; # number of successful cert loads/checks +} + +sub accept { shift->_unimpl("accept") } +sub getc { shift->_unimpl("getc") } +sub ungetc { shift->_unimpl("ungetc") } +sub getlines { shift->_unimpl("getlines"); } + +sub _unimpl { + my($self, $meth) = @_; + croak("$meth not implemented for Net::SSL sockets"); +} + +1; + +__END__ + +=head1 NAME + +Net::SSL - support for Secure Sockets Layer + +=head1 METHODS + +=over 4 + +=item new + +Creates a new C<Net::SSL> object. + +=item configure + +Configures a C<Net::SSL> socket for operation. + +=item configure_certs + +Sets up a certificate file to use for communicating with on +the socket. + +=item connect + +=item die_with_error + +=item get_cipher + +=item get_lwp_object + +Walks up the caller stack and looks for something blessed into +the C<LWP::UserAgent> namespace and returns it. Vaguely deprecated. + +=item get_peer_certificate + +Gets the peer certificate from the underlying C<Crypt::SSLeay::Conn> +object. + +=item get_peer_verify + +=item get_shared_ciphers + +=item getchunk + +Attempts to read up to 32KiB of data from the socket. Returns +C<undef> if nothing was read, otherwise returns the data as +a scalar. + +=item getline + +Reads one character at a time until a newline is encountered, +and returns the line, including the newline. Grossly +inefficient. + +=item print + +Concatenates the input parameters and writes them to the socket. +Does not honour C<$,> nor C<$/>. Returns the number of bytes written. + +=item printf + +Performs a C<sprintf> of the input parameters (thus, the first +parameter must be the format), and writes the result to the socket. +Returns the number of bytes written. + +=item proxy + +Returns the hostname of an https proxy server, as specified by the +C<HTTPS_PROXY> environment variable. + +=item proxy_connect_helper + +Helps set up a connection through a proxy. + +=item read + +Performs a read on the socket and returns the result. + +=item ssl_context + +=item sysread + +Is an alias of C<read>. + +=item timeout + +Returns the timeout value of the socket as defined by the implementing +class or 60 seconds by default. + +=item blocking + +Returns a boolean indicating whether the underlying socket is in +blocking mode. By default, Net::SSL sockets are in blocking mode. + + $sock->blocking(0); # set to non-blocking mode + +This method simply calls the underlying C<blocking> method of the +IO::Socket object. + +=item write + +Writes the parameters passed in (thus, a list) to the socket. Returns +the number of bytes written. + +=item syswrite + +Is an alias of C<write>. + +=item accept + +Not yet implemented. Will die if called. + +=item getc + +Not yet implemented. Will die if called. + +=item getlines + +Not yet implemented. Will die if called. + +=item ungetc + +Not yet implemented. Will die if called. + +=item send_useragent_to_proxy + +By default (as of version 2.80 of C<Net::SSL> in the 0.54 distribution +of Crypt::SSLeay), the user agent string is no longer sent to the +proxy (but will continue to be sent to the remote host). + +The previous behaviour was of marginal benefit, and could cause +fatal errors in certain scenarios (see CPAN bug #4759) and so no +longer happens by default. + +To reinstate the old behaviour, call C<Net::SSL::send_useragent_to_proxy> +with a true value (usually 1). + +=back + +=head1 DIAGNOSTICS + + "no port given for proxy server <proxy>" + +A proxy was specified for configuring a socket, but no port number +was given. Ensure that the proxy is specified as a host:port pair, +such as C<proxy.example.com:8086>. + + "configure certs failed: <contents of $@>; <contents of $!>" + + "proxy connect failed: <contents of $@>; <contents of $!>" + + "Connect failed: <contents of $@>; <contents of $!>" + +During connect(). + +=head2 SEE ALSO + +=over 4 + +=item IO::Socket::INET + +C<Net::SSL> is implemented by subclassing C<IO::Socket::INET>, hence +methods not specifically overridden are defined by that package. + +=item Net::SSLeay + +A package that provides a Perl-level interface to the C<openssl> +secure sockets layer library. + +=back + +=cut + |