File Coverage

blib/lib/Net/Server/Proto/SSLEAY.pm
Criterion Covered Total %
statement 218 305 71.4
branch 76 152 50.0
condition 20 61 32.7
subroutine 32 42 76.1
pod 6 32 18.7
total 352 592 59.4


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto::SSLEAY - Net::Server Protocol module
4             #
5             # Copyright (C) 2010-2017
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             # All rights reserved.
15             #
16             ################################################################
17              
18             package Net::Server::Proto::SSLEAY;
19              
20 3     3   39960 use strict;
  3         6  
  3         77  
21 3     3   14 use warnings;
  3         4  
  3         81  
22 3     3   12 use IO::Socket::INET;
  3         6  
  3         38  
23 3     3   1443 use Fcntl ();
  3         4  
  3         40  
24 3     3   9 use Errno ();
  3         5  
  3         37  
25 3     3   9 use Socket ();
  3         8  
  3         272  
26              
27             BEGIN {
28 3 50   3   8 eval { require Net::SSLeay; 1 }
  3         10  
  3         18  
29             or warn "Module Net::SSLeay is required for SSLeay.";
30 3         9 for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) {
31 15         4219 Net::SSLeay->can($sub)->();
32             }
33 3 50       1693 eval { [Fcntl::F_GETFL(), Fcntl::F_SETFL(), Fcntl::O_NONBLOCK()] } || die "Could not access Fcntl constant while loading ".__PACKAGE__.": $@";
  3         10724  
34             }
35              
36             our @ISA = qw(IO::Socket::INET);
37             our $AUTOLOAD;
38              
39             my @ssl_args = qw(
40             SSL_use_cert
41             SSL_verify_mode
42             SSL_key_file
43             SSL_cert_file
44             SSL_ca_path
45             SSL_ca_file
46             SSL_cipher_list
47             SSL_passwd_cb
48             SSL_max_getline_length
49             SSL_error_callback
50             );
51              
52 18     18 0 79 sub NS_proto { 'SSLEAY' }
53 21 100   21 0 681 sub NS_port { my $sock = shift; ${*$sock}{'NS_port'} = shift if @_; return ${*$sock}{'NS_port'} }
  21         53  
  7         21  
  21         40  
  21         86  
54 19 100   19 0 359 sub NS_host { my $sock = shift; ${*$sock}{'NS_host'} = shift if @_; return ${*$sock}{'NS_host'} }
  19         50  
  7         29  
  19         34  
  19         75  
55 19 100   19 0 41 sub NS_ipv { my $sock = shift; ${*$sock}{'NS_ipv'} = shift if @_; return ${*$sock}{'NS_ipv'} }
  19         46  
  7         29  
  19         33  
  19         233  
56 10 100   10 0 20 sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }
  10         25  
  5         17  
  10         19  
  10         22  
57              
58             sub object {
59 5     5 0 18 my ($class, $info, $server) = @_;
60              
61 5   66     138 my $ssl = $server->{'server'}->{'ssl_args'} ||= do {
62 4         46 my %temp = map {$_ => undef} @ssl_args;
  40         168  
63 4         33 $server->configure({map {$_ => \$temp{$_}} @ssl_args});
  40         92  
64 4         22 \%temp;
65             };
66              
67             # we cannot do this at compile time because we have not yet read the configuration then
68 5 50 33     56 @ISA = qw(IO::Socket::INET6) if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server);
69              
70 5         112 my @sock = $class->SUPER::new();
71 5         909 foreach my $sock (@sock) {
72 5         42 $sock->NS_host($info->{'host'});
73 5         20 $sock->NS_port($info->{'port'});
74 5         17 $sock->NS_ipv( $info->{'ipv'} );
75             $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
76 5 100       36 : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
    100          
77             : Socket::SOMAXCONN());
78 5 50       15 ${*$sock}{'NS_orig_port'} = $info->{'orig_port'} if defined $info->{'orig_port'};
  0         0  
79              
80 5         17 for my $key (@ssl_args) {
81             my $val = defined($info->{$key}) ? $info->{$key}
82             : defined($ssl->{$key}) ? $ssl->{$key}
83 50 100       358 : $server->can($key) ? $server->$key($info->{'host'}, $info->{'port'}, 'SSLEAY')
    100          
    100          
84             : undef;
85 50 100       112 next if ! defined $val;
86 9 50       103 $sock->$key($val) if defined $val;
87             }
88             }
89 5 50       33 return wantarray ? @sock : $sock[0];
90             }
91              
92             sub log_connect {
93 2     2 0 6 my ($sock, $server) = @_;
94 2         7 $server->log(2, "Binding to ".$sock->NS_proto." port ".$sock->NS_port." on host ".$sock->NS_host." with IPv".$sock->NS_ipv);
95             }
96              
97             sub connect { # connect the first time
98 2     2 0 11 my ($sock, $server) = @_;
99 2         10 my $host = $sock->NS_host;
100 2         9 my $port = $sock->NS_port;
101 2         9 my $ipv = $sock->NS_ipv;
102 2         7 my $lstn = $sock->NS_listen;
103              
104 2 50       88 $sock->SUPER::configure({
    0          
    0          
    50          
    50          
105             LocalPort => $port,
106             Proto => 'tcp',
107             Listen => $lstn,
108             ReuseAddr => 1,
109             Reuse => 1,
110             (($host ne '*') ? (LocalAddr => $host) : ()), # * is all
111             ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()),
112             }) || $server->fatal("Can't connect to SSLEAY port $port on $host [$!]");
113              
114 2 50 33     895 if ($port eq '0' and $port = $sock->sockport) {
    50 33        
115 0         0 $server->log(2, " Bound to auto-assigned port $port");
116 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
117 0         0 $sock->NS_port($port);
118             } elsif ($port =~ /\D/ and $port = $sock->sockport) {
119 0         0 $server->log(2, " Bound to service port ".$sock->NS_port()."($port)");
120 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
121 0         0 $sock->NS_port($port);
122             }
123              
124 2         25 $sock->bind_SSL($server);
125             }
126              
127             sub reconnect { # connect on a sig -HUP
128 0     0 0 0 my ($sock, $fd, $server, $port) = @_;
129 0         0 $server->log(3,"Reassociating file descriptor $fd with ".$sock->NS_proto." on [".$sock->NS_host."]:".$sock->NS_port.", using IPv".$sock->NS_ipv);
130 0 0       0 my $resp = $sock->fdopen( $fd, 'w' ) or $server->fatal("Error opening to file descriptor ($fd) [$!]");
131              
132 0 0       0 if ($sock->isa("IO::Socket::INET6")) {
133 0         0 my $ipv = $sock->NS_ipv;
134 0 0       0 ${*$sock}{'io_socket_domain'} = ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC();
  0 0       0  
135             }
136              
137 0         0 $sock->bind_SSL($server);
138              
139 0 0       0 if ($port ne $sock->NS_port) {
140 0         0 $server->log(2, " Re-bound to previously assigned port $port");
141 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
142 0         0 $sock->NS_port($port);
143             }
144              
145 0         0 return $resp;
146             }
147              
148             sub bind_SSL {
149 2     2 0 9 my ($sock, $server) = @_;
150 2         491 my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new");
  2         27  
151              
152 2         58 Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options");
  2         384  
153              
154             # 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE
155             # 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0)
156 2         10 Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode");
  2         6  
157              
158             # Load certificate. This will prompt for a password if necessary.
159 2   50     8 my $file_key = $sock->SSL_key_file || die "SSLeay missing SSL_key_file on ".$sock->hup_string.".\n";
160 2   50     7 my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file on ".$sock->hup_string>".\n";
161 2         42 Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file");
  2         318  
162 2         60 Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file");
  2         415  
163 2         22 $sock->SSLeay_context($ctx);
164             }
165              
166             sub close {
167 1     1 0 3 my $sock = shift;
168 1 50       5 if ($sock->SSLeay_is_client) {
169 1         4 Net::SSLeay::free($sock->SSLeay);
170             } else {
171 0         0 Net::SSLeay::CTX_free($sock->SSLeay_context);
172             }
173 1         7 $sock->SSLeay_check_fatal("SSLeay close free");
174 1         19 return $sock->SUPER::close(@_);
175             }
176              
177             sub accept {
178 2     2 1 7 my ($sock, $class) = (@_);
179 2         7 my ($client, $peername);
180 2 50       6 if (wantarray) {
181 0         0 ($client, $peername) = $sock->SUPER::accept($class);
182             } else {
183 2         16 $client = $sock->SUPER::accept($class);
184             }
185 2 50       537 if (defined $client) {
186 2         16 $client->NS_proto($sock->NS_proto);
187 2         12 $client->NS_ipv( $sock->NS_ipv);
188 2         14 $client->NS_host( $sock->NS_host);
189 2         11 $client->NS_port( $sock->NS_port);
190 2         12 $client->SSLeay_context($sock->SSLeay_context);
191 2         27 $client->SSLeay_is_client(1);
192             }
193              
194 2 50       40 return wantarray ? ($client, $peername) : $client;
195             }
196              
197             sub post_accept {
198 2     2 0 7 my $client = shift;
199 2         13 $client->SSLeay;
200             }
201              
202             sub SSLeay {
203 9     9 0 22 my $client = shift;
204              
205 9 100       20 if (! exists ${*$client}{'SSLeay'}) {
  9         42  
206 2 50       9 die "SSLeay refusing to accept on non-client socket" if !$client->SSLeay_is_client;
207              
208 2         34 $client->autoflush(1);
209              
210 2   50     127 my $f = fcntl($client, Fcntl::F_GETFL(), 0) || die "SSLeay - fcntl get: $!\n";
211 2 50       15 fcntl($client, Fcntl::F_SETFL(), $f | Fcntl::O_NONBLOCK()) || die "SSLeay - fcntl set: $!\n";
212              
213 2         8 my $ssl = Net::SSLeay::new($client->SSLeay_context); $client->SSLeay_check_fatal("SSLeay new");
  2         12  
214 2         18 Net::SSLeay::set_fd($ssl, $client->fileno); $client->SSLeay_check_fatal("SSLeay set_fd");
  2         24  
215 2         618 Net::SSLeay::accept($ssl); $client->SSLeay_check_fatal("SSLeay accept");
  2         18  
216 2         5 ${*$client}{'SSLeay'} = $ssl;
  2         21  
217             }
218              
219 9 100       33 return if ! defined wantarray;
220 7         14 return ${*$client}{'SSLeay'};
  7         47  
221             }
222              
223             sub SSLeay_check_fatal {
224 17     17 0 60 my ($client, $msg) = @_;
225 17 50       47 if (my $err = $client->SSLeay_check_error($msg, 1)) {
226 0         0 my ($file, $pkg, $line) = caller;
227 0         0 die "$msg at $file line $line\n ".join(' ', @$err);
228             }
229             }
230              
231             sub SSLeay_check_error {
232 880     880 0 1750 my ($client, $msg, $fatal) = @_;
233 880         1169 my @err;
234 880         2792 while (my $n = Net::SSLeay::ERR_get_error()) {
235 0         0 push @err, "$n. ". Net::SSLeay::ERR_error_string($n) ."\n";
236             }
237 880 50       1718 if (@err) {
238 0         0 my $cb = $client->SSL_error_callback;
239 0 0       0 $cb->($client, $msg, \@err, ($fatal ? 'is_fatal' : ())) if $cb;
    0          
240 0         0 return \@err;
241             }
242 880         1953 return;
243             }
244              
245              
246             ###----------------------------------------------------------------###
247              
248             sub read_until {
249 1     1 1 7 my ($client, $bytes, $end_qr, $non_greedy) = @_;
250              
251 1         5 my $ssl = $client->SSLeay;
252 1         5 my $content = ${*$client}{'SSLeay_buffer'};
  1         7  
253 1 50       14 $content = '' if ! defined $content;
254 1         5 my $ok = 0;
255              
256             # the rough outline for this loop came from http://devpit.org/wiki/OpenSSL_with_nonblocking_sockets_%28in_Perl%29
257 1         3 OUTER: while (1) {
258 861 100 33     1778 if (!length($content)) {
    50 33        
    50          
259             }
260             elsif (defined($bytes) && length($content) >= $bytes) {
261 0         0 ${*$client}{'SSLeay_buffer'} = substr($content, $bytes, length($content), '');
  0         0  
262 0         0 $ok = 2;
263 0         0 last;
264             }
265             elsif (defined($end_qr) && $content =~ m/$end_qr/g) {
266 1         4 my $n = pos($content);
267 1         6 ${*$client}{'SSLeay_buffer'} = substr($content, $n, length($content), '');
  1         10  
268 1         3 $ok = 1;
269 1         3 last;
270             }
271              
272             # this select appears to only cause read issues - in some cases the underlying select of Net::SSLeay enters into a spinloop
273             #vec(my $vec = '', $client->fileno, 1) = 1;
274             #select($vec, undef, undef, undef);
275              
276 860         1316 my $n_empty = 0;
277 860         1209 while (1) {
278             # 16384 is the maximum amount read() can return
279 861         1072 my $n = 16384;
280 861 50 33     1542 $n -= ($bytes - length($content)) if $non_greedy && ($bytes - length($content)) < $n;
281 861         5317 my $buf = Net::SSLeay::read($ssl, 16384); # read the most we can - continue reading until the buffer won't read any more
282 861 50       2111 if ($client->SSLeay_check_error('SSLeay read_until read')) {
283 0         0 last OUTER;
284             }
285 861 0 66     4186 die "SSLeay read_until: $!\n" if ! defined($buf) && !$!{EAGAIN} && !$!{EINTR} && !$!{ENOBUFS};
      33        
      0        
286 861 100       11026 last if ! defined($buf);
287 1 50       5 if (!length($buf)) {
288 0 0 0     0 last OUTER if !length($buf) && $n_empty++;
289             }
290             else {
291 1         3 $content .= $buf;
292 1 50 33     8 if ($non_greedy && length($content) == $bytes) {
293 0         0 $ok = 3;
294 0         0 last;
295             }
296             }
297             }
298             }
299 1 50       9 return wantarray ? ($ok, $content) : $content;
300             }
301              
302             sub read {
303 0     0 0 0 my ($client, $buf, $size, $offset) = @_;
304 0         0 my ($ok, $read) = $client->read_until($size, undef, 1);
305 0 0 0     0 substr($_[1], $offset || 0, defined($buf) ? length($buf) : 0, $read);
306 0         0 return length $read;
307             }
308              
309             sub sysread {
310 2     2 0 452 my ($client, $buf, $length, $offset) = @_;
311 2 50       11 $length = length $buf unless defined $length;
312 2 50       9 $offset = 0 unless defined $offset;
313 2         8 my $ssl = $client->SSLeay;
314 2         1245 my $data = Net::SSLeay::read($ssl, $length);
315              
316 2 100 66     22 return if $!{EAGAIN} || $!{EINTR};
317              
318 1 50       50 die "SSLeay print: $!\n" unless defined $data;
319              
320 1         4 $length = length($data);
321 1 50       5 $$buf = '' if !defined $buf;
322              
323 1 50       19 if ($offset > length($$buf)) {
324 0         0 $$buf .= "\0" x ($offset - length($buf));
325             }
326              
327 1         16 substr($$buf, $offset, length($$buf), $data);
328 1         5 return $length;
329             }
330              
331 0     0 1 0 sub error { my $client = shift; return ${*$client}{'_error'} }
  0         0  
  0         0  
332              
333             sub syswrite {
334 1     1 0 17 my ($client, $buf, $length, $offset) = @_;
335 1         4 delete ${*$client}{'_error'};
  1         4  
336              
337 1 50       6 $length = length $buf unless defined $length;
338 1 50       5 $offset = 0 unless defined $offset;
339 1         5 my $ssl = $client->SSLeay;
340              
341 1         56 my $write = Net::SSLeay::write_partial($ssl, $offset, $length, $buf);
342              
343 1 50 33     10 return if $!{EAGAIN} || $!{EINTR};
344 1 50       61 if ($write < 0) {
345 0         0 ${*$client}{'_error'} = "SSLeay print: $!\n";
  0         0  
346 0         0 return;
347             }
348              
349 1         4 return $write;
350             }
351              
352             sub getline {
353 1     1 1 3 my $client = shift;
354 1         15 my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);
355 1         13 return $line;
356             }
357              
358             sub getlines {
359 0     0 1 0 my $client = shift;
360 0         0 my @lines;
361 0         0 while (1) {
362 0         0 my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);
363 0         0 push @lines, $line;
364 0 0       0 last if $ok != 1;
365             }
366 0         0 return @lines;
367             }
368              
369             sub print {
370 2     2 0 4 my $client = shift;
371 2         4 delete ${*$client}{'_error'};
  2         8  
372 2 100       11 my $buf = @_ == 1 ? $_[0] : join('', @_);
373 2         7 my $ssl = $client->SSLeay;
374 2         9 while (length $buf) {
375 2         17 vec(my $vec = '', $client->fileno, 1) = 1;
376 2         35 select(undef, $vec, undef, undef);
377              
378 2         1175 my $write = Net::SSLeay::write($ssl, $buf);
379 2 50       14 return 0 if $client->SSLeay_check_error('SSLeay write');
380 2 0 33     11 if ($write == -1 && !$!{EAGAIN} && !$!{EINTR} && !$!{ENOBUFS}) {
      33        
      0        
381 0         0 ${*$client}{'_error'} = "SSLeay print: $!\n";
  0         0  
382 0         0 return;
383             }
384 2 50       18 substr($buf, 0, $write, "") if $write > 0;
385             }
386 2         12 return 1;
387             }
388              
389             sub printf {
390 0     0 0 0 my $client = shift;
391 0         0 $client->print(sprintf(shift, @_));
392             }
393              
394             sub say {
395 0     0 0 0 my $client = shift;
396 0         0 $client->print(@_, "\n");
397             }
398              
399             sub write {
400 0     0 1 0 my $client = shift;
401 0         0 my $buf = shift;
402 0 0 0     0 $buf = substr($buf, $_[1] || 0, $_[0]) if @_;
403 0         0 $client->print($buf);
404             }
405              
406             sub seek {
407 0     0 0 0 my $client = shift;
408 0         0 my ($pos, $whence) = @_;
409 0 0       0 if ($whence) {
410 0         0 $! = "Seek from $whence of non-zero is not supported.";
411 0         0 return 0;
412             }
413 0         0 my $n = $client->read(my $buf, $pos);
414 0 0       0 if ($n != $pos) {
415 0         0 $| = "Couldn't seek to $pos ($n)\n";
416 0         0 return 0;
417             }
418 0         0 return 1;
419             }
420              
421             sub poll_cb { # implemented for psgi compatibility - TODO - should poll appropriately for Multipex
422 0     0 0 0 my ($self, $cb) = @_;
423 0         0 return $cb->($self);
424             }
425              
426             ###----------------------------------------------------------------###
427              
428             sub hup_string {
429 3     3 0 819 my $sock = shift;
430 3 50       6 return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, "ipv".$sock->NS_ipv, (defined(${*$sock}{'NS_orig_port'}) ? ${*$sock}{'NS_orig_port'} : ());
  3         16  
  0         0  
431             }
432              
433             sub show {
434 0     0 0 0 my $sock = shift;
435 0         0 my $t = "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
436 0         0 foreach my $prop (qw(SSLeay_context SSLeay_is_client)) {
437 0         0 $t .= " $prop = \"" .$sock->$prop()."\"\n";
438             }
439 0         0 return $t;
440             }
441              
442             sub AUTOLOAD {
443 7     7   19 my $sock = shift;
444 7 50       360 my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD.";
445 7 50       197 die "Unknown method or property [$prop]"
446             if $prop !~ /^(SSLeay_context|SSLeay_is_client|SSL_\w+)$/;
447              
448 3     3   35 no strict 'refs';
  3         63  
  3         576  
449 7         55 *{__PACKAGE__."::${prop}"} = sub {
450 32     32   65 my $sock = shift;
451 32 100       70 if (@_) {
452 15         25 ${*$sock}{$prop} = shift;
  15         80  
453 15 50       37 return delete ${*$sock}{$prop} if ! defined ${*$sock}{$prop};
  0         0  
  15         96  
454             } else {
455 17         27 return ${*$sock}{$prop};
  17         129  
456             }
457 7         58 };
458 7         33 return $sock->$prop(@_);
459             }
460              
461 2     2 0 14 sub tie_stdout { 1 }
462              
463             1;
464              
465             __END__