File Coverage

blib/lib/Net/Inspect/L7/HTTP/WebSocket.pm
Criterion Covered Total %
statement 147 203 72.4
branch 88 142 61.9
condition 24 55 43.6
subroutine 10 10 100.0
pod 0 1 0.0
total 269 411 65.4


line stmt bran cond sub pod time code
1             ############################################################################
2             # WebSocket support
3             ############################################################################
4              
5 1     1   27408 use strict;
  1         4  
  1         81  
6 1     1   10 use warnings;
  1         3  
  1         63  
7             package Net::Inspect::L7::HTTP::WebSocket;
8 1     1   9 use Scalar::Util 'weaken';
  1         4  
  1         83  
9 1     1   9 use Carp 'croak';
  1         3  
  1         66  
10 1     1   694 use Digest::SHA 'sha1_base64';
  1         4943  
  1         2306  
11              
12             sub upgrade_websocket {
13 1     1 0 3 my ($self,$conn,$req,$rsp) = @_;
14              
15             # Websocket: RFC6455, Sec.4.1 Page 16ff
16 1   50     12 my $wskey = $req->{fields}{'sec-websocket-key'} || [];
17 1 50       5 if (@$wskey > 1) {
18 0         0 my %x;
19 0 0       0 $wskey = [ map { $x{$_}++ ? ():($_) } @$wskey ];
  0         0  
20             }
21              
22             # Check request
23 1 50       4 die "no sec-websocket-key given in request" if ! @$wskey;
24 1 50       3 die "multiple sec-websocket-key given in request" if @$wskey > 1;
25             die "method must be GET but is $req->{method}"
26 1 50       4 if $req->{method} ne 'GET';
27 1         2 my $v = $req->{fields}{'sec-websocket-version'};
28 1 50       4 die "no sec-websocket-version field in request" if !$v;
29             die "sec-websocket-version must be 13 not '@$v'"
30 1 50       3 if grep { $_ ne '13' } @$v;
  1         5  
31              
32             # Check response
33 1         2 my $wsa = $rsp->{fields}{'sec-websocket-accept'};
34 1 50       8 if (@$wsa > 1) {
35 0         0 my %x;
36 0 0       0 $wsa = [ map { $x{$_}++ ? ():($_) } @$wsa ];
  0         0  
37             }
38 1 50       4 die "no sec-websocket-accept given in response" if ! @$wsa;
39 1 50       4 die "multiple sec-websocket-accept given in response" if @$wsa > 1;
40              
41             # Check that sec-websocket-accept in response matches sec-websocket-key.
42             # Beware its magic! see RFC6455 page 7.
43             # sha1_base64 does no padding, so we need to add a single '=' (pad to 4*7
44             # byte) at the end for comparison.
45 1 50 33     22 if ( @$wsa != 1 or $wsa->[0] ne sha1_base64(
46             $wskey->[0].'258EAFA5-E914-47DA-95CA-C5AB0DC85B11').'=') {
47 0         0 die "sec-websocket-accept does not match sec-websocket-key";
48             }
49              
50              
51 1         2 my @sub;
52 1         6 weaken($self);
53 1         3 for my $dir (0,1) {
54 2         4 my $dir = $dir; # old $dir is only alias
55 2         4 my $rbuf = '';
56              
57             # If $clen is defined we are inside a frame ($current_frame).
58             # If $clen is not defined all other variables here do not matter.
59             # Since control messages might be in-between fragmented data messages we
60             # need to keep this information for an open data message.
61 2         3 my ($clen,$clenhi,$current_frame,$data_frame,$ctl_frame,$got_close);
62              
63             $sub[$dir] = sub {
64 18     18   38 my ($data,$eof,$time) = @_;
65 18         30 my $err;
66              
67             # Handle data gaps. These are only allowed inside data frames.
68             ############################################################
69 18 100       40 if (ref($data)) {
70 5 50       26 croak "unknown type $data->[0]" if $data->[0] ne 'gap';
71 5         9 my $gap = $data->[1];
72 5 50       13 if (!defined $clen) {
73 0         0 $err = "gap outside websocket frame";
74 0         0 goto bad;
75             }
76 5 50 33     23 if (!$data_frame || $current_frame != $data_frame) {
77 0         0 $err = "gap inside control frame";
78 0         0 goto bad;
79             }
80 5         7 my $eom = 0; # end of message on end-of-frame + FIN frame
81 5         13 while ($gap>0) {
82 5 50       15 if ($clen == 0) {
    50          
83 0 0       0 if (!$clenhi) {
84 0         0 $err = "gap larger than frame size";
85 0         0 goto bad;
86             }
87 0         0 $clenhi--;
88 0         0 $clen = 0xffffffff;
89 0         0 $gap--;
90             $current_frame->{mask_offset}
91 0   0     0 = (($current_frame->{mask_offset}||0) + 1) % 4;
92              
93             } elsif ($gap > $clen) {
94 0         0 $gap -= $clen;
95             $current_frame->{mask_offset}
96 0   0     0 = (($current_frame->{mask_offset}||0) + $clen) % 4;
97 0         0 $clen = 0;
98             } else { # $gap <= $clen
99 5         7 $clen -= $gap;
100             $current_frame->{mask_offset}
101 5   100     19 = (($current_frame->{mask_offset}||0) + $gap) % 4;
102 5         12 $gap = 0;
103             }
104             }
105 5 0 33     12 if (!$clen && !$clenhi) {
106             # frame done
107 0 0       0 $eom = $data_frame->{fin} ? 1:0;
108 0         0 $clen = undef;
109             }
110              
111 5 50       11 if (defined $clen) {
112 5         11 $data_frame->{bytes_left} = [$clenhi,$clen];
113             } else {
114 0         0 delete $data_frame->{bytes_left};
115             }
116 5         17 $self->in_wsdata($dir,$data,$eom,$time,$data_frame);
117 5 50       48 if ($eom) {
118 0         0 $data_frame = $current_frame = undef;
119 0         0 $conn->set_gap_diff($dir,undef);
120             } else {
121 5         8 delete $data_frame->{init};
122 5         8 delete $data_frame->{header};
123             }
124 5         11 return;
125             }
126              
127 13         24 $rbuf .= $data;
128              
129             PARSE_DATA:
130              
131             # data for existing frame
132             ############################################################
133 21 100       47 if (defined $clen) {
134 10         17 my $size = length($rbuf);
135 10 50 33     27 if (!$size and $clen || $clenhi and $eof) {
      66        
      33        
136 0         0 $err = "eof inside websocket frame";
137 0         0 goto bad;
138             }
139 10         17 my $fwd = '';
140 10         16 my $eom = 0;
141 10         27 while ($size>0) {
142 9 50       23 if ($clen == 0) {
    50          
143 0 0       0 last if !$clenhi;
144 0         0 $clenhi--;
145 0         0 $clen = 0xffffffff;
146 0         0 $size--;
147 0         0 $fwd .= substr($rbuf,0,1,'');
148             } elsif ($size > $clen) {
149 0         0 $size -= $clen;
150 0         0 $fwd .= substr($rbuf,0,$clen,'');
151 0         0 $clen = 0;
152             } else { # $size < $clen
153 9         16 $clen -= $size;
154 9         12 $size = 0;
155 9         23 $fwd .= $rbuf;
156 9         23 $rbuf = '';
157             }
158             }
159 10 50 66     35 if (!$clen && !$clenhi) {
160             # frame done
161 8 100       19 $eom = $current_frame->{fin} ? 1:0;
162 8         11 $clen = undef;
163             }
164 10 100 100     41 if ($data_frame && $current_frame == $data_frame) {
165 6 100       13 if (defined $clen) {
166 2         16 $data_frame->{bytes_left} = [$clenhi,$clen];
167             } else {
168 4         9 delete $data_frame->{bytes_left};
169             }
170 6         26 $self->in_wsdata($dir,$fwd,$eom,$time,$data_frame);
171 6 100       51 if ($eom) {
172 2         2 $data_frame = undef;
173             } else {
174 4         7 delete $data_frame->{init};
175 4         7 delete $data_frame->{header};
176             $current_frame->{mask_offset}
177 4 100 50     16 = (($current_frame->{mask_offset}||0) + length($fwd)) % 4
178             if defined $clen;
179             }
180             } else {
181             # Control frames are read in full and we make sure about
182             # this when reading the header already.
183 4 50       9 die "expected to read full control frame" if defined $clen;
184              
185 4 100       12 if ($current_frame->{opcode} == 0x8) {
186             # extract status + reason for close
187 2 50       8 if ($fwd eq '') {
    50          
188 0         0 $current_frame->{status} = 1005; # RFC6455, 7.1.5
189             } elsif (length($fwd) < 2) {
190             # if payload it must be at least 2 byte for status
191 0         0 $err = "invalid length for close control frame";
192 0         0 goto bad;
193             } else {
194             ($current_frame->{status},$current_frame->{reason})
195 2         5 = unpack("na*",$current_frame->unmask($fwd));
196             }
197             }
198 4         13 $self->in_wsctl($dir,$fwd,$time,$current_frame);
199             }
200 10 50       140 goto done if !$size;
201 0         0 goto PARSE_DATA;
202             }
203              
204             # start of new frame: read frame header
205             ############################################################
206 11 100       27 goto done if $eof;
207 9 50       24 goto hdr_need_more if length($rbuf)<2;
208              
209 9         30 (my $flags,$clen) = unpack("CC",$rbuf);
210 9         18 my $mask = $clen & 0x80;
211 9         13 $clen &= 0x7f;
212 9         14 $clenhi = 0;
213 9         12 my $off = 2;
214              
215 9 100       27 if ($clen == 126) {
    100          
216 1 50       4 goto hdr_need_more if length($rbuf)<4;
217 1         8 ($clen) = unpack("xxn",$rbuf);
218 1 50       5 goto bad_length if $clen<126;
219 1         2 $off = 4;
220             } elsif ($clen == 127) {
221 2 50       6 goto hdr_need_more if length($rbuf)<10;
222 2         6 ($clenhi,$clen) = unpack("xxNN",$rbuf);
223 2 50 33     11 goto bad_length if !$clenhi && $clen<2**16;
224 2         5 $off = 10;
225             }
226 9 100       19 if ($mask) {
227 7 100       20 goto hdr_need_more if length($rbuf)<$off+4;
228 6         20 ($mask) = unpack("x${off}a4",$rbuf);
229 6         10 $off+=4;
230             } else {
231 2         3 $mask = undef;
232             }
233              
234 8         16 my $opcode = $flags & 0b00001111;
235 8         14 my $fin = $flags & 0b10000000;
236 8 50       22 goto reserved_flag if $flags & 0b01110000;
237              
238 8 100       22 if ($opcode >= 0x8) {
    100          
239             # control frame
240 4 50       10 goto reserved_opcode if $opcode >= 0xb;
241 4 50       13 if (!$fin) {
242 0         0 $err = "fragmented control frames are forbidden";
243 0         0 goto bad;
244             }
245 4 50 33     20 if ($clenhi || $clen>125) {
246 0         0 $err = "control frames should be <= 125 bytes";
247 0         0 goto bad;
248             }
249             # We like to forward control frames as a single entity, so make
250             # sure we get the whole (small) frame at once.
251 4 50       12 goto hdr_need_more if $off+$clen > length($rbuf);
252              
253 4   66     13 $current_frame = $ctl_frame
254             ||= Net::Inspect::L7::HTTP::WebSocket::_WSFrame->new;
255 4 100       28 %$current_frame = (
256             opcode => $opcode,
257             defined($mask) ? ( mask => $mask ):()
258             );
259 4 100       12 $got_close = 1 if $opcode == 0x8;
260              
261             } elsif ($opcode>0) {
262             # data frame, but no continuation
263 2 50       7 goto reserved_opcode if $opcode >= 0x3;
264 2 50       6 if ($got_close) {
265 0         0 $err = "data frame after close";
266 0         0 goto bad;
267             }
268 2 50       6 if ($data_frame) {
269 0         0 $err = "new data message before end of previous message";
270 0         0 goto bad;
271             }
272 2         10 $current_frame = $data_frame
273             = Net::Inspect::L7::HTTP::WebSocket::_WSFrame->new;
274 2 100       15 %$current_frame = (
    100          
275             opcode => $opcode,
276             $fin ? ( fin => 1 ):(),
277             init => 1, # initial data
278             defined($mask) ? ( mask => $mask ):()
279             );
280              
281             } else {
282             # continuation frame
283 2 50       8 if (!$data_frame) {
284 0         0 $err = "continuation frame without previous data frame";
285 0         0 goto bad;
286             }
287 2         4 $current_frame = $data_frame;
288             %$current_frame = (
289             opcode => $data_frame->{opcode},
290 2 100       14 $fin ? ( fin => 1 ):(),
    50          
291             defined($mask) ? ( mask => $mask ):()
292             );
293             }
294              
295             # done with frame header
296 8         24 $current_frame->{header} = substr($rbuf,0,$off,'');
297 8         18 goto PARSE_DATA;
298              
299             # Done
300             ############################################################
301              
302 1         2 hdr_need_more:
303             $clen = undef; # re-read from start if frame next time
304 1         3 return;
305              
306             done:
307 12 100       28 if ($eof) {
    100          
308             # forward eof as special wsctl with no frame
309             # FIXME: complain if we have eof but the current frame is not
310             # done yet.
311 2         7 $self->in_wsctl($dir,'',$time);
312             } elsif (defined $clen) {
313             # We have at least the header of a data frame (control frames
314             # are read as a single entity) and might need more data
315             # (clen>0). Set gap_diff.
316 2 50       11 $clen>0 and $conn->set_gap_diff($dir,
    50          
317             ! $clenhi ? $clen : # len <=32 bit
318             1 << 32 == 1 ? 0xffffffff : # maxint on 32-bit platform
319             ($clenhi << 32) + $clen # full 64 bit
320             );
321             }
322 12         39 return;
323              
324 0   0     0 bad_length:
325             $err ||= "non-minimal length representation in websocket frame";
326 0   0     0 reserved_flag:
327             $err ||= "extensions using reserved flags are not supported";
328 0   0     0 reserved_opcode:
329             $err ||= "no support for opcode $opcode";
330              
331             bad:
332 0         0 $conn->{error} = 1;
333 0         0 $self->fatal($err,$dir,$time);
334 0         0 return;
335 2         18 };
336             }
337              
338             return sub {
339 18     18   30 my $dir = shift;
340 18         26 goto &{$sub[$dir]};
  18         56  
341             }
342 1         7 }
343              
344             {
345             package Net::Inspect::L7::HTTP::WebSocket::_WSFrame;
346 4     4   14 sub new { bless {}, shift };
347             sub unmask {
348 11     11   62 my ($self,$data) = @_;
349 11 100 66     56 return $data if $data eq '' or ! $self->{mask};
350 8         16 my $l = length($data);
351 8   100     60 $data ^= substr($self->{mask} x int($l/4+2),$self->{mask_offset}||0,$l);
352 8         57 return $data;
353             };
354             }
355              
356             1;
357              
358             __END__