File Coverage

blib/lib/Net/WebSocket/Handshake/Client.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


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 2     2   108234 use strict;
  2         20  
  2         47  
44 2     2   9 use warnings;
  2         3  
  2         51  
45              
46 2     2   413 use parent qw( Net::WebSocket::Handshake );
  2         409  
  2         9  
47              
48             use URI::Split ();
49              
50             use Net::WebSocket::Constants ();
51             use Net::WebSocket::X ();
52              
53             use constant SCHEMAS => (
54             'ws', 'wss',
55             'http', 'https',
56             );
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             my ($class, %opts) = @_;
78              
79             if (length $opts{'uri'}) {
80             @opts{ 'uri_schema', 'uri_auth', 'uri_path', 'uri_query' } = URI::Split::uri_split($opts{'uri'});
81             }
82              
83             if (!$opts{'uri_schema'} || !grep { $_ eq $opts{'uri_schema'} } SCHEMAS()) {
84             die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
85             }
86              
87             if (!length $opts{'uri_auth'}) {
88             die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
89             }
90              
91             @opts{ 'uri_host', 'uri_port' } = split m<:>, $opts{'uri_auth'};
92              
93             $opts{'key'} ||= _create_key();
94              
95             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             my ($self, $code, $reason) = @_;
113              
114             if ($code ne Net::WebSocket::Constants::REQUIRED_HTTP_STATUS()) {
115             die Net::WebSocket::X->create('BadHTTPStatus', $code, $reason);
116             }
117              
118             return;
119             }
120              
121             #Shouldn’t be needed?
122             sub get_key {
123             my ($self) = @_;
124              
125             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             my ($self, $received) = @_;
153              
154             my $should_be = $self->_get_accept();
155              
156             return if $received eq $should_be;
157              
158             die Net::WebSocket::X->create('BadAccept', $should_be, $received );
159             }
160              
161             #----------------------------------------------------------------------
162              
163             sub _create_header_lines {
164             my ($self) = @_;
165              
166             my $path = $self->{'uri_path'};
167              
168             if (!length $path) {
169             $path = '/';
170             }
171              
172             if (length $self->{'uri_query'}) {
173             $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             ( $self->{'origin'} ? "Origin: $self->{'origin'}" : () ),
193             );
194             }
195              
196             sub _valid_headers_or_die {
197             my ($self) = @_;
198              
199             my @needed = $self->_missing_generic_headers();
200             push @needed, 'Sec-WebSocket-Accept' if !$self->{'_accept_header_ok'};
201              
202             if (@needed) {
203             die Net::WebSocket::X->create('MissingHeaders', @needed);
204             }
205              
206             return;
207             }
208              
209             sub _consume_peer_header {
210             my ($self, $name => $value) = @_;
211              
212             for my $hdr_part ( qw( Accept Protocol Extensions ) ) {
213             if ($name eq "Sec-WebSocket-$hdr_part") {
214             if ( exists $self->{"_got_$name"} ) {
215             die Net::WebSocket::X->create('DuplicateHeader', $name, $self->{"_got_$name"}, $value);
216             }
217              
218             $self->{"_got_$name"} = $value;
219             }
220             }
221              
222             if ($name eq 'Sec-WebSocket-Accept') {
223             $self->validate_accept_or_die($value);
224             $self->{'_accept_header_ok'} = 1;
225             }
226             elsif ($name eq 'Sec-WebSocket-Protocol') {
227             if (!grep { $_ eq $value } @{ $self->{'subprotocols'} }) {
228             die Net::WebSocket::X->create('UnknownSubprotocol', $value);
229             }
230              
231             $self->{'_subprotocol'} = $value;
232             }
233             else {
234             $self->_consume_generic_header($name => $value);
235             }
236              
237             return;
238             }
239              
240             sub _handle_unrecognized_extension {
241             my ($self, $xtn_obj) = @_;
242              
243             die Net::WebSocket::X->create('UnknownExtension', $xtn_obj->to_string());
244             }
245              
246              
247             sub _create_key {
248             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             my $sixteen_bytes = pack 'S8', map { rand 65536 } 1 .. 8;
253              
254             my $b64 = MIME::Base64::encode_base64($sixteen_bytes);
255             chomp $b64;
256              
257             return $b64;
258             }
259              
260             #Send all extensions to the server in the request.
261             use constant _should_include_extension_in_headers => 1;
262              
263             1;