Lines 23-176
Link Here
|
23 |
|
23 |
|
24 |
use strict; |
24 |
use strict; |
25 |
use vars qw($VERSION $AUTOLOAD @ISA); |
25 |
use vars qw($VERSION $AUTOLOAD @ISA $have_inet6); |
26 |
use IO::Socket::INET; |
|
|
27 |
use Fcntl (); |
26 |
use Fcntl (); |
28 |
use Errno (); |
27 |
use Errno (); |
29 |
use Socket (); |
28 |
use Socket (); |
|
|
29 |
use IO::Socket; |
30 |
|
30 |
|
31 |
BEGIN { |
31 |
BEGIN { |
32 |
eval { require Net::SSLeay }; |
32 |
eval { |
33 |
$@ && warn "Module Net::SSLeay is required for SSLeay."; |
33 |
require Socket6; import Socket6; |
34 |
# Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times? |
34 |
require IO::Socket::INET6; |
35 |
for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) { |
35 |
@ISA = qw(IO::Socket::INET6); |
36 |
Net::SSLeay->can($sub)->(); |
36 |
$have_inet6 = 1; |
37 |
} |
37 |
} or do { |
|
|
38 |
require IO::Socket::INET; |
39 |
@ISA = qw(IO::Socket::INET); |
40 |
}; |
41 |
eval { require Net::SSLeay }; |
42 |
$@ && warn "Module Net::SSLeay is required for SSLeay."; |
43 |
# Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times? |
44 |
for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) { |
45 |
Net::SSLeay->can($sub)->(); |
46 |
} |
38 |
} |
47 |
} |
39 |
|
48 |
|
40 |
$VERSION = $Net::Server::VERSION; # done until separated |
49 |
$VERSION = $Net::Server::VERSION; # done until separated |
41 |
@ISA = qw(IO::Socket::INET); |
50 |
|
|
|
51 |
# additional protocol specific arguments |
52 |
my @ssl_args = qw( |
53 |
SSL_use_cert |
54 |
SSL_verify_mode |
55 |
SSL_key_file |
56 |
SSL_cert_file |
57 |
SSL_ca_path |
58 |
SSL_ca_file |
59 |
SSL_cipher_list |
60 |
SSL_passwd_cb |
61 |
SSL_max_getline_length |
62 |
SSL_error_callback |
63 |
); |
42 |
|
64 |
|
43 |
sub object { |
65 |
sub object { |
44 |
my $type = shift; |
66 |
my $type = shift; |
45 |
my $class = ref($type) || $type || __PACKAGE__; |
67 |
my $class = ref($type) || $type || __PACKAGE__; |
46 |
|
68 |
|
47 |
my ($default_host,$port,$server) = @_; |
69 |
my ($default_host,$port,$server) = @_; |
48 |
my $prop = $server->{'server'}; |
70 |
my $host; |
49 |
my $host; |
71 |
my $prop = $server->{'server'}; |
50 |
|
72 |
|
51 |
if ($port =~ m/^([\w\.\-\*\/]+):(\w+)$/) { # allow for things like "domain.com:80" |
73 |
local($1,$2); |
52 |
($host, $port) = ($1, $2); |
74 |
### allow for things like "[::1]:80" or "[host.example.com]:80" |
53 |
} |
75 |
if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){ |
54 |
elsif ($port =~ /^(\w+)$/) { # allow for things like "80" |
76 |
($host,$port) = ($1,$2); |
55 |
($host, $port) = ($default_host, $1); |
77 |
|
56 |
} |
78 |
### allow for things like "host.example.com:80" |
57 |
else { |
79 |
}elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ |
58 |
$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); |
80 |
($host,$port) = ($1,$2); |
59 |
} |
81 |
|
60 |
|
82 |
### allow for things like "80" or "http" |
61 |
# read any additional protocol specific arguments |
83 |
}elsif( $port =~ /^(\w+)$/ ){ |
62 |
my @ssl_args = qw( |
84 |
($host,$port) = ($default_host,$1); |
63 |
SSL_server |
85 |
|
64 |
SSL_use_cert |
86 |
### don't know that style of port |
65 |
SSL_verify_mode |
87 |
}else{ |
66 |
SSL_key_file |
88 |
$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); |
67 |
SSL_cert_file |
89 |
} |
68 |
SSL_ca_path |
90 |
|
69 |
SSL_ca_file |
91 |
### collect bind addresses along with their address family for all hosts |
70 |
SSL_cipher_list |
92 |
my @bind_tuples; |
71 |
SSL_passwd_cb |
93 |
if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){ |
72 |
SSL_error_callback |
94 |
push(@bind_tuples, [AF_INET,$host,$port]); |
73 |
SSL_max_getline_length |
95 |
}elsif( $host =~ /:/ ){ |
74 |
); |
96 |
die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6; |
75 |
my %args; |
97 |
push(@bind_tuples, [AF_INET6,$host,$port]); |
76 |
$args{$_} = \$prop->{$_} for @ssl_args; |
98 |
}elsif( !$have_inet6 ){ |
77 |
$server->configure(\%args); |
99 |
push(@bind_tuples, [AF_INET,$host,$port]); |
78 |
|
100 |
}elsif( $have_inet6 && $host =~ /\*/ ){ |
79 |
my $sock = $class->new; |
101 |
push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]); |
80 |
$sock->NS_host($host); |
102 |
}else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet |
81 |
$sock->NS_port($port); |
103 |
# obtain a list of IP addresses for $host, resolve port name |
82 |
$sock->NS_proto('SSLEAY'); |
104 |
my @res1 = getaddrinfo($host, $port, |
|
|
105 |
AF_UNSPEC, SOCK_STREAM, 0, AI_PASSIVE); |
106 |
die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5; |
107 |
while (@res1 >= 5) { |
108 |
my($afam, $socktype, $proto, $saddr, $canonname); |
109 |
($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1; |
110 |
my @res2 = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV); |
111 |
die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2; |
112 |
my($hostip,$portnum) = @res2; |
113 |
$server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam"); |
114 |
push(@bind_tuples, [$afam,$hostip,$portnum]); |
115 |
} |
116 |
} |
117 |
|
118 |
my @sockets_list; |
119 |
### create a socket for each specified bind address and family |
120 |
foreach my $tuple ( @bind_tuples ){ |
121 |
my $afamily; # address family (AF_* constants) |
122 |
my $pfamily; # socket protocol family (PF_* constants) |
123 |
($afamily,$host,$port) = @$tuple; |
124 |
my $sock; |
125 |
if( $have_inet6 ){ |
126 |
# Using IO::Socket::INET6 to handle both the IPv4 and IPv6. |
127 |
# Constants PF_INET/PF_INET6 (protocol family) usually happen to have |
128 |
# the same value as AF_INET/AF_INET6 (address family) constants. |
129 |
# Still, better safe than sorry: |
130 |
$pfamily = $afamily == AF_INET ? PF_INET |
131 |
: $afamily == AF_INET6 ? PF_INET6 : $afamily; |
132 |
$server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily"); |
133 |
$sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6 |
134 |
}else{ |
135 |
$pfamily = PF_INET; |
136 |
$server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily"); |
137 |
$sock = IO::Socket::INET->new(); # inet socket (IPv4 only) |
138 |
} |
139 |
|
140 |
if ($sock) { |
141 |
bless $sock, $class; |
142 |
|
143 |
$sock->NS_host($host); |
144 |
$sock->NS_port($port); |
145 |
$sock->NS_proto('SSLEAY'); |
146 |
$sock->NS_family($pfamily); # socket protocol family |
83 |
|
147 |
|
84 |
for my $key (@ssl_args) { |
148 |
for my $key (@ssl_args) { |
85 |
my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef; |
149 |
my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef; |
86 |
$sock->$key($val); |
150 |
$sock->$key($val); |
|
|
151 |
} |
152 |
push @sockets_list, $sock; |
87 |
} |
153 |
} |
|
|
154 |
} |
88 |
|
155 |
|
89 |
return $sock; |
156 |
### returns any number of sockets, |
|
|
157 |
### one for each protocol family (PF_INET or PF_INET6) and each bind address |
158 |
return !wantarray ? $sockets_list[0] : @sockets_list; |
90 |
} |
159 |
} |
91 |
|
160 |
|
92 |
sub log_connect { |
161 |
sub log_connect { |
93 |
my $sock = shift; |
162 |
my $sock = shift; |
94 |
my $server = shift; |
163 |
my $server = shift; |
95 |
my $host = $sock->NS_host; |
164 |
my $host = $sock->NS_host; |
96 |
my $port = $sock->NS_port; |
165 |
my $port = $sock->NS_port; |
97 |
my $proto = $sock->NS_proto; |
166 |
my $proto = $sock->NS_proto; |
98 |
$server->log(2,"Binding to $proto port $port on host $host\n"); |
167 |
my $pfamily = $sock->NS_family || 0; |
|
|
168 |
$server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n"); |
99 |
} |
169 |
} |
100 |
|
170 |
|
101 |
###----------------------------------------------------------------### |
171 |
###----------------------------------------------------------------### |
102 |
|
172 |
|
103 |
sub connect { # connect the first time |
173 |
### bind the first time |
104 |
my $sock = shift; |
174 |
sub connect { |
105 |
my $server = shift; |
175 |
my $sock = shift; |
106 |
my $prop = $server->{'server'}; |
176 |
my $server = shift; |
107 |
|
177 |
my $prop = $server->{server}; |
108 |
my $host = $sock->NS_host; |
178 |
|
109 |
my $port = $sock->NS_port; |
179 |
my $host = $sock->NS_host; |
110 |
|
180 |
my $port = $sock->NS_port; |
111 |
my %args; |
181 |
my $pfamily = $sock->NS_family || 0; |
112 |
$args{'LocalPort'} = $port; |
182 |
|
113 |
$args{'Proto'} = 'tcp'; |
183 |
my %args; |
114 |
$args{'LocalAddr'} = $host if $host !~ /\*/; # * is all |
184 |
$args{LocalPort} = $port; |
115 |
$args{'Listen'} = $prop->{'listen'}; |
185 |
$args{Proto} = 'tcp'; |
116 |
$args{'Reuse'} = 1; |
186 |
$args{LocalAddr} = $host if $host !~ /\*/; # * is all |
117 |
|
187 |
$args{Domain} = $pfamily if $have_inet6 && $pfamily; |
118 |
$sock->SUPER::configure(\%args) || $server->fatal("Can't connect to SSL port $port on $host [$!]"); |
188 |
$args{Listen} = $prop->{listen}; |
119 |
$server->fatal("Bad sock [$!]!".caller()) if ! $sock; |
189 |
$args{Reuse} = 1; |
120 |
|
190 |
|
121 |
if ($port == 0 && ($port = $sock->sockport)) { |
191 |
$sock->SUPER::configure(\%args) |
122 |
$sock->NS_port($port); |
192 |
or $server->fatal("Can't bind to SSL port $port on $host [$!]"); |
123 |
$server->log(2,"Bound to auto-assigned port $port"); |
193 |
$server->fatal("Bad sock [$!]!".caller()) if !$sock; |
124 |
} |
194 |
|
125 |
|
195 |
my $actual_port = $sock->sockport; |
126 |
$sock->bind_SSL($server); |
196 |
# $port may be a service name, compare as strings |
127 |
} |
197 |
if( $actual_port && (!defined $port || $actual_port ne $port) ){ |
128 |
|
198 |
$sock->NS_port($actual_port); |
129 |
sub reconnect { # connect on a sig -HUP |
199 |
if( $port =~ /^0*\z/ ){ |
130 |
my ($sock, $fd, $server) = @_; |
200 |
$server->log(2,"Bound to auto-assigned port $actual_port"); |
131 |
my $resp = $sock->fdopen( $fd, 'w' ) || $server->fatal("Error opening to file descriptor ($fd) [$!]"); |
201 |
}else{ |
132 |
$sock->bind_SSL($server); |
202 |
$server->log(3,"Bound to service \"$port\", port number $actual_port"); |
133 |
return $resp; |
203 |
} |
|
|
204 |
} |
205 |
|
206 |
$sock->bind_SSL($server); |
207 |
} |
208 |
|
209 |
### reassociate sockets with inherited file descriptors on a sig -HUP |
210 |
sub reconnect { |
211 |
my ($sock, $fd, $server) = @_; |
212 |
|
213 |
my $host = $sock->NS_host; |
214 |
my $port = $sock->NS_port; |
215 |
my $proto = $sock->NS_proto; |
216 |
my $pfamily = $sock->NS_family || 0; |
217 |
|
218 |
$server->log(3,"Reassociating file descriptor $fd ". |
219 |
"with socket $proto on [$host]:port, PF $pfamily\n"); |
220 |
my $resp = $sock->fdopen( $fd, 'w' ) |
221 |
or $server->fatal("Error opening to file descriptor ($fd) [$!]"); |
222 |
$sock->bind_SSL($server); |
223 |
return $resp; |
134 |
} |
224 |
} |
135 |
|
225 |
|
136 |
sub bind_SSL { |
226 |
sub bind_SSL { |
137 |
my ($sock, $server) = @_; |
227 |
my ($sock, $server) = @_; |
138 |
my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new"); |
228 |
my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new"); |
139 |
|
229 |
|
140 |
Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options"); |
230 |
Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options"); |
141 |
|
231 |
|
142 |
# 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE |
232 |
# 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE |
143 |
# 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0) |
233 |
# 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0) |
144 |
Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode"); |
234 |
Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode"); |
145 |
|
235 |
|
146 |
# Load certificate. This will prompt for a password if necessary. |
236 |
# Load certificate. This will prompt for a password if necessary. |
147 |
my $file_key = $sock->SSL_key_file || die "SSLeay missing SSL_key_file.\n"; |
237 |
my $file_key = $sock->SSL_key_file || die "SSLeay missing SSL_key_file.\n"; |
148 |
my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file.\n"; |
238 |
my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file.\n"; |
149 |
Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file"); |
239 |
Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file"); |
150 |
Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file"); |
240 |
Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file"); |
151 |
$sock->SSLeay_context($ctx); |
241 |
$sock->SSLeay_context($ctx); |
152 |
} |
242 |
} |
153 |
|
243 |
|
154 |
sub close { |
244 |
sub close { |
155 |
my $sock = shift; |
245 |
my $sock = shift; |
156 |
if ($sock->SSLeay_is_client) { |
246 |
if ($sock->SSLeay_is_client) { |
157 |
Net::SSLeay::free($sock->SSLeay); |
247 |
Net::SSLeay::free($sock->SSLeay); |
158 |
} else { |
248 |
} else { |
159 |
Net::SSLeay::CTX_free($sock->SSLeay_context); |
249 |
Net::SSLeay::CTX_free($sock->SSLeay_context); |
160 |
} |
250 |
} |
161 |
$sock->SSLeay_check_fatal("SSLeay close free"); |
251 |
$sock->SSLeay_check_fatal("SSLeay close free"); |
162 |
return $sock->SUPER::close(@_); |
252 |
return $sock->SUPER::close(@_); |
163 |
} |
253 |
} |
164 |
|
254 |
|
165 |
sub accept { |
255 |
sub accept { |
166 |
my $sock = shift; |
256 |
my $sock = shift; |
167 |
my $client = $sock->SUPER::accept; |
257 |
my $client = $sock->SUPER::accept; |
168 |
if (defined $client) { |
258 |
if (defined $client) { |
169 |
$client->NS_proto($sock->NS_proto); |
259 |
$client->NS_proto( $sock->NS_proto ); |
170 |
$client->SSLeay_context($sock->SSLeay_context); |
260 |
$client->NS_family( $sock->NS_family ); |
171 |
$client->SSLeay_is_client(1); |
261 |
$client->NS_host( $sock->NS_host ); |
172 |
} |
262 |
$client->NS_port( $sock->NS_port ); |
|
|
263 |
$client->SSLeay_context( $sock->SSLeay_context ); |
264 |
$client->SSLeay_is_client(1); |
265 |
} |
173 |
|
266 |
|
174 |
return $client; |
267 |
return $client; |
175 |
} |
268 |
} |
176 |
|
269 |
|
Lines 281-284
Link Here
|
281 |
} |
374 |
} |
282 |
|
375 |
|
|
|
376 |
sub sysread { |
377 |
my ($client, $buf, $size, $offset) = @_; |
378 |
warn "sysread is not supported by Net::Server::Proto::SSLEAY"; |
379 |
# not quite right, usable only for testing: |
380 |
my ($ok, $read) = $client->read_until($size, $/, 1); |
381 |
substr($_[1], $offset || 0, defined($buf) ? length($buf) : 0, $read); |
382 |
# should return the number of bytes actually read, 0 at end of file, or |
383 |
# undef if there was an error (in the latter case $! should also be set) |
384 |
return length $read; |
385 |
} |
386 |
|
283 |
sub getline { |
387 |
sub getline { |
284 |
my $client = shift; |
388 |
my $client = shift; |
Lines 331-335
Link Here
|
331 |
} |
435 |
} |
332 |
|
436 |
|
333 |
sub sysread { die "sysread is not supported by Net::Server::Proto::SSLEAY" } |
|
|
334 |
sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" } |
437 |
sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" } |
335 |
|
438 |
|
Lines 338-342
Link Here
|
338 |
sub hup_string { |
441 |
sub hup_string { |
339 |
my $sock = shift; |
442 |
my $sock = shift; |
340 |
return join "|", map{$sock->$_()} qw(NS_host NS_port NS_proto); |
443 |
return join("|", |
|
|
444 |
$sock->NS_host, |
445 |
$sock->NS_port, |
446 |
$sock->NS_proto, |
447 |
!$have_inet6 || !$sock->NS_family ? () : $sock->NS_family, |
448 |
); |
341 |
} |
449 |
} |
342 |
|
450 |
|
Lines 344-348
Link Here
|
344 |
my $sock = shift; |
452 |
my $sock = shift; |
345 |
my $t = "Ref = \"" .ref($sock) . "\"\n"; |
453 |
my $t = "Ref = \"" .ref($sock) . "\"\n"; |
346 |
foreach my $prop ( qw(NS_proto NS_port NS_host SSLeay_context SSLeay_is_client) ){ |
454 |
foreach my $prop ( qw(NS_proto NS_port NS_host NS_family SSLeay_context SSLeay_is_client) ){ |
347 |
$t .= " $prop = \"" .$sock->$prop()."\"\n"; |
455 |
$t .= " $prop = \"" .$sock->$prop()."\"\n"; |
348 |
} |
456 |
} |
Lines 354-358
Link Here
|
354 |
my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD."; |
462 |
my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD."; |
355 |
die "Unknown method or property [$prop]" |
463 |
die "Unknown method or property [$prop]" |
356 |
if $prop !~ /^(NS_proto|NS_port|NS_host|SSLeay_context|SSLeay_is_client|SSL_\w+)$/; |
464 |
if $prop !~ /^(NS_proto|NS_port|NS_host|NS_family|SSLeay_context|SSLeay_is_client|SSL_\w+)$/; |
357 |
|
465 |
|
358 |
no strict 'refs'; |
466 |
no strict 'refs'; |