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 6package IO::Async::SSL; 7 8use strict; 9use warnings; 10 11our $VERSION = '0.22'; 12$VERSION = eval $VERSION; 13 14use Carp; 15 16use POSIX qw( EAGAIN EWOULDBLOCK ); 17 18use IO::Socket::SSL 2.003 qw( $SSL_ERROR SSL_WANT_READ SSL_WANT_WRITE ); # default_ca 19 # require >= 2.003 for bugfixes - see RT#125220 20 21use Future 0.33; # ->catch_with_f 22use IO::Async::Handle 0.29; 23use IO::Async::Loop '0.61'; # new Listen API 24 25=head1 NAME 26 27C<IO::Async::SSL> - use SSL/TLS with L<IO::Async> 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 61This module extends existing L<IO::Async> classes with extra methods to allow 62the use of SSL or TLS-based connections using L<IO::Socket::SSL>. It does not 63directly provide any methods or functions of its own. 64 65Primarily, it provides C<SSL_connect> and C<SSL_listen>, which yield 66C<IO::Socket::SSL>-upgraded socket handles or L<IO::Async::Stream> 67instances, and two forms of C<SSL_upgrade> to upgrade an existing TCP 68connection to use SSL. 69 70As an additional convenience, if the C<SSL_verify_mode> and C<SSL_ca_*> 71options are omitted, the module will attempt to provide them by quering the 72result of L<IO::Socket::SSL>'s C<default_ca> function. Otherwise, the module 73will print a warning and set C<SSL_VERIFY_NONE> instead. 74 75=cut 76 77my %SSL_ca_args = IO::Socket::SSL::default_ca(); 78 79sub _SSL_args 80{ 81 my %args = @_; 82 83 # SSL clients (i.e. non-server) require a verify mode 84 if( !$args{SSL_server} and !defined $args{SSL_verify_mode} and 85 !defined $args{SSL_ca_file} and !defined $args{SSL_ca_path} ) { 86 unless( %SSL_ca_args ) { 87 carp "Unable to set SSL_VERIFY_PEER because IO::Socket::SSL::default_ca() gives nothing"; 88 $SSL_ca_args{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_NONE(); 89 } 90 91 %args = ( %SSL_ca_args, %args ); 92 } 93 94 return %args; 95} 96 97sub sslread 98{ 99 my $stream = shift; 100 my ( $fh, undef, $len ) = @_; 101 102 my $ret = $stream->_sysread( $fh, $_[1], $len ); 103 104 my $read_wants_write = !defined $ret && 105 ( $! == EAGAIN or $! == EWOULDBLOCK ) && 106 $SSL_ERROR == SSL_WANT_WRITE; 107 $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 if( $fh->pending ) { 112 $stream->loop->later( sub { $stream->on_read_ready } ); 113 } 114 115 return $ret; 116} 117 118sub sslwrite 119{ 120 my $stream = shift; 121 my ( $fh, undef, $len ) = @_; 122 123 # Placate RT98372 124 utf8::downgrade( $_[1] ) or 125 carp "Wide character in sslwrite"; 126 127 my $ret = $stream->_syswrite( $fh, $_[1], $len ); 128 129 my $write_wants_read = !defined $ret && 130 ( $! == EAGAIN or $! == EWOULDBLOCK ) && 131 $SSL_ERROR == SSL_WANT_READ; 132 $stream->want_readready_for_write( $write_wants_read ); 133 # If write wants read, there's no point waiting on writereadiness either 134 $stream->want_writeready_for_write( !$write_wants_read ); 135 136 return $ret; 137} 138 139=head1 LOOP METHODS 140 141The following extra methods are added to L<IO::Async::Loop>. 142 143=cut 144 145=head2 SSL_upgrade 146 147 ( $stream or $socket ) = $loop->SSL_upgrade( %params )->get; 148 149This method upgrades a given stream filehandle into an SSL-wrapped stream, 150returning a future which will yield the given stream object or socket. 151 152Takes the following parameters: 153 154=over 8 155 156=item handle => IO::Async::Stream | IO 157 158The C<IO::Async::Stream> object containing the IO handle of an 159already-established connection to act as the transport for SSL; or the plain 160IO socket handle itself. 161 162If an C<IO::Async::Stream> is passed it will have the C<reader> and C<writer> 163functions set on it suitable for SSL use, and will be returned as the result 164from the future. 165 166If a plain socket handle is passed, that will be returned from the future 167instead. 168 169=item SSL_server => BOOL 170 171If true, indicates this is the server side of the connection. 172 173=back 174 175In addition, any parameter whose name starts C<SSL_> will be passed to the 176C<IO::Socket::SSL> constructor. 177 178The following legacy callback arguments are also supported, in case the 179returned future is not used: 180 181=over 8 182 183=item on_upgraded => CODE 184 185A continuation that is invoked when the socket has been successfully upgraded 186to SSL. It will be passed an instance of an C<IO::Socket::SSL>, which will 187have appropriate SSL-compatible reader/writer functions attached. 188 189 $on_upgraded->( $sslsocket ) 190 191=item on_error => CODE 192 193A continuation that is invoked if C<IO::Socket::SSL> detects an error while 194negotiating the upgrade. 195 196 $on_error->( $! ) 197 198=back 199 200=cut 201 202sub IO::Async::Loop::SSL_upgrade 203{ 204 my $loop = shift; 205 my %params = @_; 206 207 my $f = $loop->new_future; 208 209 $params{handle} or croak "Expected 'handle'"; 210 211 my $stream; 212 my $socket; 213 if( $params{handle}->isa( "IO::Async::Stream" ) ) { 214 $stream = delete $params{handle}; 215 $socket = $stream->read_handle; 216 } 217 else { 218 $socket = delete $params{handle}; 219 } 220 221 { 222 my $on_upgraded = delete $params{on_upgraded} or defined wantarray 223 or croak "Expected 'on_upgraded' or to return a Future"; 224 my $on_error = delete $params{on_error} or defined wantarray 225 or croak "Expected 'on_error' or to return a Future"; 226 227 $f->on_done( $on_upgraded ) if $on_upgraded; 228 $f->on_fail( $on_error ) if $on_error; 229 } 230 231 my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; 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 SSL_error_trap => sub { }, 239 240 %ssl_params, 241 ) or die IO::Socket::SSL->errstr; 242 } or do { 243 chomp( my $e = $@ ); 244 return $f->fail( $e, "ssl" ); 245 }; 246 247 my $ready_method = $ssl_params{SSL_server} ? "accept_SSL" : "connect_SSL"; 248 249 my $ready = sub { 250 my ( $self ) = @_; 251 if( $socket->$ready_method ) { 252 $loop->remove( $self ); 253 254 if( $stream ) { 255 $stream->configure( 256 handle => $socket, 257 reader => \&sslread, 258 writer => \&sslwrite, 259 ); 260 } 261 262 $f->done( $stream || $socket ); 263 return; 264 } 265 266 if( $! != EAGAIN and $! != EWOULDBLOCK ) { 267 my $errstr = IO::Socket::SSL::errstr(); 268 $loop->remove( $self ); 269 $f->fail( $errstr, "ssl" ); 270 return; 271 } 272 273 $self->want_readready ( $SSL_ERROR == SSL_WANT_READ ); 274 $self->want_writeready( $SSL_ERROR == SSL_WANT_WRITE ); 275 }; 276 277 # We're going to steal the IO handle from $stream, so we'll have to 278 # temporarily deconfigure it 279 $stream->configure( handle => undef ) if $stream; 280 281 $loop->add( my $handle = IO::Async::Handle->new( 282 handle => $socket, 283 on_read_ready => $ready, 284 on_write_ready => $ready, 285 ) ); 286 287 $ready->( $handle ); 288 289 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 $f->on_ready( sub { undef $f } ); # intentional cycle 294} 295 296=head2 SSL_connect 297 298 $stream = $loop->SSL_connect( %params )->get; 299 300This method performs a non-blocking connection to a given address or set of 301addresses, upgrades the socket to SSL, then yields a C<IO::Async::Stream> 302object when the SSL handshake is complete. 303 304It takes all the same arguments as C<IO::Async::Loop::connect()>. Any argument 305whose name starts C<SSL_> will be passed on to the L<IO::Socket::SSL> 306constructor rather than the Loop's C<connect> method. It is not required to 307pass the C<socktype> option, as SSL implies this will be C<stream>. 308 309This method can also upgrade an existing C<IO::Async::Stream> or subclass 310instance given as the C<handle> argument, by setting the C<reader> and 311C<writer> functions. 312 313=head2 SSL_connect (void) 314 315 $loop->SSL_connect( %params, 316 on_connected => sub { ... }, 317 on_stream => sub { ... }, 318 ); 319 320When not returning a future, this method also supports the C<on_connected> and 321C<on_stream> continuations. 322 323In addition, the following arguments are then required: 324 325=over 8 326 327=item on_ssl_error => CODE 328 329A continuation that is invoked if C<IO::Socket::SSL> detects an SSL-based 330error once the actual stream socket is connected. 331 332=back 333 334If the C<on_connected> continuation is used, the socket handle it yields will 335be a C<IO::Socket::SSL>, which must be wrapped in C<IO::Async::SSLStream> to 336be used by C<IO::Async>. The C<on_stream> continuation will already yield such 337an instance. 338 339=cut 340 341sub IO::Async::Loop::SSL_connect 342{ 343 my $loop = shift; 344 my %params = @_; 345 346 my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; 347 348 my $on_done; 349 if( exists $params{on_connected} ) { 350 my $on_connected = delete $params{on_connected}; 351 $on_done = sub { 352 my ( $stream ) = @_; 353 $on_connected->( $stream->read_handle ); 354 }; 355 } 356 elsif( exists $params{on_stream} ) { 357 my $on_stream = delete $params{on_stream}; 358 $on_done = $on_stream; 359 } 360 else { 361 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 croak "Expected 'on_ssl_error' or to return a Future"; 366 367 my $stream = delete $params{handle} || do { 368 require IO::Async::Stream; 369 IO::Async::Stream->new; 370 }; 371 372 $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 my ( $socket ) = @_; 384 385 $stream->configure( handle => $socket ); 386 387 $loop->SSL_upgrade( 388 _SSL_args( %ssl_params ), 389 handle => $stream, 390 ) 391 }); 392 393 $f->on_done( $on_done ) if $on_done; 394 $f->on_fail( sub { 395 $on_ssl_error->( $_[0] ) if defined $_[1] and $_[1] eq "ssl"; 396 }) if $on_ssl_error; 397 398 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 $f->on_ready( sub { undef $f } ); # intentional cycle 403} 404 405=head2 SSL_listen 406 407 $loop->SSL_listen( %params )->get; 408 409This method sets up a listening socket using the addresses given, and will 410invoke the callback each time a new connection is accepted on the socket and 411the SSL handshake has been completed. This can be either the C<on_accept> or 412C<on_stream> continuation; C<on_socket> is not supported. 413 414It takes all the same arguments as C<IO::Async::Loop::listen()>. Any argument 415whose name starts C<SSL_> will be passed on to the L<IO::Socket::SSL> 416constructor rather than the Loop's C<listen> method. It is not required to 417pass the C<socktype> option, as SSL implies this will be C<stream>. 418 419In addition, the following arguments are rquired: 420 421=over 8 422 423=item on_ssl_error => CODE 424 425A continuation that is invoked if C<IO::Socket::SSL> detects an SSL-based 426error once the actual stream socket is connected. 427 428=back 429 430The underlying L<IO::Socket::SSL> socket will also require the server key and 431certificate for a server-mode socket. See its documentation for more details. 432 433If the C<on_accept> continuation is used, the socket handle it yields will be 434a C<IO::Socket::SSL>, which must be wrapped in C<IO::Async::SSLStream> to be 435used by C<IO::Async>. The C<on_stream> continuation will already yield such an 436instance. 437 438=cut 439 440sub IO::Async::Loop::SSL_listen 441{ 442 my $loop = shift; 443 my %params = @_; 444 445 my %ssl_params = map { $_ => delete $params{$_} } grep m/^SSL_/, keys %params; 446 my $on_ssl_error = delete $params{on_ssl_error} or defined wantarray 447 or croak "Expected 'on_ssl_error'"; 448 449 my $f = $loop->listen( 450 socktype => 'stream', 451 %params, 452 )->on_done( sub { 453 my $listener = shift; 454 455 my $cleartext_acceptor = $listener->acceptor; 456 my $ssl_acceptor = sub { 457 my $listener = shift; 458 my ( $listen_sock, %params ) = @_; 459 my $stream = $params{handle}; 460 !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 my ( $socket ) = @_; 465 466 return Future->done() unless $socket; # EAGAIN 467 468 $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 my ( $f, $failure ) = @_; 475 if( $on_ssl_error ) { 476 $on_ssl_error->( $failure ); 477 return Future->done; # eat it 478 } 479 return $f; 480 }); 481 }); 482 }; 483 484 $listener->configure( acceptor => $ssl_acceptor ); 485 }); 486 487 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 $f->on_ready( sub { undef $f } ); # intentional cycle 492} 493 494=head1 STREAM PROTOCOL METHODS 495 496The following extra methods are added to L<IO::Async::Protocol::Stream>. 497 498=cut 499 500=head2 SSL_upgrade 501 502 $protocol->SSL_upgrade( %params )->get; 503 504A shortcut to calling C<< $loop->SSL_upgrade >>. This method will unconfigure 505the C<transport> of the Protocol, upgrade its underlying filehandle to SSL, 506then reconfigure it again with SSL reader and writer functions on it. It takes 507the same arguments as C<< $loop->SSL_upgrade >>, except that the C<handle> 508argument is not required as it's taken from the Protocol's C<transport>. 509 510=cut 511 512sub IO::Async::Protocol::Stream::SSL_upgrade 513{ 514 my $protocol = shift; 515 my %params = @_; 516 517 my $on_upgraded = delete $params{on_upgraded} or croak "Expected 'on_upgraded'"; 518 519 my $loop = $protocol->get_loop or croak "Expected to be a member of a Loop"; 520 521 my $transport = $protocol->transport; 522 523 $protocol->configure( transport => undef ); 524 525 $loop->SSL_upgrade( 526 handle => $transport, 527 on_upgraded => sub { 528 my ( $transport ) = @_; 529 530 $protocol->configure( transport => $transport ); 531 532 $on_upgraded->(); 533 }, 534 535 %params, 536 ); 537} 538 539=head1 AUTHOR 540 541Paul Evans <leonerd@leonerd.org.uk> 542 543=cut 544 5450x55AA; 546