File Coverage

blib/lib/Net/WebSocket/Handshake/Client.pm
Criterion Covered Total %
statement 72 82 87.8
branch 21 32 65.6
condition 2 6 33.3
subroutine 16 17 94.1
pod 2 4 50.0
total 113 141 80.1


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 3     3   109761 use strict;
  3         19  
  3         70  
44 3     3   13 use warnings;
  3         10  
  3         67  
45              
46 3     3   626 use parent qw( Net::WebSocket::Handshake );
  3         633  
  3         12  
47              
48 3     3   763 use URI::Split ();
  3         2826  
  3         66  
49              
50 3     3   960 use Net::WebSocket::Constants ();
  3         9  
  3         58  
51 3     3   17 use Net::WebSocket::X ();
  3         7  
  3         60  
52              
53 3         2191 use constant SCHEMAS => (
54             'ws', 'wss',
55             'http', 'https',
56 3     3   11 );
  3         5  
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 3     3 1 766 my ($class, %opts) = @_;
78              
79 3 50       13 if (length $opts{'uri'}) {
80 3         13 @opts{ 'uri_schema', 'uri_auth', 'uri_path', 'uri_query' } = URI::Split::uri_split($opts{'uri'});
81             }
82              
83 3 50 33     44 if (!$opts{'uri_schema'} || !grep { $_ eq $opts{'uri_schema'} } SCHEMAS()) {
  12         34  
84 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
85             }
86              
87 3 50       11 if (!length $opts{'uri_auth'}) {
88 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
89             }
90              
91 3         15 @opts{ 'uri_host', 'uri_port' } = split m<:>, $opts{'uri_auth'};
92              
93 3   33     16 $opts{'key'} ||= _create_key();
94              
95 3         28 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 17 my ($self, $code, $reason) = @_;
113              
114 1 50       4 if ($code ne Net::WebSocket::Constants::REQUIRED_HTTP_STATUS()) {
115 0         0 die Net::WebSocket::X->create('BadHTTPStatus', $code, $reason);
116             }
117              
118 1         2 return;
119             }
120              
121             #Shouldn’t be needed?
122             sub get_key {
123 1     1 0 5 my ($self) = @_;
124              
125 1         9 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 1     1 0 2 my ($self, $received) = @_;
153              
154 1         4 my $should_be = $self->_get_accept();
155              
156 1 50       3 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 2     2   4 my ($self) = @_;
165              
166 2         8 my $path = $self->{'uri_path'};
167              
168 2 50       6 if (!length $path) {
169 2         5 $path = '/';
170             }
171              
172 2 50       6 if (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 2 100       16 ( $self->{'origin'} ? "Origin: $self->{'origin'}" : () ),
193             );
194             }
195              
196             sub _valid_headers_or_die {
197 1     1   2 my ($self) = @_;
198              
199 1         5 my @needed = $self->_missing_generic_headers();
200 1 50       4 push @needed, 'Sec-WebSocket-Accept' if !$self->{'_accept_header_ok'};
201              
202 1 50       3 if (@needed) {
203 0         0 die Net::WebSocket::X->create('MissingHeaders', @needed);
204             }
205              
206 1         2 return;
207             }
208              
209             sub _consume_peer_header {
210 4     4   8 my ($self, $name => $value) = @_;
211              
212 4         6 for my $hdr_part ( qw( Accept Protocol Extensions ) ) {
213 12 100       23 if ($name eq "Sec-WebSocket-$hdr_part") {
214 2 50       7 if ( exists $self->{"_got_$name"} ) {
215 0         0 die Net::WebSocket::X->create('DuplicateHeader', $name, $self->{"_got_$name"}, $value);
216             }
217              
218 2         5 $self->{"_got_$name"} = $value;
219             }
220             }
221              
222 4 100       10 if ($name eq 'Sec-WebSocket-Accept') {
    100          
223 1         3 $self->validate_accept_or_die($value);
224 1         2 $self->{'_accept_header_ok'} = 1;
225             }
226             elsif ($name eq 'Sec-WebSocket-Protocol') {
227 1 50       6 if (!grep { $_ eq $value } @{ $self->{'subprotocols'} }) {
  3         16  
  1         3  
228 0         0 die Net::WebSocket::X->create('UnknownSubprotocol', $value);
229             }
230              
231 1         4 $self->{'_subprotocol'} = $value;
232             }
233             else {
234 2         6 $self->_consume_generic_header($name => $value);
235             }
236              
237 4         14 return;
238             }
239              
240             sub _handle_unrecognized_extension {
241 0     0   0 my ($self, $xtn_obj) = @_;
242              
243 0         0 die Net::WebSocket::X->create('UnknownExtension', $xtn_obj->to_string());
244             }
245              
246              
247             sub _create_key {
248 3 100   3   34 Module::Load::load('MIME::Base64') if !MIME::Base64->can('encode');
249              
250             #NB: Not cryptographically secure, but it should be good enough
251             #for the purpose of a nonce.
252 3         732 my $sixteen_bytes = pack 'S8', map { rand 65536 } 1 .. 8;
  24         124  
253              
254 3         13 my $b64 = MIME::Base64::encode_base64($sixteen_bytes);
255 3         9 chomp $b64;
256              
257 3         13 return $b64;
258             }
259              
260             #Send all extensions to the server in the request.
261 3     3   20 use constant _should_include_extension_in_headers => 1;
  3         5  
  3         123  
262              
263             1;