File Coverage

blib/lib/Net/WebSocket/Handshake/Client.pm
Criterion Covered Total %
statement 40 47 85.1
branch 7 16 43.7
condition 2 6 33.3
subroutine 10 11 90.9
pod 0 3 0.0
total 59 83 71.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
17             subprotocols => [ 'echo', 'haha' ],
18              
19             #optional, to imitate a web client
20             origin => ..,
21              
22             #optional, base 64 .. auto-created if not given
23             key => '..',
24              
25             #optional, instances of Net::WebSocket::Handshake::Extension
26             extensions => \@extension_objects,
27             );
28              
29             #Note the need to conclude the header text manually.
30             #This is by design, so you can add additional headers.
31             my $hdr = $hsk->create_header_text() . "\x0d\x0a";
32              
33             my $b64 = $hsk->get_key();
34              
35             #Validates the value of the “Sec-WebSocket-Accept” header;
36             #throws Net::WebSocket::X::BadAccept if not.
37             $hsk->validate_accept_or_die($accent_value);
38              
39             =head1 DESCRIPTION
40              
41             This class implements WebSocket handshake logic for a client.
42              
43             Because Net::WebSocket tries to be agnostic about how you parse your HTTP
44             headers, this class doesn’t do a whole lot for you: it’ll create a base64
45             key for you and create “starter” headers for you. It also can validate
46             the C header value from the server.
47              
48             B C does NOT provide the extra trailing
49             CRLF to conclude the HTTP headers. This allows you to add additional
50             headers beyond what this class gives you.
51              
52             =cut
53              
54 2     2   150937 use strict;
  2         5  
  2         62  
55 2     2   13 use warnings;
  2         4  
  2         85  
56              
57 2     2   485 use parent qw( Net::WebSocket::Handshake::Base );
  2         418  
  2         11  
58              
59 2     2   527 use URI::Split ();
  2         2554  
  2         50  
60              
61 2     2   498 use Net::WebSocket::Constants ();
  2         4  
  2         32  
62 2     2   441 use Net::WebSocket::X ();
  2         6  
  2         1068  
63              
64             sub new {
65 2     2 0 17 my ($class, %opts) = @_;
66              
67 2 50       8 if (length $opts{'uri'}) {
68 2         10 @opts{ 'uri_schema', 'uri_auth', 'uri_path', 'uri_query' } = URI::Split::uri_split($opts{'uri'});
69             }
70              
71 2 50 33     47 if (!$opts{'uri_schema'} || ($opts{'uri_schema'} !~ m<\A(?:ws|http)s?\z>)) {
72 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
73             }
74              
75 2 50       11 if (!$opts{'uri_auth'}) {
76 0         0 die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
77             }
78              
79 2         11 @opts{ 'uri_host', 'uri_port' } = split m<:>, $opts{'uri_auth'};
80              
81 2   33     16 $opts{'key'} ||= _create_key();
82              
83 2         7 return bless \%opts, $class;
84             }
85              
86             sub _create_header_lines {
87 1     1   4 my ($self) = @_;
88              
89 1         4 my $path = $self->{'uri_path'};
90              
91 1 50       3 if (!length $path) {
92 1         2 $path = '/';
93             }
94              
95 1 50       3 if (length $self->{'uri_query'}) {
96 0         0 $path .= "?$self->{'uri_query'}";
97             }
98              
99             return (
100             "GET $path HTTP/1.1",
101             "Host: $self->{'uri_host'}",
102              
103             #For now let’s assume no one wants any other Upgrade:
104             #or Connection: values than the ones WebSocket requires.
105             'Upgrade: websocket',
106             'Connection: Upgrade',
107              
108             "Sec-WebSocket-Key: $self->{'key'}",
109             'Sec-WebSocket-Version: ' . Net::WebSocket::Constants::PROTOCOL_VERSION(),
110              
111             $self->_encode_extensions(),
112              
113             $self->_encode_subprotocols(),
114              
115 1 50       9 ( $self->{'origin'} ? "Origin: $self->{'origin'}" : () ),
116             );
117             }
118              
119             sub validate_accept_or_die {
120 0     0 0 0 my ($self, $received) = @_;
121              
122 0         0 my $should_be = $self->_get_accept();
123              
124 0 0       0 return if $received eq $should_be;
125              
126 0         0 die Net::WebSocket::X->create('BadAccept', $should_be, $received );
127             }
128              
129             sub get_key {
130 1     1 0 6 my ($self) = @_;
131              
132 1         11 return $self->{'key'};
133             }
134              
135             sub _create_key {
136 2 50   2   28 Module::Load::load('MIME::Base64') if !MIME::Base64->can('encode');
137              
138 2         8 my $sixteen_bytes = pack 'S8', map { rand 65536 } 1 .. 8;
  16         77  
139              
140 2         10 my $b64 = MIME::Base64::encode_base64($sixteen_bytes);
141 2         6 chomp $b64;
142              
143 2         8 return $b64;
144             }
145              
146             1;