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