line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::WebSocket::Handshake; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
766
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
68
|
|
4
|
3
|
|
|
3
|
|
12
|
use warnings; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
75
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=encoding utf-8 |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
Net::WebSocket::Handshake - base class for handshake objects |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 DESCRIPTION |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
This base class’s L and |
15
|
|
|
|
|
|
|
L subclasses implement |
16
|
|
|
|
|
|
|
WebSocket’s handshake logic. They handle the basics of a WebSocket |
17
|
|
|
|
|
|
|
handshake and, optionally, subprotocol and extension negotiation. |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
This base class is NOT directly instantiable. |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=cut |
22
|
|
|
|
|
|
|
|
23
|
3
|
|
|
3
|
|
822
|
use Digest::SHA (); |
|
3
|
|
|
|
|
6500
|
|
|
3
|
|
|
|
|
113
|
|
24
|
3
|
|
|
3
|
|
767
|
use HTTP::Headers::Util (); |
|
3
|
|
|
|
|
2161
|
|
|
3
|
|
|
|
|
52
|
|
25
|
3
|
|
|
3
|
|
729
|
use Module::Load (); |
|
3
|
|
|
|
|
2496
|
|
|
3
|
|
|
|
|
52
|
|
26
|
|
|
|
|
|
|
|
27
|
3
|
|
|
3
|
|
793
|
use Net::WebSocket::HTTP (); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
47
|
|
28
|
3
|
|
|
3
|
|
15
|
use Net::WebSocket::X (); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
79
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
use constant { |
31
|
3
|
|
|
|
|
2886
|
_WS_MAGIC_CONSTANT => '258EAFA5-E914-47DA-95CA-C5AB0DC85B11', |
32
|
|
|
|
|
|
|
CRLF => "\x0d\x0a", |
33
|
3
|
|
|
3
|
|
14
|
}; |
|
3
|
|
|
|
|
5
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 METHODS |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head2 I->new( %OPTS ) |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
Returns an instance of the relevant subclass |
42
|
|
|
|
|
|
|
(L or |
43
|
|
|
|
|
|
|
L). |
44
|
|
|
|
|
|
|
The following are common options for both: |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=over |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=item * C - A list of HTTP tokens (e.g., C) |
49
|
|
|
|
|
|
|
that stand for subprotocols that this endpoint can use via the WebSocket |
50
|
|
|
|
|
|
|
connection. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=item * C - A list of extension objects that the Handshake |
53
|
|
|
|
|
|
|
object will interact with to determine extension support. |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 COMMON EXTENSION INTERFACE |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
Each object in the C array must implement the following methods: |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=over |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=item * C The extension’s token. (e.g., C) |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=item * C Returns an instance of |
64
|
|
|
|
|
|
|
L to represent the extension and |
65
|
|
|
|
|
|
|
its parameters in the HTTP headers. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=item * C Receives the extension parameters |
68
|
|
|
|
|
|
|
(in the format that C |
69
|
|
|
|
|
|
|
returns). This operation should configure the object to return the proper |
70
|
|
|
|
|
|
|
value from its C method. |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=item * C A boolean that indicates whether the peer indicates |
73
|
|
|
|
|
|
|
proper support for the extension. This should not be called until after |
74
|
|
|
|
|
|
|
C
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=back |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=cut |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub new { |
81
|
5
|
|
|
5
|
1
|
4885
|
my ($class, %opts) = @_; |
82
|
|
|
|
|
|
|
|
83
|
5
|
100
|
|
|
|
22
|
if ($opts{'extensions'}) { |
84
|
1
|
|
|
|
|
2
|
$opts{'_extension_tokens'} = { map { $_->token() => $_ } @{ $opts{'extensions'} } }; |
|
2
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
3
|
|
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
5
|
|
|
|
|
24
|
return bless \%opts, $class; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head2 $sp_token = I->get_subprotocol() |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Returns the negotiated subprotocol’s token (e.g., C). |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=cut |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub get_subprotocol { |
97
|
2
|
|
|
2
|
1
|
14
|
my $self = shift; |
98
|
|
|
|
|
|
|
|
99
|
2
|
50
|
|
|
|
6
|
if (!$self->{'_no_use_legacy'}) { |
100
|
0
|
|
|
|
|
0
|
die 'Must call consume_headers() first!'; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
2
|
|
|
|
|
11
|
return $self->{'_subprotocol'}; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
#sub get_match_extensions { |
107
|
|
|
|
|
|
|
# my $self = shift; |
108
|
|
|
|
|
|
|
# |
109
|
|
|
|
|
|
|
# Call::Context::must_be_list(); |
110
|
|
|
|
|
|
|
# |
111
|
|
|
|
|
|
|
# return { %{ $self->{'_match_extensions'} } }; |
112
|
|
|
|
|
|
|
#} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub consume_headers { |
115
|
2
|
|
|
2
|
0
|
8
|
my ($self, @kv_pairs) = @_; |
116
|
|
|
|
|
|
|
|
117
|
2
|
|
|
|
|
10
|
$self->{'_no_use_legacy'} = 1; |
118
|
|
|
|
|
|
|
|
119
|
2
|
|
|
|
|
9
|
while ( my ($k => $v) = splice( @kv_pairs, 0, 2 ) ) { |
120
|
10
|
|
|
|
|
22
|
$self->_consume_peer_header($k => $v); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
2
|
|
|
|
|
9
|
$self->_valid_headers_or_die(); |
124
|
|
|
|
|
|
|
|
125
|
2
|
|
|
|
|
7
|
return; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head2 my $hdrs_txt = I->to_string() |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
The text of the HTTP headers to send, with the 2nd trailing CR/LF |
131
|
|
|
|
|
|
|
that ends the headers portion of an HTTP message. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
If you use this object |
134
|
|
|
|
|
|
|
to negotiate a subprotocol and/or extensions, those will be included |
135
|
|
|
|
|
|
|
in the output from this method. |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
To append custom headers, do the following with the result of this method: |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
substr($hdrs_txt, -2, 0) = '..'; |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=cut |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub to_string { |
144
|
3
|
|
|
3
|
1
|
18
|
my $self = shift; |
145
|
|
|
|
|
|
|
|
146
|
3
|
|
|
|
|
41
|
return join( CRLF(), $self->_create_header_lines(), q<>, q<> ); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=head1 LEGACY INTERFACE |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Prior to version 0.5 this module was a great deal less “helpful”: |
152
|
|
|
|
|
|
|
it required callers to parse out and write WebSocket headers, |
153
|
|
|
|
|
|
|
doing most of the validation manually. Version 0.5 added a generic |
154
|
|
|
|
|
|
|
interface for entering in HTTP headers, which allows Net::WebSocket to |
155
|
|
|
|
|
|
|
handle the parsing and creation of HTTP headers as well as subprotocol |
156
|
|
|
|
|
|
|
and extension negotiation. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
For now the legacy functionality is being left in; however, |
159
|
|
|
|
|
|
|
it is considered DEPRECATED and will be removed eventually. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=head2 my $hdrs_txt = I->create_header_text() |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
The same output as C but minus the 2nd trailing |
164
|
|
|
|
|
|
|
CR/LF. (This was intended to facilitate adding other headers; however, |
165
|
|
|
|
|
|
|
that’s done easily enough with the newer C.) |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=cut |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub create_header_text { |
170
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
171
|
|
|
|
|
|
|
|
172
|
0
|
|
|
|
|
0
|
return join( CRLF(), $self->_create_header_lines(), q<> ); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=head1 SEE ALSO |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=over |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=item * L |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item * L |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=back |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=cut |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _get_accept { |
190
|
3
|
|
|
3
|
|
5
|
my ($self) = @_; |
191
|
|
|
|
|
|
|
|
192
|
3
|
50
|
|
|
|
13
|
my $key_b64 = $self->{'key'} or do { |
193
|
0
|
|
|
|
|
0
|
die Net::WebSocket::X->create('BadArg', key => $self->{'key'}); |
194
|
|
|
|
|
|
|
}; |
195
|
|
|
|
|
|
|
|
196
|
3
|
|
|
|
|
18
|
$key_b64 =~ s<\A\s+|\s+\z><>g; |
197
|
|
|
|
|
|
|
|
198
|
3
|
|
|
|
|
31
|
my $accept = Digest::SHA::sha1_base64( $key_b64 . _WS_MAGIC_CONSTANT() ); |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
#pad base64 |
201
|
3
|
|
|
|
|
13
|
$accept .= '=' x (4 - (length($accept) % 4)); |
202
|
|
|
|
|
|
|
|
203
|
3
|
|
|
|
|
13
|
return $accept; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
#Post-legacy, move this to Client and have the Server use logic |
207
|
|
|
|
|
|
|
#that allows only one. |
208
|
|
|
|
|
|
|
sub _encode_subprotocols { |
209
|
3
|
|
|
3
|
|
61
|
my ($self) = @_; |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
return ( $self->{'subprotocols'} && @{ $self->{'subprotocols'} } |
212
|
3
|
50
|
33
|
|
|
12
|
? ( 'Sec-WebSocket-Protocol: ' . join(', ', @{ $self->{'subprotocols'} } ) ) |
|
3
|
|
|
|
|
34
|
|
213
|
|
|
|
|
|
|
: () |
214
|
|
|
|
|
|
|
); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub _encode_extensions { |
218
|
3
|
|
|
3
|
|
8
|
my ($self) = @_; |
219
|
|
|
|
|
|
|
|
220
|
3
|
100
|
|
|
|
19
|
return if !$self->{'extensions'}; |
221
|
|
|
|
|
|
|
|
222
|
1
|
|
|
|
|
2
|
my @handshake_xtns; |
223
|
1
|
|
|
|
|
1
|
for my $xtn ( @{ $self->{'extensions'} } ) { |
|
1
|
|
|
|
|
28
|
|
224
|
2
|
50
|
|
|
|
12
|
if ( $xtn->isa('Net::WebSocket::Handshake::Extension') ) { |
|
|
0
|
|
|
|
|
|
225
|
2
|
|
|
|
|
9
|
$self->_warn_legacy(); |
226
|
2
|
|
|
|
|
4
|
push @handshake_xtns, $xtn; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
elsif ( $self->_should_include_extension_in_headers($xtn) ) { |
229
|
0
|
|
|
|
|
0
|
push @handshake_xtns, $xtn->get_handshake_object(); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
1
|
50
|
|
|
|
3
|
return if !@handshake_xtns; |
234
|
|
|
|
|
|
|
|
235
|
1
|
|
|
|
|
3
|
my ($first, @others) = @handshake_xtns; |
236
|
|
|
|
|
|
|
|
237
|
1
|
|
|
|
|
3
|
return 'Sec-WebSocket-Extensions: ' . $first->to_string(@others); |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub _warn_legacy { |
241
|
2
|
|
|
2
|
|
3
|
my ($self) = @_; |
242
|
|
|
|
|
|
|
|
243
|
2
|
100
|
|
|
|
5
|
if (!$self->{'_warned_legacy'}) { |
244
|
1
|
|
|
|
|
2
|
my $ref = ref $self; |
245
|
1
|
|
|
|
|
31
|
warn "You are using $ref’s legacy interface. This interface will eventually be removed from $ref entirely, so please update your application to the newer interface. (The update should simplify your code.)"; |
246
|
|
|
|
|
|
|
|
247
|
1
|
|
|
|
|
5
|
$self->{'_warned_legacy'}++; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
2
|
|
|
|
|
3
|
return; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub _missing_generic_headers { |
254
|
2
|
|
|
2
|
|
5
|
my ($self) = @_; |
255
|
|
|
|
|
|
|
|
256
|
2
|
|
|
|
|
3
|
my @missing; |
257
|
2
|
50
|
|
|
|
6
|
push @missing, 'Connection' if !$self->{'_connection_header_ok'}; |
258
|
2
|
50
|
|
|
|
5
|
push @missing, 'Upgrade' if !$self->{'_upgrade_header_ok'}; |
259
|
|
|
|
|
|
|
|
260
|
2
|
|
|
|
|
5
|
return @missing; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub _consume_sec_websocket_extensions_header { |
264
|
0
|
|
|
0
|
|
0
|
my ($self, $value) = @_; |
265
|
|
|
|
|
|
|
|
266
|
0
|
|
|
|
|
0
|
Module::Load::load('Net::WebSocket::Handshake::Extension'); |
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
|
|
0
|
for my $xtn ( Net::WebSocket::Handshake::Extension->parse_string($value) ) { |
269
|
0
|
|
|
|
|
0
|
my $xtn_token = $xtn->token(); |
270
|
0
|
|
|
|
|
0
|
my $xtn_handler = $self->{'_extension_tokens'}{ $xtn_token }; |
271
|
0
|
0
|
|
|
|
0
|
if ($xtn_handler) { |
272
|
0
|
|
|
|
|
0
|
$xtn_handler->consume_parameters($xtn->parameters()); |
273
|
|
|
|
|
|
|
|
274
|
0
|
0
|
|
|
|
0
|
if ($xtn_handler->ok_to_use()) { |
275
|
0
|
|
|
|
|
0
|
$self->{'_match_extensions'}{ $xtn_token } = $xtn_handler; |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
else { |
279
|
0
|
|
|
|
|
0
|
$self->_handle_unrecognized_extension($xtn); |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
0
|
|
|
|
|
0
|
return; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub _consume_generic_header { |
287
|
5
|
|
|
5
|
|
9
|
my ($self, $hname, $value) = @_; |
288
|
|
|
|
|
|
|
|
289
|
5
|
|
|
|
|
11
|
tr for ($hname); |
290
|
|
|
|
|
|
|
|
291
|
5
|
100
|
|
|
|
16
|
if ($hname eq 'connection') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
292
|
2
|
|
|
|
|
4
|
$value =~ tr; |
293
|
2
|
|
|
|
|
8
|
for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) { |
294
|
2
|
50
|
|
|
|
6
|
if ($t eq 'upgrade') { |
295
|
2
|
|
|
|
|
6
|
$self->{'_connection_header_ok'} = 1; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
elsif ($hname eq 'upgrade') { |
300
|
2
|
|
|
|
|
4
|
$value =~ tr; |
301
|
2
|
|
|
|
|
3
|
for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) { |
302
|
2
|
50
|
|
|
|
5
|
if ($t eq 'websocket') { |
303
|
2
|
|
|
|
|
4
|
$self->{'_upgrade_header_ok'} = 1; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
elsif ($hname eq 'sec-websocket-protocol') { |
308
|
0
|
|
|
|
|
0
|
for my $token ( Net::WebSocket::HTTP::split_tokens($value) ) { |
309
|
0
|
0
|
|
|
|
0
|
if (!defined $self->{'_match_protocol'}) { |
310
|
0
|
|
|
|
|
0
|
($self->{'_match_protocol'}) = grep { $_ eq $token } @{ $self->{'subprotocols'} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
elsif ($hname eq 'sec-websocket-extensions') { |
315
|
0
|
|
|
|
|
0
|
$self->_consume_sec_websocket_extensions_header($value); |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
5
|
|
|
|
|
10
|
return; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
1; |