File Coverage

blib/lib/Net/WebSocket/Handshake/Server.pm
Criterion Covered Total %
statement 52 56 92.8
branch 15 22 68.1
condition n/a
subroutine 13 14 92.8
pod 1 1 100.0
total 81 93 87.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 3     3   1006 use strict;
  3         7  
  3         77  
35 3     3   14 use warnings;
  3         6  
  3         91  
36              
37 3     3   18 use parent qw( Net::WebSocket::Handshake );
  3         7  
  3         24  
38              
39 3     3   169 use Call::Context ();
  3         5  
  3         44  
40 3     3   11 use Digest::SHA ();
  3         5  
  3         38  
41              
42 3     3   14 use Net::WebSocket::Constants ();
  3         14  
  3         47  
43 3     3   16 use Net::WebSocket::X ();
  3         6  
  3         64  
44              
45             #no-op
46 3     3   14 use constant _handle_unrecognized_extension => ();
  3         6  
  3         1539  
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 17 my ($self, $method) = @_;
69              
70 1 50       6 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   15 my ($self, $name => $value) = @_;
79              
80 6 100       24 if ($name eq 'Sec-WebSocket-Version') {
    100          
    100          
81 1 50       5 if ( $value ne Net::WebSocket::Constants::PROTOCOL_VERSION() ) {
82 0         0 die Net::WebSocket::X->new('BadHeader', 'Sec-WebSocket-Version', $value, 'Unsupported protocol version; must be ' . Net::WebSocket::Constants::PROTOCOL_VERSION());
83             }
84              
85 1         3 $self->{'_version_ok'} = 1;
86             }
87             elsif ($name eq 'Sec-WebSocket-Key') {
88 1         4 $self->{'key'} = $value;
89             }
90             elsif ($name eq 'Sec-WebSocket-Protocol') {
91 1         5 Module::Load::load('Net::WebSocket::HTTP');
92              
93 1         91 for my $token ( Net::WebSocket::HTTP::split_tokens($value) ) {
94 3 100       13 if (!defined $self->{'_subprotocol'}) {
95 2         5 ($self->{'_subprotocol'}) = grep { $_ eq $token } @{ $self->{'subprotocols'} };
  6         19  
  2         5  
96             }
97             }
98             }
99             else {
100 3         13 $self->_consume_generic_header($name => $value);
101             }
102              
103 6         28 return;
104             }
105              
106             #Send only those extensions that we’ve deduced the client can actually use.
107             sub _should_include_extension_in_headers {
108 0     0   0 my ($self, $xtn) = @_;
109              
110 0         0 return $xtn->ok_to_use();
111             }
112              
113             sub _encode_subprotocols {
114 1     1   4 my ($self) = @_;
115              
116 1 50       8 local $self->{'subprotocols'} = defined($self->{'_subprotocol'}) ? [ $self->{'_subprotocol'} ] : undef if $self->{'_no_use_legacy'};
    50          
117              
118 1         7 return $self->SUPER::_encode_subprotocols();
119             }
120              
121             sub _valid_headers_or_die {
122 1     1   3 my ($self) = @_;
123              
124 1         9 my @needed = $self->_missing_generic_headers();
125              
126 1 50       4 push @needed, 'Sec-WebSocket-Version' if !$self->{'_version_ok'};
127 1 50       6 push @needed, 'Sec-WebSocket-Key' if !$self->{'key'};
128              
129 1 50       5 die "Need: [@needed]" if @needed;
130              
131 1         3 return;
132             }
133              
134             sub _create_header_lines {
135 1     1   3 my ($self) = @_;
136              
137 1         5 Call::Context::must_be_list();
138              
139             return (
140 1         13 'HTTP/1.1 101 Switching Protocols',
141              
142             #For now let’s assume no one wants any other Upgrade:
143             #or Connection: values than the ones WebSocket requires.
144             'Upgrade: websocket',
145             'Connection: Upgrade',
146              
147             'Sec-WebSocket-Accept: ' . $self->get_accept(),
148              
149             $self->_encode_subprotocols(),
150              
151             $self->_encode_extensions(),
152             );
153             }
154              
155             #----------------------------------------------------------------------
156              
157             =head1 LEGACY INTERFACE: SYNOPSIS
158              
159             #...Parse the request’s headers yourself...
160              
161             my $hsk = Net::WebSocket::Handshake::Server->new(
162              
163             #base 64, gotten from request
164             key => '..',
165              
166             #optional - same as in non-legacy interface
167             subprotocols => [ 'echo', 'haha' ],
168              
169             #optional, instances of Net::WebSocket::Handshake::Extension
170             extensions => \@extension_objects,
171             );
172              
173             #Note the need to conclude the header text manually.
174             print $hsk->create_header_text() . "\x0d\x0a";
175              
176             =cut
177              
178             *get_accept = __PACKAGE__->can('_get_accept');
179              
180             1;