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