line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2010-2017 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package IO::Async::SSL; |
7
|
|
|
|
|
|
|
|
8
|
11
|
|
|
11
|
|
1054992
|
use strict; |
|
11
|
|
|
|
|
105
|
|
|
11
|
|
|
|
|
264
|
|
9
|
11
|
|
|
11
|
|
53
|
use warnings; |
|
11
|
|
|
|
|
16
|
|
|
11
|
|
|
|
|
418
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.22'; |
12
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
13
|
|
|
|
|
|
|
|
14
|
11
|
|
|
11
|
|
75
|
use Carp; |
|
11
|
|
|
|
|
16
|
|
|
11
|
|
|
|
|
537
|
|
15
|
|
|
|
|
|
|
|
16
|
11
|
|
|
11
|
|
558
|
use POSIX qw( EAGAIN EWOULDBLOCK ); |
|
11
|
|
|
|
|
5077
|
|
|
11
|
|
|
|
|
63
|
|
17
|
|
|
|
|
|
|
|
18
|
11
|
|
|
11
|
|
9518
|
use IO::Socket::SSL 2.003 qw( $SSL_ERROR SSL_WANT_READ SSL_WANT_WRITE ); # default_ca |
|
11
|
|
|
|
|
470094
|
|
|
11
|
|
|
|
|
83
|
|
19
|
|
|
|
|
|
|
# require >= 2.003 for bugfixes - see RT#125220 |
20
|
|
|
|
|
|
|
|
21
|
11
|
|
|
11
|
|
7036
|
use Future 0.33; # ->catch_with_f |
|
11
|
|
|
|
|
71996
|
|
|
11
|
|
|
|
|
381
|
|
22
|
11
|
|
|
11
|
|
4896
|
use IO::Async::Handle 0.29; |
|
11
|
|
|
|
|
82746
|
|
|
11
|
|
|
|
|
320
|
|
23
|
11
|
|
|
11
|
|
738
|
use IO::Async::Loop '0.61'; # new Listen API |
|
11
|
|
|
|
|
7540
|
|
|
11
|
|
|
|
|
16984
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 NAME |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
C - use SSL/TLS with L |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 SYNOPSIS |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
use IO::Async::Loop; |
32
|
|
|
|
|
|
|
use IO::Async::SSL; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
my $loop = IO::Async::Loop->new(); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
$loop->SSL_connect( |
37
|
|
|
|
|
|
|
host => "www.example.com", |
38
|
|
|
|
|
|
|
service => "https", |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
on_stream => sub { |
41
|
|
|
|
|
|
|
my ( $stream ) = @_; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$stream->configure( |
44
|
|
|
|
|
|
|
on_read => sub { |
45
|
|
|
|
|
|
|
... |
46
|
|
|
|
|
|
|
}, |
47
|
|
|
|
|
|
|
); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
$loop->add( $stream ); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
... |
52
|
|
|
|
|
|
|
}, |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; }, |
55
|
|
|
|
|
|
|
on_connect_error => sub { print STDERR "Cannot connect\n"; }, |
56
|
|
|
|
|
|
|
on_ssl_error => sub { print STDERR "Cannot negotiate SSL - $_[-1]\n"; }, |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=head1 DESCRIPTION |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
This module extends existing L classes with extra methods to allow |
62
|
|
|
|
|
|
|
the use of SSL or TLS-based connections using L. It does not |
63
|
|
|
|
|
|
|
directly provide any methods or functions of its own. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
Primarily, it provides C and C, which yield |
66
|
|
|
|
|
|
|
C-upgraded socket handles or L |
67
|
|
|
|
|
|
|
instances, and two forms of C to upgrade an existing TCP |
68
|
|
|
|
|
|
|
connection to use SSL. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
As an additional convenience, if the C and C |
71
|
|
|
|
|
|
|
options are omitted, the module will attempt to provide them by quering the |
72
|
|
|
|
|
|
|
result of L's C function. Otherwise, the module |
73
|
|
|
|
|
|
|
will print a warning and set C instead. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=cut |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my %SSL_ca_args = IO::Socket::SSL::default_ca(); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub _SSL_args |
80
|
|
|
|
|
|
|
{ |
81
|
33
|
|
|
33
|
|
166
|
my %args = @_; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# SSL clients (i.e. non-server) require a verify mode |
84
|
33
|
100
|
100
|
|
|
216
|
if( !$args{SSL_server} and !defined $args{SSL_verify_mode} and |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
85
|
|
|
|
|
|
|
!defined $args{SSL_ca_file} and !defined $args{SSL_ca_path} ) { |
86
|
1
|
50
|
|
|
|
3
|
unless( %SSL_ca_args ) { |
87
|
0
|
|
|
|
|
0
|
carp "Unable to set SSL_VERIFY_PEER because IO::Socket::SSL::default_ca() gives nothing"; |
88
|
0
|
|
|
|
|
0
|
$SSL_ca_args{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_NONE(); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
1
|
|
|
|
|
4
|
%args = ( %SSL_ca_args, %args ); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
33
|
|
|
|
|
398
|
return %args; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub sslread |
98
|
|
|
|
|
|
|
{ |
99
|
280
|
|
|
280
|
0
|
219135
|
my $stream = shift; |
100
|
280
|
|
|
|
|
481
|
my ( $fh, undef, $len ) = @_; |
101
|
|
|
|
|
|
|
|
102
|
280
|
|
|
|
|
638
|
my $ret = $stream->_sysread( $fh, $_[1], $len ); |
103
|
|
|
|
|
|
|
|
104
|
280
|
|
66
|
|
|
45753
|
my $read_wants_write = !defined $ret && |
105
|
|
|
|
|
|
|
( $! == EAGAIN or $! == EWOULDBLOCK ) && |
106
|
|
|
|
|
|
|
$SSL_ERROR == SSL_WANT_WRITE; |
107
|
280
|
|
|
|
|
820
|
$stream->want_writeready_for_read( $read_wants_write ); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# It's possible SSL_read took all the data out of the filehandle, thus |
110
|
|
|
|
|
|
|
# making it not appear read-ready any more. |
111
|
280
|
100
|
|
|
|
5088
|
if( $fh->pending ) { |
112
|
16
|
|
|
16
|
|
176
|
$stream->loop->later( sub { $stream->on_read_ready } ); |
|
16
|
|
|
|
|
2717
|
|
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
280
|
|
|
|
|
3161
|
return $ret; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub sslwrite |
119
|
|
|
|
|
|
|
{ |
120
|
263
|
|
|
263
|
0
|
79067
|
my $stream = shift; |
121
|
263
|
|
|
|
|
452
|
my ( $fh, undef, $len ) = @_; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Placate RT98372 |
124
|
263
|
50
|
|
|
|
682
|
utf8::downgrade( $_[1] ) or |
125
|
|
|
|
|
|
|
carp "Wide character in sslwrite"; |
126
|
|
|
|
|
|
|
|
127
|
263
|
|
|
|
|
540
|
my $ret = $stream->_syswrite( $fh, $_[1], $len ); |
128
|
|
|
|
|
|
|
|
129
|
263
|
|
33
|
|
|
46375
|
my $write_wants_read = !defined $ret && |
130
|
|
|
|
|
|
|
( $! == EAGAIN or $! == EWOULDBLOCK ) && |
131
|
|
|
|
|
|
|
$SSL_ERROR == SSL_WANT_READ; |
132
|
263
|
|
|
|
|
763
|
$stream->want_readready_for_write( $write_wants_read ); |
133
|
|
|
|
|
|
|
# If write wants read, there's no point waiting on writereadiness either |
134
|
263
|
|
|
|
|
4620
|
$stream->want_writeready_for_write( !$write_wants_read ); |
135
|
|
|
|
|
|
|
|
136
|
263
|
|
|
|
|
3944
|
return $ret; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head1 LOOP METHODS |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
The following extra methods are added to L. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=cut |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=head2 SSL_upgrade |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
( $stream or $socket ) = $loop->SSL_upgrade( %params )->get; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
This method upgrades a given stream filehandle into an SSL-wrapped stream, |
150
|
|
|
|
|
|
|
returning a future which will yield the given stream object or socket. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
Takes the following parameters: |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=over 8 |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=item handle => IO::Async::Stream | IO |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
The C object containing the IO handle of an |
159
|
|
|
|
|
|
|
already-established connection to act as the transport for SSL; or the plain |
160
|
|
|
|
|
|
|
IO socket handle itself. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
If an C is passed it will have the C and C |
163
|
|
|
|
|
|
|
functions set on it suitable for SSL use, and will be returned as the result |
164
|
|
|
|
|
|
|
from the future. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
If a plain socket handle is passed, that will be returned from the future |
167
|
|
|
|
|
|
|
instead. |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=item SSL_server => BOOL |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
If true, indicates this is the server side of the connection. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=back |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
In addition, any parameter whose name starts C will be passed to the |
176
|
|
|
|
|
|
|
C constructor. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
The following legacy callback arguments are also supported, in case the |
179
|
|
|
|
|
|
|
returned future is not used: |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=over 8 |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=item on_upgraded => CODE |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
A continuation that is invoked when the socket has been successfully upgraded |
186
|
|
|
|
|
|
|
to SSL. It will be passed an instance of an C, which will |
187
|
|
|
|
|
|
|
have appropriate SSL-compatible reader/writer functions attached. |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
$on_upgraded->( $sslsocket ) |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=item on_error => CODE |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
A continuation that is invoked if C detects an error while |
194
|
|
|
|
|
|
|
negotiating the upgrade. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
$on_error->( $! ) |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=back |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=cut |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub IO::Async::Loop::SSL_upgrade |
203
|
|
|
|
|
|
|
{ |
204
|
22
|
|
|
22
|
0
|
14369
|
my $loop = shift; |
205
|
22
|
|
|
|
|
95
|
my %params = @_; |
206
|
|
|
|
|
|
|
|
207
|
22
|
|
|
|
|
82
|
my $f = $loop->new_future; |
208
|
|
|
|
|
|
|
|
209
|
22
|
50
|
|
|
|
3176
|
$params{handle} or croak "Expected 'handle'"; |
210
|
|
|
|
|
|
|
|
211
|
22
|
|
|
|
|
53
|
my $stream; |
212
|
|
|
|
|
|
|
my $socket; |
213
|
22
|
100
|
|
|
|
164
|
if( $params{handle}->isa( "IO::Async::Stream" ) ) { |
214
|
16
|
|
|
|
|
35
|
$stream = delete $params{handle}; |
215
|
16
|
|
|
|
|
81
|
$socket = $stream->read_handle; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
else { |
218
|
6
|
|
|
|
|
12
|
$socket = delete $params{handle}; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
{ |
222
|
22
|
|
|
|
|
96
|
my $on_upgraded = delete $params{on_upgraded} or defined wantarray |
223
|
22
|
50
|
66
|
|
|
122
|
or croak "Expected 'on_upgraded' or to return a Future"; |
224
|
|
|
|
|
|
|
my $on_error = delete $params{on_error} or defined wantarray |
225
|
22
|
50
|
66
|
|
|
95
|
or croak "Expected 'on_error' or to return a Future"; |
226
|
|
|
|
|
|
|
|
227
|
22
|
100
|
|
|
|
66
|
$f->on_done( $on_upgraded ) if $on_upgraded; |
228
|
22
|
100
|
|
|
|
189
|
$f->on_fail( $on_error ) if $on_error; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
22
|
|
|
|
|
260
|
my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; |
|
44
|
|
|
|
|
121
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
eval { |
234
|
|
|
|
|
|
|
$socket = IO::Socket::SSL->start_SSL( $socket, _SSL_args |
235
|
|
|
|
|
|
|
SSL_startHandshake => 0, |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# Required to make IO::Socket::SSL not ->close before we have a chance to remove it from the loop |
238
|
|
|
|
4
|
|
|
SSL_error_trap => sub { }, |
239
|
|
|
|
|
|
|
|
240
|
22
|
100
|
|
|
|
162
|
%ssl_params, |
241
|
|
|
|
|
|
|
) or die IO::Socket::SSL->errstr; |
242
|
22
|
100
|
|
|
|
46
|
} or do { |
243
|
1
|
|
|
|
|
488
|
chomp( my $e = $@ ); |
244
|
1
|
|
|
|
|
7
|
return $f->fail( $e, "ssl" ); |
245
|
|
|
|
|
|
|
}; |
246
|
|
|
|
|
|
|
|
247
|
21
|
100
|
|
|
|
17973
|
my $ready_method = $ssl_params{SSL_server} ? "accept_SSL" : "connect_SSL"; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
my $ready = sub { |
250
|
55
|
|
|
55
|
|
17504
|
my ( $self ) = @_; |
251
|
55
|
100
|
|
|
|
264
|
if( $socket->$ready_method ) { |
252
|
17
|
|
|
|
|
4757
|
$loop->remove( $self ); |
253
|
|
|
|
|
|
|
|
254
|
17
|
100
|
|
|
|
2981
|
if( $stream ) { |
255
|
15
|
|
|
|
|
93
|
$stream->configure( |
256
|
|
|
|
|
|
|
handle => $socket, |
257
|
|
|
|
|
|
|
reader => \&sslread, |
258
|
|
|
|
|
|
|
writer => \&sslwrite, |
259
|
|
|
|
|
|
|
); |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
17
|
|
66
|
|
|
2730
|
$f->done( $stream || $socket ); |
263
|
17
|
|
|
|
|
2928
|
return; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
38
|
100
|
66
|
|
|
32633
|
if( $! != EAGAIN and $! != EWOULDBLOCK ) { |
267
|
4
|
|
|
|
|
13
|
my $errstr = IO::Socket::SSL::errstr(); |
268
|
4
|
|
|
|
|
36
|
$loop->remove( $self ); |
269
|
4
|
|
|
|
|
732
|
$f->fail( $errstr, "ssl" ); |
270
|
4
|
|
|
|
|
391
|
return; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
34
|
|
|
|
|
142
|
$self->want_readready ( $SSL_ERROR == SSL_WANT_READ ); |
274
|
34
|
|
|
|
|
336
|
$self->want_writeready( $SSL_ERROR == SSL_WANT_WRITE ); |
275
|
21
|
|
|
|
|
140
|
}; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# We're going to steal the IO handle from $stream, so we'll have to |
278
|
|
|
|
|
|
|
# temporarily deconfigure it |
279
|
21
|
100
|
|
|
|
102
|
$stream->configure( handle => undef ) if $stream; |
280
|
|
|
|
|
|
|
|
281
|
21
|
|
|
|
|
2222
|
$loop->add( my $handle = IO::Async::Handle->new( |
282
|
|
|
|
|
|
|
handle => $socket, |
283
|
|
|
|
|
|
|
on_read_ready => $ready, |
284
|
|
|
|
|
|
|
on_write_ready => $ready, |
285
|
|
|
|
|
|
|
) ); |
286
|
|
|
|
|
|
|
|
287
|
21
|
|
|
|
|
6590
|
$ready->( $handle ); |
288
|
|
|
|
|
|
|
|
289
|
21
|
100
|
|
|
|
368
|
return $f if defined wantarray; |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# Caller is not going to keep hold of the Future, so we have to ensure it |
292
|
|
|
|
|
|
|
# stays alive somehow |
293
|
2
|
|
|
2
|
|
15
|
$f->on_ready( sub { undef $f } ); # intentional cycle |
|
2
|
|
|
|
|
37
|
|
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=head2 SSL_connect |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
$stream = $loop->SSL_connect( %params )->get; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
This method performs a non-blocking connection to a given address or set of |
301
|
|
|
|
|
|
|
addresses, upgrades the socket to SSL, then yields a C |
302
|
|
|
|
|
|
|
object when the SSL handshake is complete. |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
It takes all the same arguments as C. Any argument |
305
|
|
|
|
|
|
|
whose name starts C will be passed on to the L |
306
|
|
|
|
|
|
|
constructor rather than the Loop's C method. It is not required to |
307
|
|
|
|
|
|
|
pass the C option, as SSL implies this will be C. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
This method can also upgrade an existing C or subclass |
310
|
|
|
|
|
|
|
instance given as the C argument, by setting the C and |
311
|
|
|
|
|
|
|
C functions. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head2 SSL_connect (void) |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
$loop->SSL_connect( %params, |
316
|
|
|
|
|
|
|
on_connected => sub { ... }, |
317
|
|
|
|
|
|
|
on_stream => sub { ... }, |
318
|
|
|
|
|
|
|
); |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
When not returning a future, this method also supports the C and |
321
|
|
|
|
|
|
|
C continuations. |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
In addition, the following arguments are then required: |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
=over 8 |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
=item on_ssl_error => CODE |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
A continuation that is invoked if C detects an SSL-based |
330
|
|
|
|
|
|
|
error once the actual stream socket is connected. |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
=back |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
If the C continuation is used, the socket handle it yields will |
335
|
|
|
|
|
|
|
be a C, which must be wrapped in C to |
336
|
|
|
|
|
|
|
be used by C. The C continuation will already yield such |
337
|
|
|
|
|
|
|
an instance. |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
=cut |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub IO::Async::Loop::SSL_connect |
342
|
|
|
|
|
|
|
{ |
343
|
6
|
|
|
6
|
0
|
1052863
|
my $loop = shift; |
344
|
6
|
|
|
|
|
67
|
my %params = @_; |
345
|
|
|
|
|
|
|
|
346
|
6
|
|
|
|
|
86
|
my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; |
|
5
|
|
|
|
|
32
|
|
347
|
|
|
|
|
|
|
|
348
|
6
|
|
|
|
|
19
|
my $on_done; |
349
|
6
|
100
|
|
|
|
46
|
if( exists $params{on_connected} ) { |
|
|
100
|
|
|
|
|
|
350
|
1
|
|
|
|
|
8
|
my $on_connected = delete $params{on_connected}; |
351
|
|
|
|
|
|
|
$on_done = sub { |
352
|
0
|
|
|
0
|
|
0
|
my ( $stream ) = @_; |
353
|
0
|
|
|
|
|
0
|
$on_connected->( $stream->read_handle ); |
354
|
1
|
|
|
|
|
12
|
}; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
elsif( exists $params{on_stream} ) { |
357
|
1
|
|
|
|
|
3
|
my $on_stream = delete $params{on_stream}; |
358
|
1
|
|
|
|
|
2
|
$on_done = $on_stream; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
else { |
361
|
4
|
50
|
|
|
|
29
|
croak "Expected 'on_connected' or 'on_stream' or to return a Future" unless defined wantarray; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
my $on_ssl_error = delete $params{on_ssl_error} or defined wantarray or |
365
|
6
|
50
|
66
|
|
|
71
|
croak "Expected 'on_ssl_error' or to return a Future"; |
366
|
|
|
|
|
|
|
|
367
|
6
|
|
66
|
|
|
102
|
my $stream = delete $params{handle} || do { |
368
|
|
|
|
|
|
|
require IO::Async::Stream; |
369
|
|
|
|
|
|
|
IO::Async::Stream->new; |
370
|
|
|
|
|
|
|
}; |
371
|
|
|
|
|
|
|
|
372
|
6
|
50
|
|
|
|
410
|
$stream->isa( "IO::Async::Stream" ) or |
373
|
|
|
|
|
|
|
croak "Can only SSL_connect a handle instance of IO::Async::Stream"; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# Don't ->connect with the handle yet, because we'll first have to use the |
376
|
|
|
|
|
|
|
# socket to perform SSL_upgrade on. We don't want to confuse the loop by |
377
|
|
|
|
|
|
|
# giving it the same fd twice. |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
my $f = $loop->connect( |
380
|
|
|
|
|
|
|
socktype => 'stream', # SSL over DGRAM or RAW makes no sense |
381
|
|
|
|
|
|
|
%params, |
382
|
|
|
|
|
|
|
)->then( sub { |
383
|
6
|
|
|
6
|
|
18098
|
my ( $socket ) = @_; |
384
|
|
|
|
|
|
|
|
385
|
6
|
|
|
|
|
48
|
$stream->configure( handle => $socket ); |
386
|
|
|
|
|
|
|
|
387
|
6
|
|
|
|
|
1224
|
$loop->SSL_upgrade( |
388
|
|
|
|
|
|
|
_SSL_args( %ssl_params ), |
389
|
|
|
|
|
|
|
handle => $stream, |
390
|
|
|
|
|
|
|
) |
391
|
6
|
|
|
|
|
79
|
}); |
392
|
|
|
|
|
|
|
|
393
|
6
|
100
|
|
|
|
46478
|
$f->on_done( $on_done ) if $on_done; |
394
|
|
|
|
|
|
|
$f->on_fail( sub { |
395
|
1
|
50
|
33
|
1
|
|
217
|
$on_ssl_error->( $_[0] ) if defined $_[1] and $_[1] eq "ssl"; |
396
|
6
|
100
|
|
|
|
136
|
}) if $on_ssl_error; |
397
|
|
|
|
|
|
|
|
398
|
6
|
100
|
|
|
|
178
|
return $f if defined wantarray; |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# Caller is not going to keep hold of the Future, so we have to ensure it |
401
|
|
|
|
|
|
|
# stays alive somehow |
402
|
2
|
|
|
2
|
|
28
|
$f->on_ready( sub { undef $f } ); # intentional cycle |
|
2
|
|
|
|
|
109
|
|
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=head2 SSL_listen |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
$loop->SSL_listen( %params )->get; |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
This method sets up a listening socket using the addresses given, and will |
410
|
|
|
|
|
|
|
invoke the callback each time a new connection is accepted on the socket and |
411
|
|
|
|
|
|
|
the SSL handshake has been completed. This can be either the C or |
412
|
|
|
|
|
|
|
C continuation; C is not supported. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
It takes all the same arguments as C. Any argument |
415
|
|
|
|
|
|
|
whose name starts C will be passed on to the L |
416
|
|
|
|
|
|
|
constructor rather than the Loop's C method. It is not required to |
417
|
|
|
|
|
|
|
pass the C option, as SSL implies this will be C. |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
In addition, the following arguments are rquired: |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
=over 8 |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
=item on_ssl_error => CODE |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
A continuation that is invoked if C detects an SSL-based |
426
|
|
|
|
|
|
|
error once the actual stream socket is connected. |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=back |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
The underlying L socket will also require the server key and |
431
|
|
|
|
|
|
|
certificate for a server-mode socket. See its documentation for more details. |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
If the C continuation is used, the socket handle it yields will be |
434
|
|
|
|
|
|
|
a C, which must be wrapped in C to be |
435
|
|
|
|
|
|
|
used by C. The C continuation will already yield such an |
436
|
|
|
|
|
|
|
instance. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
=cut |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
sub IO::Async::Loop::SSL_listen |
441
|
|
|
|
|
|
|
{ |
442
|
5
|
|
|
5
|
0
|
23403
|
my $loop = shift; |
443
|
5
|
|
|
|
|
36
|
my %params = @_; |
444
|
|
|
|
|
|
|
|
445
|
5
|
|
|
|
|
86
|
my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; |
|
10
|
|
|
|
|
40
|
|
446
|
|
|
|
|
|
|
my $on_ssl_error = delete $params{on_ssl_error} or defined wantarray |
447
|
5
|
50
|
66
|
|
|
46
|
or croak "Expected 'on_ssl_error'"; |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
my $f = $loop->listen( |
450
|
|
|
|
|
|
|
socktype => 'stream', |
451
|
|
|
|
|
|
|
%params, |
452
|
|
|
|
|
|
|
)->on_done( sub { |
453
|
5
|
|
|
5
|
|
16761
|
my $listener = shift; |
454
|
|
|
|
|
|
|
|
455
|
5
|
|
|
|
|
106
|
my $cleartext_acceptor = $listener->acceptor; |
456
|
|
|
|
|
|
|
my $ssl_acceptor = sub { |
457
|
5
|
|
|
|
|
39536
|
my $listener = shift; |
458
|
5
|
|
|
|
|
14
|
my ( $listen_sock, %params ) = @_; |
459
|
5
|
|
|
|
|
13
|
my $stream = $params{handle}; |
460
|
5
|
50
|
66
|
|
|
59
|
!defined $stream or $stream->isa( "IO::Async::Stream" ) or |
461
|
|
|
|
|
|
|
croak "Can only accept SSL on IO::Async::Stream handles"; |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
$listener->$cleartext_acceptor( $listen_sock )->then( sub { |
464
|
5
|
|
|
|
|
1640
|
my ( $socket ) = @_; |
465
|
|
|
|
|
|
|
|
466
|
5
|
50
|
|
|
|
22
|
return Future->done() unless $socket; # EAGAIN |
467
|
|
|
|
|
|
|
|
468
|
5
|
100
|
|
|
|
36
|
$stream->configure( handle => $socket ) if $stream; |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
$loop->SSL_upgrade( |
471
|
|
|
|
|
|
|
_SSL_args( SSL_server => 1, %ssl_params ), |
472
|
|
|
|
|
|
|
handle => ( $stream || $socket ), |
473
|
|
|
|
|
|
|
)->catch_with_f( ssl => sub { |
474
|
1
|
|
|
|
|
67
|
my ( $f, $failure ) = @_; |
475
|
1
|
50
|
|
|
|
6
|
if( $on_ssl_error ) { |
476
|
1
|
|
|
|
|
3
|
$on_ssl_error->( $failure ); |
477
|
1
|
|
|
|
|
7
|
return Future->done; # eat it |
478
|
|
|
|
|
|
|
} |
479
|
0
|
|
|
|
|
0
|
return $f; |
480
|
5
|
|
66
|
|
|
549
|
}); |
481
|
5
|
|
|
|
|
33
|
}); |
482
|
5
|
|
|
|
|
80
|
}; |
483
|
|
|
|
|
|
|
|
484
|
5
|
|
|
|
|
21
|
$listener->configure( acceptor => $ssl_acceptor ); |
485
|
5
|
|
|
|
|
55
|
}); |
486
|
|
|
|
|
|
|
|
487
|
5
|
100
|
|
|
|
74015
|
return $f if defined wantarray; |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
# Caller is not going to keep hold of the Future, so we have to ensure it |
490
|
|
|
|
|
|
|
# stays alive somehow |
491
|
2
|
|
|
2
|
|
39
|
$f->on_ready( sub { undef $f } ); # intentional cycle |
|
2
|
|
|
|
|
125
|
|
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=head1 STREAM PROTOCOL METHODS |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
The following extra methods are added to L. |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
=cut |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
=head2 SSL_upgrade |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
$protocol->SSL_upgrade( %params )->get; |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
A shortcut to calling C<< $loop->SSL_upgrade >>. This method will unconfigure |
505
|
|
|
|
|
|
|
the C of the Protocol, upgrade its underlying filehandle to SSL, |
506
|
|
|
|
|
|
|
then reconfigure it again with SSL reader and writer functions on it. It takes |
507
|
|
|
|
|
|
|
the same arguments as C<< $loop->SSL_upgrade >>, except that the C |
508
|
|
|
|
|
|
|
argument is not required as it's taken from the Protocol's C. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=cut |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
sub IO::Async::Protocol::Stream::SSL_upgrade |
513
|
|
|
|
|
|
|
{ |
514
|
2
|
|
|
2
|
0
|
5962
|
my $protocol = shift; |
515
|
2
|
|
|
|
|
8
|
my %params = @_; |
516
|
|
|
|
|
|
|
|
517
|
2
|
50
|
|
|
|
7
|
my $on_upgraded = delete $params{on_upgraded} or croak "Expected 'on_upgraded'"; |
518
|
|
|
|
|
|
|
|
519
|
2
|
50
|
|
|
|
8
|
my $loop = $protocol->get_loop or croak "Expected to be a member of a Loop"; |
520
|
|
|
|
|
|
|
|
521
|
2
|
|
|
|
|
13
|
my $transport = $protocol->transport; |
522
|
|
|
|
|
|
|
|
523
|
2
|
|
|
|
|
18
|
$protocol->configure( transport => undef ); |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
$loop->SSL_upgrade( |
526
|
|
|
|
|
|
|
handle => $transport, |
527
|
|
|
|
|
|
|
on_upgraded => sub { |
528
|
2
|
|
|
2
|
|
105
|
my ( $transport ) = @_; |
529
|
|
|
|
|
|
|
|
530
|
2
|
|
|
|
|
7
|
$protocol->configure( transport => $transport ); |
531
|
|
|
|
|
|
|
|
532
|
2
|
|
|
|
|
732
|
$on_upgraded->(); |
533
|
|
|
|
|
|
|
}, |
534
|
|
|
|
|
|
|
|
535
|
2
|
|
|
|
|
720
|
%params, |
536
|
|
|
|
|
|
|
); |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
=head1 AUTHOR |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
Paul Evans |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
=cut |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
0x55AA; |