File Coverage

blib/lib/Mojo/IOLoop/TLS.pm
Criterion Covered Total %
statement 33 63 52.3
branch 5 32 15.6
condition 0 9 0.0
subroutine 12 16 75.0
pod 3 3 100.0
total 53 123 43.0


line stmt bran cond sub pod time code
1             package Mojo::IOLoop::TLS;
2 63     63   446513 use Mojo::Base 'Mojo::EventEmitter';
  63         145  
  63         452  
3              
4 63     63   17194 use Mojo::File qw(curfile);
  63         188  
  63         3471  
5 63     63   3598 use Mojo::IOLoop;
  63         173  
  63         377  
6 63     63   370 use Scalar::Util qw(weaken);
  63         260  
  63         8174  
7              
8             # TLS support requires IO::Socket::SSL
9 63 100   63   453 use constant TLS => $ENV{MOJO_NO_TLS} ? 0 : !!eval { require IO::Socket::SSL; IO::Socket::SSL->VERSION('2.009'); 1 };
  63         144  
  63         520  
  61         51455  
  61         2958114  
  61         5564  
10 63     63   588 use constant READ => TLS ? IO::Socket::SSL::SSL_WANT_READ() : 0;
  63         162  
  63         3539  
11 63     63   466 use constant WRITE => TLS ? IO::Socket::SSL::SSL_WANT_WRITE() : 0;
  63         157  
  63         61506  
12              
13             has reactor => sub { Mojo::IOLoop->singleton->reactor }, weak => 1;
14              
15             # To regenerate the certificate run this command (28.06.2019)
16             # openssl req -x509 -newkey rsa:4096 -nodes -sha256 -out server.crt \
17             # -keyout server.key -days 7300 -subj '/CN=localhost'
18             my $CERT = curfile->sibling('resources', 'server.crt')->to_string;
19             my $KEY = curfile->sibling('resources', 'server.key')->to_string;
20              
21 2     2   9 sub DESTROY { shift->_cleanup }
22              
23 149     149 1 1427 sub can_tls {TLS}
24              
25             sub negotiate {
26 2 50   2 1 20 my ($self, $args) = (shift, ref $_[0] ? $_[0] : {@_});
27              
28 2         9 return $self->emit(error => 'IO::Socket::SSL 2.009+ required for TLS support') unless TLS;
29              
30 0         0 my $handle = $self->{handle};
31             return $self->emit(error => $IO::Socket::SSL::SSL_ERROR)
32 0 0       0 unless IO::Socket::SSL->start_SSL($handle, %{$self->_expand($args)});
  0         0  
33 0     0   0 $self->reactor->io($handle => sub { $self->_tls($handle, $args->{server}) });
  0         0  
34             }
35              
36 2     2 1 18 sub new { shift->SUPER::new(handle => shift) }
37              
38             sub _cleanup {
39 2     2   7 my $self = shift;
40 2 50       7 return undef unless my $reactor = $self->reactor;
41 2 50       12 $reactor->remove($self->{handle}) if $self->{handle};
42 2         19 return $self;
43             }
44              
45             sub _expand {
46 0     0     my ($self, $args) = @_;
47              
48 0           weaken $self;
49 0     0     my $tls = {SSL_error_trap => sub { $self->_cleanup->emit(error => $_[1]) }, SSL_startHandshake => 0};
  0            
50 0 0 0       $tls->{SSL_ca_file} = $args->{tls_ca} if $args->{tls_ca} && -T $args->{tls_ca};
51 0 0         $tls->{SSL_cert_file} = $args->{tls_cert} if $args->{tls_cert};
52 0 0         $tls->{SSL_key_file} = $args->{tls_key} if $args->{tls_key};
53 0 0         $tls->{SSL_server} = $args->{server} if $args->{server};
54 0 0         @{$tls}{keys %{$args->{tls_options}}} = values %{$args->{tls_options}} if $args->{tls_options};
  0            
  0            
  0            
55              
56 0 0         if ($args->{server}) {
57 0   0       $tls->{SSL_cert_file} ||= $CERT;
58 0   0       $tls->{SSL_key_file} ||= $KEY;
59             }
60             else {
61 0 0         $tls->{SSL_hostname} = IO::Socket::SSL->can_client_sni ? $args->{address} : '';
62 0           $tls->{SSL_verifycn_name} = $args->{address};
63             }
64              
65 0           return $tls;
66             }
67              
68             sub _tls {
69 0     0     my ($self, $handle, $server) = @_;
70              
71             # Switch between reading and writing
72 0 0         if (!($server ? $handle->accept_SSL : $handle->connect_SSL)) {
    0          
73 0           my $err = $IO::Socket::SSL::SSL_ERROR;
74 0 0         if ($err == READ) { $self->reactor->watch($handle, 1, 0) }
  0 0          
75 0           elsif ($err == WRITE) { $self->reactor->watch($handle, 1, 1) }
76             }
77              
78 0           else { $self->_cleanup->emit(upgrade => delete $self->{handle}) }
79             }
80              
81             1;
82              
83             =encoding utf8
84              
85             =head1 NAME
86              
87             Mojo::IOLoop::TLS - Non-blocking TLS handshake
88              
89             =head1 SYNOPSIS
90              
91             use Mojo::IOLoop::TLS;
92              
93             # Negotiate TLS
94             my $tls = Mojo::IOLoop::TLS->new($old_handle);
95             $tls->on(upgrade => sub ($tls, $new_handle) {...});
96             $tls->on(error => sub ($tls, $err) {...});
97             $tls->negotiate(server => 1, tls_version => 'TLSv1_2');
98              
99             # Start reactor if necessary
100             $tls->reactor->start unless $tls->reactor->is_running;
101              
102             =head1 DESCRIPTION
103              
104             L negotiates TLS for L.
105              
106             =head1 EVENTS
107              
108             L inherits all events from L and can emit the following new ones.
109              
110             =head2 upgrade
111              
112             $tls->on(upgrade => sub ($tls, $handle) {...});
113              
114             Emitted once TLS has been negotiated.
115              
116             =head2 error
117              
118             $tls->on(error => sub ($tls, $err) {...});
119              
120             Emitted if an error occurs during negotiation, fatal if unhandled.
121              
122             =head1 ATTRIBUTES
123              
124             L implements the following attributes.
125              
126             =head2 reactor
127              
128             my $reactor = $tls->reactor;
129             $tls = $tls->reactor(Mojo::Reactor::Poll->new);
130              
131             Low-level event reactor, defaults to the C attribute value of the global L singleton. Note that
132             this attribute is weakened.
133              
134             =head1 METHODS
135              
136             L inherits all methods from L and implements the following new ones.
137              
138             =head2 can_tls
139              
140             my $bool = Mojo::IOLoop::TLS->can_tls;
141              
142             True if L 2.009+ is installed and TLS support enabled.
143              
144             =head2 negotiate
145              
146             $tls->negotiate(server => 1, tls_version => 'TLSv1_2');
147             $tls->negotiate({server => 1, tls_version => 'TLSv1_2'});
148              
149             Negotiate TLS.
150              
151             These options are currently available:
152              
153             =over 2
154              
155             =item server
156              
157             server => 1
158              
159             Negotiate TLS from the server-side, defaults to the client-side.
160              
161             =item tls_ca
162              
163             tls_ca => '/etc/tls/ca.crt'
164              
165             Path to TLS certificate authority file.
166              
167             =item tls_cert
168              
169             tls_cert => '/etc/tls/server.crt'
170             tls_cert => {'mojolicious.org' => '/etc/tls/mojo.crt'}
171              
172             Path to the TLS cert file, defaults to a built-in test certificate on the server-side.
173              
174             =item tls_key
175              
176             tls_key => '/etc/tls/server.key'
177             tls_key => {'mojolicious.org' => '/etc/tls/mojo.key'}
178              
179             Path to the TLS key file, defaults to a built-in test key on the server-side.
180              
181             =item tls_options
182              
183             tls_options => {SSL_alpn_protocols => ['foo', 'bar'], SSL_verify_mode => 0x00, SSL_version => 'TLSv1_2'}
184              
185             Additional options for L.
186              
187             =back
188              
189             =head2 new
190              
191             my $tls = Mojo::IOLoop::TLS->new($handle);
192              
193             Construct a new L object.
194              
195             =head1 SEE ALSO
196              
197             L, L, L.
198              
199             =cut