File Coverage

blib/lib/Mojo/WebSocket.pm
Criterion Covered Total %
statement 90 90 100.0
branch 54 60 90.0
condition 5 9 55.5
subroutine 14 14 100.0
pod 5 5 100.0
total 168 178 94.3


line stmt bran cond sub pod time code
1             package Mojo::WebSocket;
2 56     56   449 use Mojo::Base -strict;
  56         146  
  56         441  
3              
4 56     56   422 use Config;
  56         231  
  56         2961  
5 56     56   437 use Exporter qw(import);
  56         155  
  56         2607  
6 56     56   420 use Mojo::Util qw(b64_encode dumper sha1_bytes xor_encode);
  56         140  
  56         5027  
7              
8 56   50 56   453 use constant DEBUG => $ENV{MOJO_WEBSOCKET_DEBUG} || 0;
  56         141  
  56         4710  
9              
10             # Unique value from RFC 6455
11 56     56   492 use constant GUID => '258EAFA5-E914-47DA-95CA-C5AB0DC85B11';
  56         172  
  56         5227  
12              
13             # Perl with support for quads
14 56   33 56   476 use constant MODERN => (($Config{use64bitint} // '') eq 'define' || $Config{longsize} >= 8);
  56         163  
  56         10082  
15              
16             # Opcodes
17 56         81500 use constant {WS_CONTINUATION => 0x0, WS_TEXT => 0x1, WS_BINARY => 0x2, WS_CLOSE => 0x8, WS_PING => 0x9,
18 56     56   517 WS_PONG => 0xa};
  56         182  
19              
20             our @EXPORT_OK = (
21             qw(WS_BINARY WS_CLOSE WS_CONTINUATION WS_PING WS_PONG WS_TEXT build_frame challenge client_handshake parse_frame),
22             qw(server_handshake)
23             );
24              
25             sub build_frame {
26 354     354 1 60142 my ($masked, $fin, $rsv1, $rsv2, $rsv3, $op, $payload) = @_;
27 354         523 warn "-- Building frame ($fin, $rsv1, $rsv2, $rsv3, $op)\n" if DEBUG;
28              
29             # Head
30 354 100       845 my $head = $op + ($fin ? 128 : 0);
31 354 100       731 $head |= 0b01000000 if $rsv1;
32 354 100       727 $head |= 0b00100000 if $rsv2;
33 354 100       675 $head |= 0b00010000 if $rsv3;
34 354         1106 my $frame = pack 'C', $head;
35              
36             # Small payload
37 354         576 my $len = length $payload;
38 354 100       748 if ($len < 126) {
    100          
39 336         889 warn "-- Small payload ($len)\n@{[dumper $payload]}" if DEBUG;
40 336 100       1008 $frame .= pack 'C', $masked ? ($len | 128) : $len;
41             }
42              
43             # Extended payload (16-bit)
44             elsif ($len < 65536) {
45 11         23 warn "-- Extended 16-bit payload ($len)\n@{[dumper $payload]}" if DEBUG;
46 11 100       67 $frame .= pack 'Cn', $masked ? (126 | 128) : 126, $len;
47             }
48              
49             # Extended payload (64-bit with 32-bit fallback)
50             else {
51 7         12 warn "-- Extended 64-bit payload ($len)\n@{[dumper $payload]}" if DEBUG;
52 7 100       39 $frame .= pack 'C', $masked ? (127 | 128) : 127;
53 7         27 $frame .= MODERN ? pack('Q>', $len) : pack('NN', 0, $len & 0xffffffff);
54             }
55              
56             # Mask payload
57 354 100       751 if ($masked) {
58 168         648 my $mask = pack 'N', int(rand 9 x 7);
59 168         748 $payload = $mask . xor_encode($payload, $mask x 128);
60             }
61              
62 354         2995 return $frame . $payload;
63             }
64              
65             sub challenge {
66 63     63 1 130 my $tx = shift;
67              
68             # "permessage-deflate" extension
69 63         199 my $headers = $tx->res->headers;
70 63 100 100     290 $tx->compressed(1) if ($headers->sec_websocket_extensions // '') =~ /permessage-deflate/;
71              
72 63         237 return _challenge($tx->req->headers->sec_websocket_key) eq $headers->sec_websocket_accept;
73             }
74              
75             sub client_handshake {
76 80     80 1 150 my $tx = shift;
77              
78 80         212 my $headers = $tx->req->headers;
79 80 50       286 $headers->upgrade('websocket') unless $headers->upgrade;
80 80 50       245 $headers->connection('Upgrade') unless $headers->connection;
81 80 50       330 $headers->sec_websocket_version(13) unless $headers->sec_websocket_version;
82              
83             # Generate 16 byte WebSocket challenge
84 80         790 my $challenge = b64_encode sprintf('%16u', int(rand 9 x 16)), '';
85 80 100       300 $headers->sec_websocket_key($challenge) unless $headers->sec_websocket_key;
86              
87 80         475 return $tx;
88             }
89              
90             sub parse_frame {
91 564     564 1 11595 my ($buffer, $max) = @_;
92              
93             # Head
94 564 100       1986 return undef unless length $$buffer >= 2;
95 275         1069 my ($first, $second) = unpack 'C2', $$buffer;
96              
97             # FIN
98 275 100       767 my $fin = ($first & 0b10000000) == 0b10000000 ? 1 : 0;
99              
100             # RSV1-3
101 275 100       652 my $rsv1 = ($first & 0b01000000) == 0b01000000 ? 1 : 0;
102 275 100       524 my $rsv2 = ($first & 0b00100000) == 0b00100000 ? 1 : 0;
103 275 100       869 my $rsv3 = ($first & 0b00010000) == 0b00010000 ? 1 : 0;
104              
105             # Opcode
106 275         410 my $op = $first & 0b00001111;
107 275         367 warn "-- Parsing frame ($fin, $rsv1, $rsv2, $rsv3, $op)\n" if DEBUG;
108              
109             # Small payload
110 275         513 my ($hlen, $len) = (2, $second & 0b01111111);
111 275 100       608 if ($len < 126) { warn "-- Small payload ($len)\n" if DEBUG }
  259 100       382  
    50          
112              
113             # Extended payload (16-bit)
114             elsif ($len == 126) {
115 10 50       46 return undef unless length $$buffer > 4;
116 10         19 $hlen = 4;
117 10         32 $len = unpack 'x2n', $$buffer;
118 10         50 warn "-- Extended 16-bit payload ($len)\n" if DEBUG;
119             }
120              
121             # Extended payload (64-bit with 32-bit fallback)
122             elsif ($len == 127) {
123 6 50       36 return undef unless length $$buffer > 10;
124 6         9 $hlen = 10;
125 6         22 $len = MODERN ? unpack('x2Q>', $$buffer) : unpack('x2x4N', $$buffer);
126 6         13 warn "-- Extended 64-bit payload ($len)\n" if DEBUG;
127             }
128              
129             # Check message size
130 275 100       599 return 1 if $len > $max;
131              
132             # Check if whole packet has arrived
133 272 100       591 $len += 4 if my $masked = $second & 0b10000000;
134 272 100       615 return undef if length $$buffer < ($hlen + $len);
135 271         652 substr $$buffer, 0, $hlen, '';
136              
137             # Payload
138 271 100       1058 my $payload = $len ? substr($$buffer, 0, $len, '') : '';
139 271 100       1008 $payload = xor_encode($payload, substr($payload, 0, 4, '') x 128) if $masked;
140 271         474 warn dumper $payload if DEBUG;
141              
142 271         1294 return [$fin, $rsv1, $rsv2, $rsv3, $op, $payload];
143             }
144              
145             sub server_handshake {
146 73     73 1 158 my $tx = shift;
147              
148 73         270 my $headers = $tx->res->headers;
149 73         258 $headers->upgrade('websocket')->connection('Upgrade');
150 73         264 $headers->sec_websocket_accept(_challenge($tx->req->headers->sec_websocket_key));
151              
152 73         278 return $tx;
153             }
154              
155 136   50 136   1801 sub _challenge { b64_encode(sha1_bytes(($_[0] || '') . GUID), '') }
156              
157             1;
158              
159             =encoding utf8
160              
161             =head1 NAME
162              
163             Mojo::WebSocket - The WebSocket protocol
164              
165             =head1 SYNOPSIS
166              
167             use Mojo::WebSocket qw(WS_TEXT build_frame parse_frame);
168              
169             my $bytes = build_frame 0, 1, 0, 0, 0, WS_TEXT, 'Hello World!';
170             my $frame = parse_frame \$bytes, 262144;
171              
172             =head1 DESCRIPTION
173              
174             L implements the WebSocket protocol as described in L.
175             Note that 64-bit frames require a Perl with support for quads or they are limited to 32-bit.
176              
177             =head1 FUNCTIONS
178              
179             L implements the following functions, which can be imported individually.
180              
181             =head2 build_frame
182              
183             my $bytes = build_frame $masked, $fin, $rsv1, $rsv2, $rsv3, $op, $payload;
184              
185             Build WebSocket frame.
186              
187             # Masked binary frame with FIN bit and payload
188             say build_frame 1, 1, 0, 0, 0, WS_BINARY, 'Hello World!';
189              
190             # Text frame with payload but without FIN bit
191             say build_frame 0, 0, 0, 0, 0, WS_TEXT, 'Hello ';
192              
193             # Continuation frame with FIN bit and payload
194             say build_frame 0, 1, 0, 0, 0, WS_CONTINUATION, 'World!';
195              
196             # Close frame with FIN bit and without payload
197             say build_frame 0, 1, 0, 0, 0, WS_CLOSE, '';
198              
199             # Ping frame with FIN bit and payload
200             say build_frame 0, 1, 0, 0, 0, WS_PING, 'Test 123';
201              
202             # Pong frame with FIN bit and payload
203             say build_frame 0, 1, 0, 0, 0, WS_PONG, 'Test 123';
204              
205             =head2 challenge
206              
207             my $bool = challenge Mojo::Transaction::WebSocket->new;
208              
209             Check WebSocket handshake challenge.
210              
211             =head2 client_handshake
212              
213             my $tx = client_handshake Mojo::Transaction::HTTP->new;
214              
215             Perform WebSocket handshake client-side.
216              
217             =head2 parse_frame
218              
219             my $frame = parse_frame \$bytes, $limit;
220              
221             Parse WebSocket frame.
222              
223             # Parse single frame and remove it from buffer
224             my $frame = parse_frame \$buffer, 262144;
225             say "FIN: $frame->[0]";
226             say "RSV1: $frame->[1]";
227             say "RSV2: $frame->[2]";
228             say "RSV3: $frame->[3]";
229             say "Opcode: $frame->[4]";
230             say "Payload: $frame->[5]";
231              
232             =head2 server_handshake
233              
234             my $tx = server_handshake Mojo::Transaction::HTTP->new;
235              
236             Perform WebSocket handshake server-side.
237              
238             =head1 CONSTANTS
239              
240             L implements the following constants, which can be imported individually.
241              
242             =head2 WS_BINARY
243              
244             Opcode for C frames.
245              
246             =head2 WS_CLOSE
247              
248             Opcode for C frames.
249              
250             =head2 WS_CONTINUATION
251              
252             Opcode for C frames.
253              
254             =head2 WS_PING
255              
256             Opcode for C frames.
257              
258             =head2 WS_PONG
259              
260             Opcode for C frames.
261              
262             =head2 WS_TEXT
263              
264             Opcode for C frames.
265              
266             =head1 DEBUGGING
267              
268             You can set the C environment variable to get some advanced diagnostics information printed to
269             C.
270              
271             MOJO_WEBSOCKET_DEBUG=1
272              
273             =head1 SEE ALSO
274              
275             L, L, L.
276              
277             =cut