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
|
|
|
|
|
|
|
#required, base 64 |
14
|
|
|
|
|
|
|
key => '..', |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
#optional |
17
|
|
|
|
|
|
|
subprotocols => [ 'echo', 'haha' ], |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
#optional, instances of Net::WebSocket::Handshake::Extension |
20
|
|
|
|
|
|
|
extensions => \@extension_objects, |
21
|
|
|
|
|
|
|
); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
#Note the need to conclude the header text manually. |
24
|
|
|
|
|
|
|
#This is by design, so you can add additional headers. |
25
|
|
|
|
|
|
|
my $resp_hdr = $hsk->create_header_text() . "\x0d\x0a"; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $b64 = $hsk->get_accept(); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 DESCRIPTION |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
This class implements WebSocket handshake logic for a server. |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
Because Net::WebSocket tries to be agnostic about how you parse your HTTP |
34
|
|
|
|
|
|
|
headers, this class doesn’t do a whole lot for you: it’ll give you the |
35
|
|
|
|
|
|
|
C header value given a base64 |
36
|
|
|
|
|
|
|
C (i.e., from the client), and it’ll give you |
37
|
|
|
|
|
|
|
a “basic” response header text. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
B C does NOT provide the extra trailing |
40
|
|
|
|
|
|
|
CRLF to conclude the HTTP headers. This allows you to add additional |
41
|
|
|
|
|
|
|
headers beyond what this class gives you. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=cut |
44
|
|
|
|
|
|
|
|
45
|
2
|
|
|
2
|
|
1137
|
use strict; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
73
|
|
46
|
2
|
|
|
2
|
|
15
|
use warnings; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
78
|
|
47
|
|
|
|
|
|
|
|
48
|
2
|
|
|
2
|
|
16
|
use parent qw( Net::WebSocket::Handshake::Base ); |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
14
|
|
49
|
|
|
|
|
|
|
|
50
|
2
|
|
|
2
|
|
1282
|
use Call::Context (); |
|
2
|
|
|
|
|
646
|
|
|
2
|
|
|
|
|
54
|
|
51
|
2
|
|
|
2
|
|
16
|
use Digest::SHA (); |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
47
|
|
52
|
|
|
|
|
|
|
|
53
|
2
|
|
|
2
|
|
14
|
use Net::WebSocket::X (); |
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
374
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub new { |
56
|
1
|
|
|
1
|
0
|
953
|
my ($class, %opts) = @_; |
57
|
|
|
|
|
|
|
|
58
|
1
|
50
|
|
|
|
4
|
if (!$opts{'key'}) { |
59
|
0
|
|
|
|
|
0
|
die Net::WebSocket::X->create('BadArg', key => $opts{'key'}); |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
1
|
|
|
|
|
9
|
return bless \%opts, $class; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
*get_accept = __PACKAGE__->can('_get_accept'); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub _create_header_lines { |
68
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
69
|
|
|
|
|
|
|
|
70
|
0
|
|
|
|
|
|
Call::Context::must_be_list(); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
return ( |
73
|
0
|
|
|
|
|
|
'HTTP/1.1 101 Switching Protocols', |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
#For now let’s assume no one wants any other Upgrade: |
76
|
|
|
|
|
|
|
#or Connection: values than the ones WebSocket requires. |
77
|
|
|
|
|
|
|
'Upgrade: websocket', |
78
|
|
|
|
|
|
|
'Connection: Upgrade', |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
'Sec-WebSocket-Accept: ' . $self->get_accept(), |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
$self->_encode_extensions(), |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
$self->_encode_subprotocols(), |
85
|
|
|
|
|
|
|
); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
1; |