| Current File : //usr/share/webmin/vendor_perl/Protocol/WebSocket/Frame.pm |
package Protocol::WebSocket::Frame;
use strict;
use warnings;
use Config;
use Encode ();
use Scalar::Util 'readonly';
use constant MAX_RAND_INT => 2**32;
use constant MATH_RANDOM_SECURE => eval "require Math::Random::Secure;";
our $MAX_PAYLOAD_SIZE = 65536;
our $MAX_FRAGMENTS_AMOUNT = 128;
our %TYPES = (
continuation => 0x00,
text => 0x01,
binary => 0x02,
ping => 0x09,
pong => 0x0a,
close => 0x08
);
sub new {
my $class = shift;
$class = ref $class if ref $class;
my $buffer;
if (@_ == 1) {
$buffer = shift @_;
}
else {
my %args = @_;
$buffer = delete $args{buffer};
}
my $self = {@_};
bless $self, $class;
$buffer = '' unless defined $buffer;
if (Encode::is_utf8($buffer)) {
$self->{buffer} = Encode::encode('UTF-8', $buffer);
}
else {
$self->{buffer} = $buffer;
}
if (defined($self->{type}) && defined($TYPES{$self->{type}})) {
$self->opcode($TYPES{$self->{type}});
}
$self->{version} ||= 'draft-ietf-hybi-17';
$self->{fragments} = [];
$self->{max_fragments_amount} ||= $MAX_FRAGMENTS_AMOUNT unless exists $self->{max_fragments_amount};
$self->{max_payload_size} ||= $MAX_PAYLOAD_SIZE unless exists $self->{max_payload_size};
return $self;
}
sub version {
my $self = shift;
return $self->{version};
}
sub append {
my $self = shift;
return unless defined $_[0];
$self->{buffer} .= $_[0];
$_[0] = '' unless readonly $_[0];
return $self;
}
sub next {
my $self = shift;
my $bytes = $self->next_bytes;
return unless defined $bytes;
return Encode::decode('UTF-8', $bytes);
}
sub fin {
@_ > 1 ? $_[0]->{fin} =
$_[1]
: defined($_[0]->{fin}) ? $_[0]->{fin}
: 1;
}
sub rsv { @_ > 1 ? $_[0]->{rsv} = $_[1] : $_[0]->{rsv} }
sub opcode {
@_ > 1 ? $_[0]->{opcode} =
$_[1]
: defined($_[0]->{opcode}) ? $_[0]->{opcode}
: 1;
}
sub masked { @_ > 1 ? $_[0]->{masked} = $_[1] : $_[0]->{masked} }
sub is_ping { $_[0]->opcode == 9 }
sub is_pong { $_[0]->opcode == 10 }
sub is_close { $_[0]->opcode == 8 }
sub is_continuation { $_[0]->opcode == 0 }
sub is_text { $_[0]->opcode == 1 }
sub is_binary { $_[0]->opcode == 2 }
sub next_bytes {
my $self = shift;
if ( $self->version eq 'draft-hixie-75'
|| $self->version eq 'draft-ietf-hybi-00')
{
if ($self->{buffer} =~ s/^\xff\x00//) {
$self->opcode(8);
return '';
}
return unless $self->{buffer} =~ s/^[^\x00]*\x00(.*?)\xff//s;
return $1;
}
return unless length $self->{buffer} >= 2;
while (length $self->{buffer}) {
my $hdr = substr($self->{buffer}, 0, 1);
my @bits = split //, unpack("B*", $hdr);
$self->fin($bits[0]);
$self->rsv([@bits[1 .. 3]]);
my $opcode = unpack('C', $hdr) & 0b00001111;
my $offset = 1; # FIN,RSV[1-3],OPCODE
my $payload_len = unpack 'C', substr($self->{buffer}, 1, 1);
my $masked = ($payload_len & 0b10000000) >> 7;
$self->masked($masked);
$offset += 1; # + MASKED,PAYLOAD_LEN
$payload_len = $payload_len & 0b01111111;
if ($payload_len == 126) {
return unless length($self->{buffer}) >= $offset + 2;
$payload_len = unpack 'n', substr($self->{buffer}, $offset, 2);
$offset += 2;
}
elsif ($payload_len > 126) {
return unless length($self->{buffer}) >= $offset + 4;
my $bits = join '', map { unpack 'B*', $_ } split //,
substr($self->{buffer}, $offset, 8);
# Most significant bit must be 0.
# And here is a crazy way of doing it %)
$bits =~ s{^.}{0};
# Can we handle 64bit numbers?
if ($Config{ivsize} <= 4 || $Config{longsize} < 8 || $] < 5.010) {
$bits = substr($bits, 32);
$payload_len = unpack 'N', pack 'B*', $bits;
}
else {
$payload_len = unpack 'Q>', pack 'B*', $bits;
}
$offset += 8;
}
if ($self->{max_payload_size} && $payload_len > $self->{max_payload_size}) {
$self->{buffer} = '';
die "Payload is too big. "
. "Deny big message ($payload_len) "
. "or increase max_payload_size ($self->{max_payload_size})";
}
my $mask;
if ($self->masked) {
return unless length($self->{buffer}) >= $offset + 4;
$mask = substr($self->{buffer}, $offset, 4);
$offset += 4;
}
return if length($self->{buffer}) < $offset + $payload_len;
my $payload = substr($self->{buffer}, $offset, $payload_len);
if ($self->masked) {
$payload = $self->_mask($payload, $mask);
}
substr($self->{buffer}, 0, $offset + $payload_len, '');
# Injected control frame
if (@{$self->{fragments}} && $opcode & 0b1000) {
$self->opcode($opcode);
return $payload;
}
if ($self->fin) {
if (@{$self->{fragments}}) {
$self->opcode(shift @{$self->{fragments}});
}
else {
$self->opcode($opcode);
}
$payload = join '', @{$self->{fragments}}, $payload;
$self->{fragments} = [];
return $payload;
}
else {
# Remember first fragment opcode
if (!@{$self->{fragments}}) {
push @{$self->{fragments}}, $opcode;
}
push @{$self->{fragments}}, $payload;
die "Too many fragments"
if @{$self->{fragments}} > $self->{max_fragments_amount};
}
}
return;
}
sub to_bytes {
my $self = shift;
if ( $self->version eq 'draft-hixie-75'
|| $self->version eq 'draft-ietf-hybi-00')
{
if ($self->{type} && $self->{type} eq 'close') {
return "\xff\x00";
}
return "\x00" . $self->{buffer} . "\xff";
}
if ($self->{max_payload_size} && length $self->{buffer} > $self->{max_payload_size}) {
die "Payload is too big. "
. "Send shorter messages or increase max_payload_size";
}
my $rsv_set = 0;
if ( $self->{rsv} && ref( $self->{rsv} ) eq 'ARRAY' ) {
for my $i ( 0 .. @{ $self->{rsv} } - 1 ) {
$rsv_set += $self->{rsv}->[$i] * ( 1 << ( 6 - $i ) );
}
}
my $string = '';
my $opcode = $self->opcode;
$string .= pack 'C', ($opcode | $rsv_set | ($self->fin ? 128 : 0));
my $payload_len = length($self->{buffer});
if ($payload_len <= 125) {
$payload_len |= 0b10000000 if $self->masked;
$string .= pack 'C', $payload_len;
}
elsif ($payload_len <= 0xffff) {
$string .= pack 'C', 126 + ($self->masked ? 128 : 0);
$string .= pack 'n', $payload_len;
}
else {
$string .= pack 'C', 127 + ($self->masked ? 128 : 0);
# Shifting by an amount >= to the system wordsize is undefined
$string .= pack 'N', $Config{ivsize} <= 4 ? 0 : $payload_len >> 32;
$string .= pack 'N', ($payload_len & 0xffffffff);
}
if ($self->masked) {
my $mask = $self->{mask}
|| (
MATH_RANDOM_SECURE
? Math::Random::Secure::irand(MAX_RAND_INT)
: int(rand(MAX_RAND_INT))
);
$mask = pack 'N', $mask;
$string .= $mask;
$string .= $self->_mask($self->{buffer}, $mask);
}
else {
$string .= $self->{buffer};
}
return $string;
}
sub to_string {
my $self = shift;
die 'DO NOT USE';
}
sub _mask {
my $self = shift;
my ($payload, $mask) = @_;
$mask = $mask x (int(length($payload) / 4) + 1);
$mask = substr($mask, 0, length($payload));
$payload = "$payload" ^ $mask;
return $payload;
}
sub max_payload_size {
my $self = shift;
return $self->{max_payload_size};
}
1;
__END__
=head1 NAME
Protocol::WebSocket::Frame - WebSocket Frame
=head1 SYNOPSIS
# Create frame
my $frame = Protocol::WebSocket::Frame->new('123');
$frame->to_bytes;
# Parse frames
my $frame = Protocol::WebSocket::Frame->new;
$frame->append(...);
$f->next; # get next message
$f->next; # get another next message
=head1 DESCRIPTION
Construct or parse a WebSocket frame.
=head1 RANDOM MASK GENERATION
By default built-in C<rand> is used, this is not secure, so when
L<Math::Random::Secure> is installed it is used instead.
=head1 METHODS
=head2 C<new>
Protocol::WebSocket::Frame->new('data'); # same as (buffer => 'data')
Protocol::WebSocket::Frame->new(buffer => 'data', type => 'close');
Create a new L<Protocol::WebSocket::Frame> instance. Automatically detect if the
passed data is a Perl string (UTF-8 flag) or bytes.
When called with more than one arguments, it takes the following named arguments
(all of them are optional).
=over
=item C<buffer> => STR (default: C<"">)
The payload of the frame.
=item C<type> => TYPE_STR (default: C<"text">)
The type of the frame. Accepted values are:
continuation
text
binary
ping
pong
close
=item C<opcode> => INT (default: 1)
The opcode of the frame. If C<type> field is set to a valid string, this field is ignored.
=item C<fin> => BOOL (default: 1)
"fin" flag of the frame. "fin" flag must be 1 in the ending frame of fragments.
=item C<masked> => BOOL (default: 0)
If set to true, the frame will be masked.
=item C<version> => VERSION_STR (default: C<'draft-ietf-hybi-17'>)
WebSocket protocol version string. See L<Protocol::WebSocket> for valid version strings.
=back
=head2 C<is_continuation>
Check if frame is of continuation type.
=head2 C<is_text>
Check if frame is of text type.
=head2 C<is_binary>
Check if frame is of binary type.
=head2 C<is_ping>
Check if frame is a ping request.
=head2 C<is_pong>
Check if frame is a pong response.
=head2 C<is_close>
Check if frame is of close type.
=head2 C<opcode>
$opcode = $frame->opcode;
$frame->opcode(8);
Get/set opcode of the frame.
=head2 C<masked>
$masked = $frame->masked;
$frame->masked(1);
Get/set masking of the frame.
=head2 C<append>
$frame->append($chunk);
Append a frame chunk.
Beware that this method is B<destructive>.
It makes C<$chunk> empty unless C<$chunk> is read-only.
=head2 C<next>
$frame->append(...);
$frame->next; # next message
Return the next message as a Perl string (UTF-8 decoded).
=head2 C<next_bytes>
Return the next message as is.
=head2 C<to_bytes>
Construct a WebSocket message.
=head2 C<max_payload_size>
The maximum size of the payload. You may set this to C<0> or C<undef> to disable
checking the payload size.
=cut