line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# This file is part of POE-Component-SSLify |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# This software is copyright (c) 2014 by Apocalypse. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# This is free software; you can redistribute it and/or modify it under |
7
|
|
|
|
|
|
|
# the same terms as the Perl 5 programming language system itself. |
8
|
|
|
|
|
|
|
# |
9
|
13
|
|
|
13
|
|
4804
|
use strict; use warnings; |
|
13
|
|
|
13
|
|
132
|
|
|
13
|
|
|
|
|
355
|
|
|
13
|
|
|
|
|
48
|
|
|
13
|
|
|
|
|
13
|
|
|
13
|
|
|
|
|
792
|
|
10
|
|
|
|
|
|
|
package POE::Component::SSLify::ServerHandle; |
11
|
|
|
|
|
|
|
$POE::Component::SSLify::ServerHandle::VERSION = '1.012'; |
12
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:APOCAL'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# ABSTRACT: Server-side handle for SSLify |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# Import the SSL death routines |
17
|
13
|
|
|
13
|
|
50
|
use Net::SSLeay 1.36 qw( die_now die_if_ssl_error ERROR_WANT_READ ERROR_WANT_WRITE ); |
|
13
|
|
|
|
|
195
|
|
|
13
|
|
|
|
|
9721
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# Ties the socket |
20
|
|
|
|
|
|
|
sub TIEHANDLE { |
21
|
29
|
|
|
29
|
|
56
|
my ( $class, $socket, $ctx, $connref ) = @_; |
22
|
|
|
|
|
|
|
|
23
|
29
|
50
|
|
|
|
475
|
my $ssl = Net::SSLeay::new( $ctx ) or die_now( "Failed to create SSL $!" ); |
24
|
|
|
|
|
|
|
|
25
|
29
|
|
|
|
|
60
|
my $fileno = fileno( $socket ); |
26
|
|
|
|
|
|
|
|
27
|
29
|
|
|
|
|
170
|
Net::SSLeay::set_fd( $ssl, $fileno ); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# Socket is in non-blocking mode, so accept() will return immediately. |
30
|
|
|
|
|
|
|
# die_if_ssl_error won't die on non-blocking errors. We don't need to call accept() |
31
|
|
|
|
|
|
|
# again, because OpenSSL I/O functions (read, write, ...) can handle that entirely |
32
|
|
|
|
|
|
|
# by self (it's needed to accept() once to determine connection type). |
33
|
29
|
50
|
|
|
|
2794
|
my $res = Net::SSLeay::accept( $ssl ) and die_if_ssl_error( 'ssl accept' ); |
34
|
|
|
|
|
|
|
|
35
|
29
|
|
|
|
|
527
|
my $self = bless { |
36
|
|
|
|
|
|
|
'ssl' => $ssl, |
37
|
|
|
|
|
|
|
'ctx' => $ctx, |
38
|
|
|
|
|
|
|
'socket' => $socket, |
39
|
|
|
|
|
|
|
'fileno' => $fileno, |
40
|
|
|
|
|
|
|
'status' => $res, |
41
|
|
|
|
|
|
|
'on_connect' => $connref, |
42
|
|
|
|
|
|
|
'ssl_started' => 0, |
43
|
|
|
|
|
|
|
}, $class; |
44
|
|
|
|
|
|
|
|
45
|
29
|
|
|
|
|
193
|
return $self; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# TODO should we make a convenience function to convert retval to string equivalents for easier debugging? |
49
|
|
|
|
|
|
|
# From OpenSSL 1.0.0d |
50
|
|
|
|
|
|
|
#define SSL_ERROR_NONE 0 |
51
|
|
|
|
|
|
|
#define SSL_ERROR_SSL 1 |
52
|
|
|
|
|
|
|
#define SSL_ERROR_WANT_READ 2 |
53
|
|
|
|
|
|
|
#define SSL_ERROR_WANT_WRITE 3 |
54
|
|
|
|
|
|
|
#define SSL_ERROR_WANT_X509_LOOKUP 4 |
55
|
|
|
|
|
|
|
#define SSL_ERROR_SYSCALL 5 /* look at error stack/return value/errno */ |
56
|
|
|
|
|
|
|
#define SSL_ERROR_ZERO_RETURN 6 |
57
|
|
|
|
|
|
|
#define SSL_ERROR_WANT_CONNECT 7 |
58
|
|
|
|
|
|
|
#define SSL_ERROR_WANT_ACCEPT 8 |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub _check_status { |
61
|
169
|
|
|
169
|
|
185
|
my $self = shift; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Okay, is negotiation done? |
64
|
|
|
|
|
|
|
# http://www.openssl.org/docs/ssl/SSL_connect.html#RETURN_VALUES |
65
|
169
|
100
|
|
|
|
329
|
if ( exists $self->{'client'} ) { |
66
|
129
|
|
|
|
|
10934
|
$self->{'status'} = Net::SSLeay::connect( $self->{'ssl'} ); |
67
|
|
|
|
|
|
|
} else { |
68
|
40
|
|
|
|
|
101608
|
$self->{'status'} = Net::SSLeay::accept( $self->{'ssl'} ); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
169
|
100
|
|
|
|
617
|
if ( $self->{'status'} <= 0 ) { |
|
|
50
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# http://www.openssl.org/docs/ssl/SSL_get_error.html |
73
|
113
|
|
|
|
|
399
|
my $errval = Net::SSLeay::get_error( $self->{'ssl'}, $self->{'status'} ); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# Handle the case of ERROR_WANT_READ and ERROR_WANT_WRITE |
76
|
|
|
|
|
|
|
# TODO should we skip ERROR_WANT_ACCEPT and ERROR_WANT_CONNECT ? |
77
|
|
|
|
|
|
|
# also, ERROR_WANT_ACCEPT isn't exported by Net::SSLeay, huh? |
78
|
113
|
100
|
66
|
|
|
2973
|
if ( $errval == ERROR_WANT_READ or $errval == ERROR_WANT_WRITE ) { |
79
|
|
|
|
|
|
|
# continue reading/writing from the socket until we connect or not... |
80
|
111
|
|
|
|
|
1671
|
return 1; |
81
|
|
|
|
|
|
|
} else { |
82
|
|
|
|
|
|
|
# call the hook function for error connect |
83
|
2
|
50
|
|
|
|
370
|
if ( defined $self->{'on_connect'} ) { |
84
|
2
|
|
|
|
|
8
|
$self->{'on_connect'}->( $self->{'orig_socket'}, 0, $errval ); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# don't try to read/write from the socket anymore! |
88
|
2
|
|
|
|
|
1212
|
return 0; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} elsif ( $self->{'status'} == 1 ) { |
91
|
|
|
|
|
|
|
# SSL handshake is done! |
92
|
56
|
|
|
|
|
126
|
$self->{'ssl_started'} = 1; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# call the hook function for successful connect |
95
|
56
|
100
|
|
|
|
150
|
if ( defined $self->{'on_connect'} ) { |
96
|
4
|
|
|
|
|
16
|
$self->{'on_connect'}->( $self->{'orig_socket'}, 1 ); |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# we can now read/write from the socket! |
100
|
56
|
|
|
|
|
1044
|
return 1; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Read something from the socket |
105
|
|
|
|
|
|
|
sub READ { |
106
|
|
|
|
|
|
|
# Get ourself! |
107
|
2910
|
|
|
2910
|
|
430659
|
my $self = shift; |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Get the pointers to buffer, length, and the offset |
110
|
2910
|
|
|
|
|
4225
|
my( $buf, $len, $offset ) = \( @_ ); |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# Check the status of the SSL handshake |
113
|
2910
|
100
|
|
|
|
6567
|
if ( ! $self->{'ssl_started'} ) { |
114
|
43
|
100
|
|
|
|
108
|
return if $self->_check_status == 0; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# If we have no offset, replace the buffer with some input |
118
|
2908
|
50
|
|
|
|
4545
|
if ( ! defined $$offset ) { |
119
|
2908
|
|
|
|
|
655740
|
$$buf = Net::SSLeay::read( $self->{'ssl'}, $$len ); |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# Are we done? |
122
|
2908
|
100
|
|
|
|
6039
|
if ( defined $$buf ) { |
123
|
|
|
|
|
|
|
# TODO do we need the same "flush is success" logic in WRITE? |
124
|
|
|
|
|
|
|
|
125
|
2860
|
|
|
|
|
9144
|
return length( $$buf ); |
126
|
|
|
|
|
|
|
} else { |
127
|
|
|
|
|
|
|
# Nah, clear the buffer too... |
128
|
48
|
|
|
|
|
78
|
$$buf = ""; |
129
|
48
|
|
|
|
|
183
|
return; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# Now, actually read the data |
134
|
0
|
0
|
|
|
|
0
|
defined( my $read = Net::SSLeay::read( $self->{'ssl'}, $$len ) ) or return; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# TODO do we need the same "flush is success" logic in WRITE? |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# Figure out the buffer and offset |
139
|
0
|
|
|
|
|
0
|
my $buf_len = length( $$buf ); |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# If our offset is bigger, pad the buffer |
142
|
0
|
0
|
|
|
|
0
|
if ( $$offset > $buf_len ) { |
143
|
0
|
|
|
|
|
0
|
$$buf .= chr( 0 ) x ( $$offset - $buf_len ); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# Insert what we just read into the buffer |
147
|
0
|
|
|
|
|
0
|
substr( $$buf, $$offset, 1, $read ); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# All done! |
150
|
0
|
|
|
|
|
0
|
return length( $read ); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# Write some stuff to the socket |
154
|
|
|
|
|
|
|
sub WRITE { |
155
|
|
|
|
|
|
|
# Get ourself + buffer + length + offset to write |
156
|
3145
|
|
|
3145
|
|
70441
|
my( $self, $len, $offset ) = ( $_[0], $_[2], $_[3] ); |
157
|
3145
|
|
|
|
|
3119
|
my $buf = \$_[1]; # don't copy! |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# Check the status of the SSL handshake |
160
|
3145
|
100
|
|
|
|
5454
|
if ( ! $self->{'ssl_started'} ) { |
161
|
|
|
|
|
|
|
# The normal syswrite() POE uses expects 0 here. |
162
|
126
|
50
|
|
|
|
216
|
return 0 if $self->_check_status == 0; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# If we have nothing to offset, then start from the beginning |
166
|
3145
|
50
|
|
|
|
4499
|
if ( ! defined $offset ) { |
167
|
0
|
|
|
|
|
0
|
$offset = 0; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Thanks to RT#95071 and RT#58243 we need to clamp the length to the TLS 16K limit |
171
|
|
|
|
|
|
|
# seems like the same thing happened to https://www.mail-archive.com/openssl-users@openssl.org/msg28151.html |
172
|
3145
|
100
|
|
|
|
4724
|
$len = 16_384 if $len > 16_384; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# don't trigger substr's magic as it is SLOOOOOOOOW! |
175
|
|
|
|
|
|
|
# see http://www.perlmonks.org/?node_id=732873 |
176
|
3145
|
|
|
|
|
602900
|
my $wrote_len = Net::SSLeay::write( $self->{'ssl'}, scalar substr( $$buf, $offset, $len ) ); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# Did we get an error or number of bytes written? |
179
|
|
|
|
|
|
|
# Net::SSLeay::write() returns the number of bytes written, or 0 on unsuccessful |
180
|
|
|
|
|
|
|
# operation (probably connection closed), or -1 on error. |
181
|
3145
|
100
|
|
|
|
6741
|
if ( $wrote_len < 0 ) { |
182
|
|
|
|
|
|
|
# The normal syswrite() POE uses expects 0 here. |
183
|
313
|
|
|
|
|
916
|
return 0; |
184
|
|
|
|
|
|
|
} else { |
185
|
|
|
|
|
|
|
# We flushed some data, which means we finished the handshake! |
186
|
|
|
|
|
|
|
# This is IMPORTANT, as MIRE found out! |
187
|
|
|
|
|
|
|
# Otherwise openssl will zonk out and give us SSL_ERROR_SSL and things randomly break :( |
188
|
|
|
|
|
|
|
# this is because we tried to connect() or accept() and the handshake was done... or something like that hah |
189
|
2832
|
50
|
|
|
|
5261
|
if ( ! $self->{'ssl_started'} ) { |
190
|
0
|
|
|
|
|
0
|
$self->{'ssl_started'} = 1; |
191
|
0
|
|
|
|
|
0
|
$self->{'status'} = 1; |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# call the hook function for successful connect |
194
|
0
|
0
|
|
|
|
0
|
if ( defined $self->{'on_connect'} ) { |
195
|
0
|
|
|
|
|
0
|
$self->{'on_connect'}->( $self->{'orig_socket'}, 1 ); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
# All done! |
200
|
2832
|
|
|
|
|
7650
|
return $wrote_len; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# Sets binmode on the socket |
205
|
|
|
|
|
|
|
# Thanks to RT #27117 |
206
|
|
|
|
|
|
|
sub BINMODE { |
207
|
58
|
|
|
58
|
|
736
|
my $self = shift; |
208
|
58
|
50
|
|
|
|
137
|
if (@_) { |
209
|
0
|
|
|
|
|
0
|
my $mode = shift; |
210
|
0
|
|
|
|
|
0
|
binmode $self->{'socket'}, $mode; |
211
|
|
|
|
|
|
|
} else { |
212
|
58
|
|
|
|
|
160
|
binmode $self->{'socket'}; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
58
|
|
|
|
|
120
|
return; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# Closes the socket |
219
|
|
|
|
|
|
|
sub CLOSE { |
220
|
58
|
|
|
58
|
|
68
|
my $self = shift; |
221
|
58
|
50
|
|
|
|
123
|
if ( defined $self->{'socket'} ) { |
222
|
58
|
|
|
|
|
2051
|
Net::SSLeay::free( $self->{'ssl'} ); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# TODO we ignore any close errors because there's no way to sanely propagate it up the stack... |
225
|
58
|
|
|
|
|
2697
|
close( $self->{'socket'} ); ## no critic ( InputOutput::RequireCheckedClose ) |
226
|
58
|
|
|
|
|
137
|
undef $self->{'socket'}; |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# do we need to do CTX_free? |
229
|
58
|
100
|
|
|
|
311
|
if ( exists $self->{'client'} ) { |
230
|
29
|
|
|
|
|
462
|
Net::SSLeay::CTX_free( $self->{'ctx'} ); |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
58
|
|
|
|
|
98
|
return 1; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# Add DESTROY handler |
238
|
|
|
|
|
|
|
sub DESTROY { |
239
|
58
|
|
|
58
|
|
2359
|
my $self = shift; |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Did we already CLOSE? |
242
|
58
|
50
|
|
|
|
215
|
if ( defined $self->{'socket'} ) { |
243
|
|
|
|
|
|
|
# Guess not... |
244
|
58
|
|
|
|
|
154
|
$self->CLOSE(); |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
58
|
|
|
|
|
382
|
return; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub FILENO { |
251
|
1234
|
|
|
1234
|
|
107730
|
my $self = shift; |
252
|
1234
|
|
|
|
|
2621
|
return $self->{'fileno'}; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# Not implemented TIE's |
256
|
|
|
|
|
|
|
sub READLINE { |
257
|
0
|
|
|
0
|
|
|
die 'Not Implemented'; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub PRINT { |
261
|
0
|
|
|
0
|
|
|
die 'Not Implemented'; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
1; |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
__END__ |