File Coverage

blib/lib/Net/WebSocket/Handshake.pm
Criterion Covered Total %
statement 88 113 77.8
branch 32 48 66.6
condition 2 3 66.6
subroutine 17 19 89.4
pod 5 5 100.0
total 144 188 76.6


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