File Coverage

blib/lib/Net/WebSocket/Handshake/Server.pm
Criterion Covered Total %
statement 59 61 96.7
branch 25 26 96.1
condition n/a
subroutine 13 14 92.8
pod 2 2 100.0
total 99 103 96.1


line stmt bran cond sub pod time code
1             package Net::WebSocket::Handshake::Server;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::WebSocket::Handshake::Server
8              
9             =head1 SYNOPSIS
10              
11             my $hsk = Net::WebSocket::Handshake::Server->new(
12              
13             #optional
14             subprotocols => [ 'echo', 'haha' ],
15              
16             #optional
17             extensions => \@extension_objects,
18             );
19              
20             $hsk->valid_method_or_die( $http_method ); #optional
21              
22             $hsk->consume_headers(@headers_kv_pairs);
23              
24             my $resp_hdr = $hsk->to_string();
25              
26             =head1 DESCRIPTION
27              
28             This class implements WebSocket handshake logic for a server.
29             It handles the basics of handshaking and, optionally, subprotocol
30             and extension negotiation.
31              
32             =cut
33              
34 5     5   1948 use strict;
  5         9  
  5         138  
35 5     5   23 use warnings;
  5         9  
  5         119  
36              
37 5     5   376 use parent qw( Net::WebSocket::Handshake );
  5         232  
  5         33  
38              
39 5     5   263 use Call::Context ();
  5         10  
  5         78  
40              
41 5     5   23 use Net::WebSocket::Constants ();
  5         9  
  5         86  
42 5     5   25 use Net::WebSocket::X ();
  5         8  
  5         95  
43              
44             #no-op
45 5     5   32 use constant _handle_unrecognized_extension => ();
  5         7  
  5         2962  
46              
47             =head2 I->new( %OPTS )
48              
49             Returns an instance of this class. %OPTS is as described in the base class;
50             there are no options specific to this class.
51              
52             =head2 I->valid_protocol_or_die( PROTOCOL )
53              
54             Throws an exception if the given PROTOCOL isn’t the HTTP protocol (HTTP/1.1)
55             that WebSocket requires for all requests.
56              
57             You only need this if if you’re not using a request-parsing interface
58             that’s compatible with L; otherwise,
59             L’s C function
60             will do this (and other niceties) for you.
61              
62             =cut
63              
64             sub valid_protocol_or_die {
65 4     4 1 1024 my ($self, $protocol) = @_;
66              
67 4 100       14 if ($protocol ne Net::WebSocket::Constants::REQUIRED_REQUEST_PROTOCOL()) {
68 2         18 die Net::WebSocket::X->create('BadRequestProtocol', $protocol);
69             }
70              
71 2         6 return;
72             }
73              
74             =head2 I->valid_method_or_die( METHOD )
75              
76             Throws an exception if the given METHOD isn’t the HTTP method (GET) that
77             WebSocket requires for all requests.
78              
79             As with C, L might
80             call this method for you.
81              
82             =cut
83              
84             sub valid_method_or_die {
85 4     4 1 2410 my ($self, $method) = @_;
86              
87 4 100       13 if ($method ne Net::WebSocket::Constants::REQUIRED_HTTP_METHOD()) {
88 2         12 die Net::WebSocket::X->create('BadHTTPMethod', $method);
89             }
90              
91 2         5 return;
92             }
93              
94             sub _consume_peer_header {
95 24     24   48 my ($self, $name => $value) = @_;
96              
97 24         39 $name =~ tr; #case insensitive
98              
99 24 100       95 if ($name eq 'sec-websocket-version') {
    100          
    100          
100 5 100       15 if ( $value ne Net::WebSocket::Constants::PROTOCOL_VERSION() ) {
101 2         13 die Net::WebSocket::X->create('UnsupportedProtocolVersion', $value);
102             }
103              
104 3         8 $self->{'_version_ok'} = 1;
105             }
106             elsif ($name eq 'sec-websocket-key') {
107 5 100       25 if ($value !~ m<\A[A-Za-z0-9/\+]{22}==\z>) {
108 1         6 die Net::WebSocket::X->create('BadHeader', 'Sec-WebSocket-Key' => $value);
109             }
110              
111 4         10 $self->{'key'} = $value;
112             }
113             elsif ($name eq 'sec-websocket-protocol') {
114 1         9 require Net::WebSocket::HTTP;
115              
116 1         5 for my $token ( Net::WebSocket::HTTP::split_tokens($value) ) {
117 3 100       8 if (!defined $self->{'_subprotocol'}) {
118 2         4 ($self->{'_subprotocol'}) = grep { $_ eq $token } @{ $self->{'subprotocols'} };
  6         13  
  2         3  
119             }
120             }
121             }
122             else {
123 13         44 $self->_consume_generic_header($name => $value);
124             }
125              
126 19         66 return;
127             }
128              
129             #Send only those extensions that we’ve deduced the client can actually use.
130             sub _should_include_extension_in_headers {
131 0     0   0 my ($self, $xtn) = @_;
132              
133 0         0 return $xtn->ok_to_use();
134             }
135              
136             sub _encode_subprotocols {
137 2     2   5 my ($self) = @_;
138              
139 2 100       11 local $self->{'subprotocols'} = defined($self->{'_subprotocol'}) ? [ $self->{'_subprotocol'} ] : undef if $self->{'_no_use_legacy'};
    50          
140              
141 2         10 return $self->SUPER::_encode_subprotocols();
142             }
143              
144             sub _die_if_missing_headers {
145 4     4   7 my ($self) = @_;
146              
147 4         19 my @needed = $self->_missing_generic_headers();
148              
149 4 100       11 push @needed, 'Sec-WebSocket-Version' if !$self->{'_version_ok'};
150 4 100       25 push @needed, 'Sec-WebSocket-Key' if !$self->{'key'};
151              
152 4 100       12 if (@needed) {
153 1         5 die Net::WebSocket::X->create('MissingHeaders', @needed);
154             }
155              
156 3         6 return;
157             }
158              
159             sub _create_header_lines {
160 2     2   5 my ($self) = @_;
161              
162 2         6 Call::Context::must_be_list();
163              
164             return (
165 2         44 'HTTP/1.1 101 Switching Protocols',
166              
167             #For now let’s assume no one wants any other Upgrade:
168             #or Connection: values than the ones WebSocket requires.
169             'Upgrade: websocket',
170             'Connection: Upgrade',
171              
172             'Sec-WebSocket-Accept: ' . $self->get_accept(),
173              
174             $self->_encode_subprotocols(),
175              
176             $self->_encode_extensions(),
177             );
178             }
179              
180             #----------------------------------------------------------------------
181              
182             =head1 LEGACY INTERFACE: SYNOPSIS
183              
184             #...Parse the request’s headers yourself...
185              
186             my $hsk = Net::WebSocket::Handshake::Server->new(
187              
188             #base 64, gotten from request
189             key => '..',
190              
191             #optional - same as in non-legacy interface
192             subprotocols => [ 'echo', 'haha' ],
193              
194             #optional, instances of Net::WebSocket::Handshake::Extension
195             extensions => \@extension_objects,
196             );
197              
198             #Note the need to conclude the header text manually.
199             print $hsk->create_header_text() . "\x0d\x0a";
200              
201             =cut
202              
203             *get_accept = __PACKAGE__->can('_get_accept');
204              
205             1;