File Coverage

blib/lib/Net/WebSocket/Handshake/Client.pm
Criterion Covered Total %
statement 74 84 88.1
branch 19 30 63.3
condition 4 12 33.3
subroutine 16 17 94.1
pod 2 4 50.0
total 115 147 78.2


line stmt bran cond sub pod time code
1             package Net::WebSocket::Handshake::Client;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::WebSocket::Handshake::Client
8              
9             =head1 SYNOPSIS
10              
11             my $hsk = Net::WebSocket::Handshake::Client->new(
12              
13             #required
14             uri => 'ws://haha.test',
15              
16             #optional, to imitate a web client
17             origin => ..,
18              
19             #optional, base 64 .. auto-created if not given
20             key => '..',
21              
22             #optional
23             subprotocols => [ 'echo', 'haha' ],
24              
25             #optional
26             extensions => \@extension_objects,
27             );
28              
29             print $hsk->to_string();
30              
31             $hsk->consume_headers( NAME1 => VALUE1, .. );
32              
33             =head1 DESCRIPTION
34              
35             This class implements WebSocket handshake logic for a client.
36             It handles the basics of handshaking and, optionally, subprotocol
37             and extension negotiation.
38              
39             It is a subclass of L.
40              
41             =cut
42              
43 4     4   169086 use strict;
  4         22  
  4         174  
44 4     4   22 use warnings;
  4         8  
  4         114  
45              
46 4     4   1866 use parent qw( Net::WebSocket::Handshake );
  4         1180  
  4         26  
47              
48 4     4   1925 use URI::Split ();
  4         4780  
  4         103  
49              
50 4     4   1236 use Net::WebSocket::Constants ();
  4         10  
  4         74  
51 4     4   25 use Net::WebSocket::X ();
  4         8  
  4         94  
52              
53 4         4259 use constant SCHEMAS => (
54             'ws', 'wss',
55             'http', 'https',
56 4     4   20 );
  4         8  
57              
58             =head1 METHODS
59              
60             =head2 I->new( %OPTS )
61              
62             Returns an instance of the class; %OPTS includes the options from
63             L as well as:
64              
65             =over
66              
67             =item * C - (required) The full URI you’re connecting to.
68              
69             =item * C - (optional) The HTTP Origin header’s value. Useful
70             for imitating a web browser.
71              
72             =back
73              
74             =cut
75              
76             sub new {
77 4     4 1 1796 my ($class, %opts) = @_;
78              
79 4 50       23 if (length $opts{'uri'}) {
80 4         23 @opts{ 'uri_schema', 'uri_auth', 'uri_path', 'uri_query' } = URI::Split::uri_split($opts{'uri'});
81             }
82              
83 4 50 33     108 if (!$opts{'uri_schema'} || !grep { $_ eq $opts{'uri_schema'} } SCHEMAS()) {
  16         58  
84 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
85             }
86              
87 4 50       17 if (!length $opts{'uri_auth'}) {
88 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
89             }
90              
91 4         23 @opts{ 'uri_host', 'uri_port' } = split m<:>, $opts{'uri_auth'};
92              
93 4   33     30 $opts{'key'} ||= _create_key();
94              
95 4         62 return $class->SUPER::new(%opts);
96             }
97              
98             =head2 I->valid_status_or_die( CODE, REASON )
99              
100             Throws an exception if the given CODE isn’t the HTTP status code (101)
101             that WebSocket requires in response to all requests. (REASON is included
102             with the exception on error; otherwise it’s unused.)
103              
104             You only need this if if you’re not using a request-parsing interface
105             that’s compatible with L; otherwise,
106             L’s C function
107             will do this (and other niceties) for you.
108              
109             =cut
110              
111             sub valid_status_or_die {
112 1     1 1 21 my ($self, $code, $reason) = @_;
113              
114 1 50       5 if ($code ne Net::WebSocket::Constants::REQUIRED_HTTP_STATUS()) {
115 0         0 die Net::WebSocket::X->create('BadHTTPStatus', $code, $reason);
116             }
117              
118 1         3 return;
119             }
120              
121             #Shouldn’t be needed?
122             sub get_key {
123 1     1 0 7 my ($self) = @_;
124              
125 1         12 return $self->{'key'};
126             }
127              
128             #----------------------------------------------------------------------
129             #Legacy:
130              
131             =head1 LEGACY INTERFACE: SYNOPSIS
132              
133             my $hsk = Net::WebSocket::Handshake::Client->new(
134              
135             #..same as the newer interface, except:
136              
137             #optional
138             extensions => \@extension_objects,
139             );
140              
141             print $hsk->create_header_text() . "\x0d\x0a";
142              
143             #...Parse the response’s headers yourself...
144              
145             #Validates the value of the “Sec-WebSocket-Accept” header;
146             #throws Net::WebSocket::X::BadAccept if not.
147             $hsk->validate_accept_or_die($accept_value);
148              
149             =cut
150              
151             sub validate_accept_or_die {
152 2     2 0 7 my ($self, $received) = @_;
153              
154 2         12 my $should_be = $self->_get_accept();
155              
156 2 50       8 return if $received eq $should_be;
157              
158 0         0 die Net::WebSocket::X->create('BadAccept', $should_be, $received );
159             }
160              
161             #----------------------------------------------------------------------
162              
163             sub _create_header_lines {
164 3     3   8 my ($self) = @_;
165              
166 3         17 my $path = $self->{'uri_path'};
167              
168 3 50 33     30 if (!defined $path || !length $path) {
169 3         9 $path = '/';
170             }
171              
172 3 50 33     14 if (defined $self->{'uri_query'} && length $self->{'uri_query'}) {
173 0         0 $path .= "?$self->{'uri_query'}";
174             }
175              
176             return (
177             "GET $path HTTP/1.1",
178             "Host: $self->{'uri_host'}",
179              
180             #For now let’s assume no one wants any other Upgrade:
181             #or Connection: values than the ones WebSocket requires.
182             'Upgrade: websocket',
183             'Connection: Upgrade',
184              
185             "Sec-WebSocket-Key: $self->{'key'}",
186             'Sec-WebSocket-Version: ' . Net::WebSocket::Constants::PROTOCOL_VERSION(),
187              
188             $self->_encode_extensions(),
189              
190             $self->_encode_subprotocols(),
191              
192 3 100       32 ( $self->{'origin'} ? "Origin: $self->{'origin'}" : () ),
193             );
194             }
195              
196             sub _die_if_missing_headers {
197 2     2   5 my ($self) = @_;
198              
199 2         9 my @needed = $self->_missing_generic_headers();
200 2 50       7 push @needed, 'Sec-WebSocket-Accept' if !$self->{'_accept_header_ok'};
201              
202 2 50       26 if (@needed) {
203 0         0 die Net::WebSocket::X->create('MissingHeaders', @needed);
204             }
205              
206 2         16 return;
207             }
208              
209             sub _consume_peer_header {
210 7     7   27 my ($self, $name => $value) = @_;
211              
212 7         15 my $orig_name = $name;
213              
214 7         15 $name =~ tr; #case insensitivity
215              
216 7         26 for my $hdr_part ( qw( accept protocol extensions ) ) {
217 21 100       54 if ($name eq "sec-websocket-$hdr_part") {
218 3 50       12 if ( exists $self->{"_got_$name"} ) {
219 0         0 die Net::WebSocket::X->create('DuplicateHeader', $orig_name, $self->{"_got_$name"}, $value);
220             }
221              
222 3         11 $self->{"_got_$name"} = $value;
223             }
224             }
225              
226 7 100       30 if ($name eq 'sec-websocket-accept') {
    100          
227 2         9 $self->validate_accept_or_die($value);
228 2         6 $self->{'_accept_header_ok'} = 1;
229             }
230             elsif ($name eq 'sec-websocket-protocol') {
231 1 50       2 if (!grep { $_ eq $value } @{ $self->{'subprotocols'} }) {
  3         9  
  1         4  
232 0         0 die Net::WebSocket::X->create('UnknownSubprotocol', $value);
233             }
234              
235 1         3 $self->{'_subprotocol'} = $value;
236             }
237             else {
238 4         20 $self->_consume_generic_header($name => $value);
239             }
240              
241 7         29 return;
242             }
243              
244             sub _handle_unrecognized_extension {
245 0     0   0 my ($self, $xtn_obj) = @_;
246              
247 0         0 die Net::WebSocket::X->create('UnknownExtension', $xtn_obj->to_string());
248             }
249              
250              
251             sub _create_key {
252 4     4   968 require MIME::Base64;
253              
254             #NB: Not cryptographically secure, but it should be good enough
255             #for the purpose of a nonce. Most implementations use TLS anyway,
256             #so this is kind of pointless except that the RFC mandates it. :-/
257 4         1226 my $sixteen_bytes = pack 'S8', map { rand 65536 } 1 .. 8;
  32         243  
258              
259 4         27 my $b64 = MIME::Base64::encode_base64($sixteen_bytes);
260 4         19 chomp $b64;
261              
262 4         23 return $b64;
263             }
264              
265             #Send all extensions to the server in the request.
266 4     4   42 use constant _should_include_extension_in_headers => 1;
  4         9  
  4         265  
267              
268             1;