File Coverage

blib/lib/Net/SSL.pm
Criterion Covered Total %
statement 59 238 24.7
branch 10 102 9.8
condition 3 34 8.8
subroutine 13 39 33.3
pod 27 27 100.0
total 112 440 25.4


line stmt bran cond sub pod time code
1             package Net::SSL;
2              
3 2     2   25435 use strict;
  2         2  
  2         67  
4 2     2   442 use MIME::Base64;
  2         618  
  2         101  
5 2     2   1092 use Socket qw(:DEFAULT :crlf);
  2         6644  
  2         1581  
6 2     2   10 use Carp qw( croak );
  2         2  
  2         78  
7              
8 2     2   7 use vars qw(@ISA $VERSION);
  2         2  
  2         148  
9             $VERSION = '2.88';
10             $VERSION = eval $VERSION;
11              
12             BEGIN {
13 2 50   2   1219 if (require IO::Socket::IP) {
14 2         64511 @ISA = qw( IO::Socket::IP );
15             }
16             else {
17 0         0 require IO::Socket;
18 0         0 @ISA = qw( IO::Socket::INET );
19             }
20             }
21              
22             my $SEND_USERAGENT_TO_PROXY = 0;
23              
24             require Crypt::SSLeay;
25              
26             sub _default_context {
27 1     1   412 require Crypt::SSLeay::MainContext;
28 1         7 Crypt::SSLeay::MainContext::main_ctx(@_);
29             }
30              
31             sub _alarm_set {
32 0 0 0 0   0 return if $^O eq 'MSWin32' or $^O eq 'NetWare';
33 0         0 alarm(shift);
34             }
35              
36             sub new {
37 1     1 1 131 my $class = shift;
38 1         14 $class->SUPER::new(@_);
39             }
40              
41             sub DESTROY {
42 1     1   2 my $self = shift;
43 1         4 local *@;
44 1         2 eval { $self->SUPER::DESTROY };
  1         11  
45 1         11 return;
46             }
47              
48             sub configure {
49 1     1 1 107 my $self = shift;
50 1         1 my $arg = shift;
51              
52 1   50     13 my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
53              
54 1   33     6 my $ctx = delete $arg->{SSL_Context} || _default_context();
55              
56 1         5 *$self->{ssl_ctx} = $ctx;
57 1         3 *$self->{ssl_debug} = $ssl_debug;
58 1         3 *$self->{ssl_arg} = $arg;
59 1         4 *$self->{ssl_peer_addr} = $arg->{PeerAddr};
60 1         3 *$self->{ssl_peer_port} = $arg->{PeerPort};
61 1         2 *$self->{ssl_peer_verify} = 0;
62              
63 1 50       6 if (my $proxy = $self->proxy) {
64 0         0 ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy);
65 0 0       0 unless ( $arg->{PeerPort} ) {
66 0         0 croak("no port given for proxy server $proxy");
67             }
68             }
69              
70 1         13 $self->SUPER::configure($arg);
71             }
72              
73 0 0   0 1 0 sub timeout { shift->SUPER::timeout || 60 }
74              
75 0     0 1 0 sub blocking { shift->SUPER::blocking(@_) }
76              
77             sub connect {
78 1     1 1 755 my $self = shift;
79              
80             # configure certs on connect() time, so we can throw an undef
81             # and have LWP understand the error
82 1         4 eval { $self->configure_certs() };
  1         6  
83 1 50       4 if ($@) {
84 0         0 $@ = "configure certs failed: $@; $!";
85 0         0 $self->die_with_error($@);
86             }
87              
88             # finished, update set_verify status
89 1 50       19 if (my $rv = *$self->{ssl_ctx}->set_verify()) {
90 0         0 *$self->{ssl_peer_verify} = $rv;
91             }
92              
93 1 50       4 if ($self->proxy) {
94             # don't die() in connect, just return undef and set $@
95 0         0 my $proxy_connect = eval { $self->proxy_connect_helper(@_) };
  0         0  
96 0 0 0     0 if(! $proxy_connect || $@) {
97 0         0 $@ = "proxy connect failed: $@; $!";
98 0         0 croak($@);
99             }
100             }
101             else {
102 1 50       7 *$self->{io_socket_peername} = (@_ == 1) ? $_[0]
103             : IO::Socket::sockaddr_in(@_);
104 1 50       13 if(!$self->SUPER::connect(@_)) {
105             # better to die than return here
106 1         254 $@ = "Connect failed: $@; $!";
107 1         441 croak($@);
108             }
109             }
110              
111 0   0     0 my $debug = *$self->{ssl_debug} || 0;
112 0         0 my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self);
113 0         0 my $arg = *$self->{ssl_arg};
114 0         0 my $new_arg = *$self->{ssl_new_arg};
115 0         0 $arg->{SSL_Debug} = $debug;
116              
117             # setup SNI if available
118 0 0       0 $ssl->can("set_tlsext_host_name") and
119             $ssl->set_tlsext_host_name(*$self->{ssl_peer_addr});
120              
121 0         0 eval {
122             local $SIG{ALRM} = sub {
123 0     0   0 $self->die_with_error("SSL connect timeout")
124 0         0 };
125 0         0 _alarm_set($self->timeout);
126              
127 0         0 my $rv;
128             {
129 0         0 local $SIG{PIPE} = \¨
  0         0  
130 0         0 $rv = eval { $ssl->connect };
  0         0  
131             }
132 0 0 0     0 if (not defined $rv or $rv <= 0) {
133 0         0 _alarm_set(0);
134 0         0 $ssl = undef;
135 0         0 eval { $self->die_with_error("SSL negotiation failed") };
  0         0  
136 0         0 croak($@);
137             }
138 0         0 _alarm_set(0);
139             };
140              
141             # odd error in eval {} block, maybe alarm outside the evals
142 0 0       0 if ($@) {
143 0         0 $@ = "$@; $!";
144 0         0 croak($@);
145             }
146              
147             # successful SSL connection gets stored
148 0         0 *$self->{ssl_ssl} = $ssl;
149 0         0 $self;
150             }
151              
152             # Delegate these calls to the Crypt::SSLeay::Conn object
153             sub get_peer_certificate {
154 0     0 1 0 my $self = shift;
155 0         0 *$self->{ssl_ssl}->get_peer_certificate(@_);
156             }
157              
158             sub get_peer_verify {
159 0     0 1 0 my $self = shift;
160 0         0 *$self->{ssl_peer_verify};
161             }
162              
163             sub get_shared_ciphers {
164 0     0 1 0 my $self = shift;
165 0         0 *$self->{ssl_ssl}->get_shared_ciphers(@_);
166             }
167              
168             sub get_cipher {
169 0     0 1 0 my $self = shift;
170 0         0 *$self->{ssl_ssl}->get_cipher(@_);
171             }
172              
173             sub pending {
174 0     0 1 0 my $self = shift;
175 0         0 *$self->{ssl_ssl}->pending(@_);
176             }
177              
178             sub ssl_context {
179 0     0 1 0 my $self = shift;
180 0         0 *$self->{ssl_ctx};
181             }
182              
183             sub die_with_error {
184 0     0 1 0 my $self=shift;
185 0         0 my $reason=shift;
186              
187 0         0 my @err;
188 0         0 while(my $err=Crypt::SSLeay::Err::get_error_string()) {
189 0         0 push @err, $err;
190             }
191 0         0 croak("$reason: " . join( ' | ', @err ));
192             }
193              
194             sub read {
195 0     0 1 0 my $self = shift;
196              
197 0         0 local $SIG{__DIE__} = \&Carp::confess;
198 0     0   0 local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
  0         0  
199              
200 0         0 _alarm_set($self->timeout);
201 0         0 my $n = *$self->{ssl_ssl}->read(@_);
202 0         0 _alarm_set(0);
203 0 0       0 $self->die_with_error("read failed") if !defined $n;
204              
205 0         0 $n;
206             }
207              
208             sub write {
209 0     0 1 0 my $self = shift;
210 0         0 my $n = *$self->{ssl_ssl}->write(@_);
211 0 0       0 $self->die_with_error("write failed") if !defined $n;
212 0         0 $n;
213             }
214              
215             *sysread = \&read;
216             *syswrite = \&write;
217              
218             sub print {
219 0     0 1 0 my $self = shift;
220             # should we care about $, and $\??
221             # I think it is too expensive...
222 0         0 $self->write(join("", @_));
223             }
224              
225             sub printf {
226 0     0 1 0 my $self = shift;
227 0         0 my $fmt = shift;
228 0         0 $self->write(sprintf($fmt, @_));
229             }
230              
231             sub getchunk {
232 0     0 1 0 my $self = shift;
233 0         0 my $buf = ''; # warnings
234 0         0 my $n = $self->read($buf, 32768);
235 0 0       0 return unless defined $n;
236 0         0 $buf;
237             }
238              
239             # This is really inefficient, but we only use it for reading the proxy response
240             # so that does not really matter.
241             sub getline {
242 0     0 1 0 my $self = shift;
243 0         0 my $val = "";
244 0         0 my $buf;
245 0         0 do {
246 0         0 $self->SUPER::recv($buf, 1);
247 0         0 $val .= $buf;
248             } until ($buf eq "\n");
249              
250 0         0 $val;
251             }
252              
253             # XXX: no way to disable <$sock>?? (tied handle perhaps?)
254              
255             sub get_lwp_object {
256 0     0 1 0 my $self = shift;
257              
258 0         0 my $lwp_object;
259 0         0 my $i = 0;
260 0         0 while(1) {
261             package DB;
262 0         0 my @stack = caller($i++);
263 0 0       0 last unless @stack;
264 0         0 my @stack_args = @DB::args;
265 0   0     0 my $stack_object = $stack_args[0] || next;
266 0 0 0     0 return $stack_object
267             if ref($stack_object)
268             and $stack_object->isa('LWP::UserAgent');
269             }
270 0         0 return undef;
271             }
272              
273             sub send_useragent_to_proxy {
274 0 0   0 1 0 if (my $val = shift) {
275 0         0 $SEND_USERAGENT_TO_PROXY = $val;
276             }
277 0         0 return $SEND_USERAGENT_TO_PROXY;
278             }
279              
280             sub proxy_connect_helper {
281 0     0 1 0 my $self = shift;
282              
283 0         0 my $proxy = $self->proxy;
284 0         0 my ($proxy_host, $proxy_port) = split(':',$proxy);
285 0 0       0 $proxy_port || croak("no port given for proxy server $proxy");
286              
287 0         0 my $proxy_addr = gethostbyname($proxy_host);
288 0 0       0 $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!");
289              
290 0         0 my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
291 0 0       0 $peer_addr || croak("no peer addr given");
292 0 0       0 $peer_port || croak("no peer port given");
293              
294             # see if the proxy should be bypassed
295 0   0     0 my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || '');
296 0         0 my $is_proxied = 1;
297 0         0 my $domain;
298 0         0 for $domain (@no_proxy) {
299 0 0       0 if ($peer_addr =~ /\Q$domain\E$/) {
300 0         0 $is_proxied = 0;
301 0         0 last;
302             }
303             }
304              
305 0 0       0 if ($is_proxied) {
306 0 0       0 $self->SUPER::connect($proxy_port, $proxy_addr)
307             || croak("proxy connect to $proxy_host:$proxy_port failed: $!");
308             }
309             else {
310             # see RT #57836
311 0         0 my $peer_addr_packed = gethostbyname($peer_addr);
312 0 0       0 $self->SUPER::connect($peer_port, $peer_addr_packed)
313             || croak("proxy bypass to $peer_addr:$peer_addr failed: $!");
314             }
315              
316 0         0 my $connect_string;
317 0 0 0     0 if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
318 0         0 my $user = $ENV{"HTTPS_PROXY_USERNAME"};
319 0         0 my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
320              
321 0         0 my $credentials = encode_base64("$user:$pass", "");
322 0         0 $connect_string = join($CRLF,
323             "CONNECT $peer_addr:$peer_port HTTP/1.0",
324             "Proxy-authorization: Basic $credentials"
325             );
326             }
327             else {
328 0         0 $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
329             }
330 0         0 $connect_string .= $CRLF;
331              
332 0 0       0 if (send_useragent_to_proxy()) {
333 0         0 my $lwp_object = $self->get_lwp_object;
334 0 0 0     0 if($lwp_object && $lwp_object->agent) {
335 0         0 $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
336             }
337             }
338              
339 0         0 $connect_string .= $CRLF;
340 0         0 $self->SUPER::send($connect_string);
341              
342 0         0 my $timeout;
343 0         0 my $header = '';
344              
345             # See RT #33954
346             # See also RT #64054
347             # Handling incomplete reads and writes better (for some values of
348             # better) may actually make this problem go away, but either way,
349             # there is no good reason to use \d when checking for 0-9
350              
351 0         0 while ($header !~ m{HTTP/[0-9][.][0-9]\s+200\s+.*$CRLF$CRLF}s) {
352 0 0       0 $timeout = $self->timeout(5) unless length $header;
353 0         0 my $n = $self->SUPER::sysread($header, 8192, length $header);
354 0 0       0 last if $n <= 0;
355             }
356              
357 0 0       0 $self->timeout($timeout) if defined $timeout;
358 0 0       0 my $conn_ok = ($header =~ m{HTTP/[0-9]+[.][0-9]+\s+200\s+}is) ? 1 : 0;
359              
360 0 0       0 if (not $conn_ok) {
361 0         0 croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
362             }
363              
364 0         0 $conn_ok;
365             }
366              
367             # code adapted from LWP::UserAgent, with $ua->env_proxy API
368             # see also RT #57836
369             sub proxy {
370 2     2 1 3 my $self = shift;
371 2   33     13 my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy};
372 2 50       11 return unless $proxy_server;
373              
374 0         0 my($peer_port, $peer_addr) = (
375             *$self->{ssl_peer_port},
376             *$self->{ssl_peer_addr}
377             );
378 0 0       0 $peer_addr || croak("no peer addr given");
379 0 0       0 $peer_port || croak("no peer port given");
380              
381             # see if the proxy should be bypassed
382 0   0     0 my @no_proxy = split( /\s*,\s*/,
383             $ENV{NO_PROXY} || $ENV{no_proxy} || ''
384             );
385 0         0 my $is_proxied = 1;
386 0         0 for my $domain (@no_proxy) {
387 0 0       0 if ($peer_addr =~ /\Q$domain\E\z/) {
388 0         0 return;
389             }
390             }
391              
392 0         0 $proxy_server =~ s|\Ahttps?://||i;
393             # sanitize the end of the string too
394             # see also http://www.nntp.perl.org/group/perl.libwww/2012/10/msg7629.html
395             # and https://github.com/nanis/Crypt-SSLeay/pull/1
396             # Thank you Mark Allen and YigangX Wen
397 0         0 $proxy_server =~ s|(:[1-9][0-9]{0,4})/\z|$1|;
398 0         0 $proxy_server;
399             }
400              
401             sub configure_certs {
402 1     1 1 2 my $self = shift;
403 1         3 my $ctx = *$self->{ssl_ctx};
404              
405 1         2 my $count = 0;
406 1         5 for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) {
407 3         8 my $file = $ENV{$_};
408 3 50       10 if ($file) {
409 0 0       0 (-e $file) or croak("$file file does not exist: $!");
410 0 0       0 (-r $file) or croak("$file file is not readable");
411 0         0 $count++;
412 0 0       0 if (/PKCS12/) {
    0          
    0          
413 0         0 $count++;
414 0 0       0 $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!");
415 0         0 last;
416             }
417             elsif (/CERT/) {
418 0 0       0 $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!");
419             }
420             elsif (/KEY/) {
421 0 0       0 $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!");
422             }
423             else {
424 0         0 croak("setting $_ not supported");
425             }
426             }
427             }
428              
429             # if both configs are set, then verify them
430 1 50       5 if ($count == 2) {
431 0 0       0 if (! $ctx->check_private_key) {
432 0         0 croak("Private key and certificate do not match");
433             }
434             }
435              
436 1         3 $count; # number of successful cert loads/checks
437             }
438              
439 0     0 1   sub accept { shift->_unimpl("accept") }
440 0     0 1   sub getc { shift->_unimpl("getc") }
441 0     0 1   sub ungetc { shift->_unimpl("ungetc") }
442 0     0 1   sub getlines { shift->_unimpl("getlines"); }
443              
444             sub _unimpl {
445 0     0     my($self, $meth) = @_;
446 0           croak("$meth not implemented for Net::SSL sockets");
447             }
448              
449             1;
450              
451             __END__