File Coverage

blib/lib/Net/WebSocket/Handshake/Server.pm
Criterion Covered Total %
statement 53 57 92.9
branch 15 22 68.1
condition n/a
subroutine 13 14 92.8
pod 1 1 100.0
total 82 94 87.2


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 3     3   1108 use strict;
  3         7  
  3         89  
35 3     3   16 use warnings;
  3         6  
  3         92  
36              
37 3     3   17 use parent qw( Net::WebSocket::Handshake );
  3         5  
  3         20  
38              
39 3     3   197 use Call::Context ();
  3         6  
  3         46  
40 3     3   15 use Digest::SHA ();
  3         5  
  3         48  
41              
42 3     3   12 use Net::WebSocket::Constants ();
  3         4  
  3         32  
43 3     3   12 use Net::WebSocket::X ();
  3         5  
  3         53  
44              
45             #no-op
46 3     3   11 use constant _handle_unrecognized_extension => ();
  3         5  
  3         1270  
47              
48             =head1 METHODS
49              
50             =head2 I->new( %OPTS )
51              
52             Returns an instance of this class. %OPTS is as described in the base class;
53             there are no options specific to this class.
54              
55             =head2 I->valid_method_or_die( METHOD )
56              
57             Throws an exception if the given METHOD isn’t the HTTP method (GET) that
58             WebSocket requires for all requests.
59              
60             You only need this if if you’re not using a request-parsing interface
61             that’s compatible with L; otherwise,
62             L’s C function
63             will do this (and other niceties) for you.
64              
65             =cut
66              
67             sub valid_method_or_die {
68 1     1 1 14 my ($self, $method) = @_;
69              
70 1 50       5 if ($method ne Net::WebSocket::Constants::REQUIRED_HTTP_METHOD()) {
71 0         0 die Net::WebSocket::X->new('BadHTTPMethod', $method);
72             }
73              
74 1         4 return;
75             }
76              
77             sub _consume_peer_header {
78 6     6   12 my ($self, $name => $value) = @_;
79              
80 6         10 $name =~ tr; #case insensitive
81              
82 6 100       18 if ($name eq 'sec-websocket-version') {
    100          
    100          
83 1 50       4 if ( $value ne Net::WebSocket::Constants::PROTOCOL_VERSION() ) {
84 0         0 die Net::WebSocket::X->new('BadHeader', 'Sec-WebSocket-Version', $value, 'Unsupported protocol version; must be ' . Net::WebSocket::Constants::PROTOCOL_VERSION());
85             }
86              
87 1         2 $self->{'_version_ok'} = 1;
88             }
89             elsif ($name eq 'sec-websocket-key') {
90 1         2 $self->{'key'} = $value;
91             }
92             elsif ($name eq 'sec-websocket-protocol') {
93 1         4 Module::Load::load('Net::WebSocket::HTTP');
94              
95 1         86 for my $token ( Net::WebSocket::HTTP::split_tokens($value) ) {
96 3 100       9 if (!defined $self->{'_subprotocol'}) {
97 2         4 ($self->{'_subprotocol'}) = grep { $_ eq $token } @{ $self->{'subprotocols'} };
  6         12  
  2         5  
98             }
99             }
100             }
101             else {
102 3         12 $self->_consume_generic_header($name => $value);
103             }
104              
105 6         20 return;
106             }
107              
108             #Send only those extensions that we’ve deduced the client can actually use.
109             sub _should_include_extension_in_headers {
110 0     0   0 my ($self, $xtn) = @_;
111              
112 0         0 return $xtn->ok_to_use();
113             }
114              
115             sub _encode_subprotocols {
116 1     1   3 my ($self) = @_;
117              
118 1 50       6 local $self->{'subprotocols'} = defined($self->{'_subprotocol'}) ? [ $self->{'_subprotocol'} ] : undef if $self->{'_no_use_legacy'};
    50          
119              
120 1         6 return $self->SUPER::_encode_subprotocols();
121             }
122              
123             sub _valid_headers_or_die {
124 1     1   4 my ($self) = @_;
125              
126 1         8 my @needed = $self->_missing_generic_headers();
127              
128 1 50       3 push @needed, 'Sec-WebSocket-Version' if !$self->{'_version_ok'};
129 1 50       21 push @needed, 'Sec-WebSocket-Key' if !$self->{'key'};
130              
131 1 50       5 die "Need: [@needed]" if @needed;
132              
133 1         2 return;
134             }
135              
136             sub _create_header_lines {
137 1     1   3 my ($self) = @_;
138              
139 1         4 Call::Context::must_be_list();
140              
141             return (
142 1         11 'HTTP/1.1 101 Switching Protocols',
143              
144             #For now let’s assume no one wants any other Upgrade:
145             #or Connection: values than the ones WebSocket requires.
146             'Upgrade: websocket',
147             'Connection: Upgrade',
148              
149             'Sec-WebSocket-Accept: ' . $self->get_accept(),
150              
151             $self->_encode_subprotocols(),
152              
153             $self->_encode_extensions(),
154             );
155             }
156              
157             #----------------------------------------------------------------------
158              
159             =head1 LEGACY INTERFACE: SYNOPSIS
160              
161             #...Parse the request’s headers yourself...
162              
163             my $hsk = Net::WebSocket::Handshake::Server->new(
164              
165             #base 64, gotten from request
166             key => '..',
167              
168             #optional - same as in non-legacy interface
169             subprotocols => [ 'echo', 'haha' ],
170              
171             #optional, instances of Net::WebSocket::Handshake::Extension
172             extensions => \@extension_objects,
173             );
174              
175             #Note the need to conclude the header text manually.
176             print $hsk->create_header_text() . "\x0d\x0a";
177              
178             =cut
179              
180             *get_accept = __PACKAGE__->can('_get_accept');
181              
182             1;