File Coverage

blib/lib/Net/WebSocket/Handshake.pm
Criterion Covered Total %
statement 84 106 79.2
branch 21 40 52.5
condition 1 3 33.3
subroutine 18 20 90.0
pod 4 5 80.0
total 128 174 73.5


line stmt bran cond sub pod time code
1             package Net::WebSocket::Handshake;
2              
3 3     3   785 use strict;
  3         5  
  3         72  
4 3     3   12 use warnings;
  3         5  
  3         77  
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   990 use Digest::SHA ();
  3         6913  
  3         69  
24 3     3   853 use HTTP::Headers::Util ();
  3         2377  
  3         56  
25 3     3   836 use Module::Load ();
  3         3074  
  3         63  
26              
27 3     3   856 use Net::WebSocket::HTTP ();
  3         10  
  3         56  
28 3     3   20 use Net::WebSocket::X ();
  3         5  
  3         98  
29              
30             use constant {
31 3         3331 _WS_MAGIC_CONSTANT => '258EAFA5-E914-47DA-95CA-C5AB0DC85B11',
32             CRLF => "\x0d\x0a",
33 3     3   14 };
  3         7  
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 4360 my ($class, %opts) = @_;
82              
83 5 100       20 if ($opts{'extensions'}) {
84 1         2 $opts{'_extension_tokens'} = { map { $_->token() => $_ } @{ $opts{'extensions'} } };
  2         6  
  1         3  
85             }
86              
87 5         23 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 11 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         9 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         7 $self->{'_no_use_legacy'} = 1;
118              
119 2         8 while ( my ($k => $v) = splice( @kv_pairs, 0, 2 ) ) {
120 10         24 $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 20 my $self = shift;
145              
146 3         13 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   8 my ($self) = @_;
191              
192 3 50       15 my $key_b64 = $self->{'key'} or do {
193 0         0 die Net::WebSocket::X->create('BadArg', key => $self->{'key'});
194             };
195              
196 3         20 $key_b64 =~ s<\A\s+|\s+\z><>g;
197              
198 3         39 my $accept = Digest::SHA::sha1_base64( $key_b64 . _WS_MAGIC_CONSTANT() );
199              
200             #pad base64
201 3         16 $accept .= '=' x (4 - (length($accept) % 4));
202              
203 3         16 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   64 my ($self) = @_;
210              
211             return ( $self->{'subprotocols'} && @{ $self->{'subprotocols'} }
212 3 50 33     14 ? ( 'Sec-WebSocket-Protocol: ' . join(', ', @{ $self->{'subprotocols'} } ) )
  3         43  
213             : ()
214             );
215             }
216              
217             sub _encode_extensions {
218 3     3   9 my ($self) = @_;
219              
220 3 100       21 return if !$self->{'extensions'};
221              
222 1         2 my @handshake_xtns;
223 1         2 for my $xtn ( @{ $self->{'extensions'} } ) {
  1         34  
224 2 50       13 if ( $xtn->isa('Net::WebSocket::Handshake::Extension') ) {
    0          
225 2         8 $self->_warn_legacy();
226 2         5 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       4 return if !@handshake_xtns;
234              
235 1         3 my ($first, @others) = @handshake_xtns;
236              
237 1         5 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         3 my $ref = ref $self;
245 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.)";
246              
247 1         4 $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       4 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   10 my ($self, $hname, $value) = @_;
288              
289 5         11 tr for ($hname);
290              
291 5 100       14 if ($hname eq 'connection') {
    100          
    50          
    50          
292 2         4 $value =~ tr;
293 2         7 for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) {
294 2 50       5 if ($t eq 'upgrade') {
295 2         5 $self->{'_connection_header_ok'} = 1;
296             }
297             }
298             }
299             elsif ($hname eq 'upgrade') {
300 2         5 $value =~ tr;
301 2         4 for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) {
302 2 50       6 if ($t eq 'websocket') {
303 2         3 $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;