Commit 1d37880d authored by Admin's avatar Admin

adding Protocol::WebSocket & tests;

parent 9f4ffa16
package Protocol::WebSocket;
use strict;
use warnings;
our $VERSION = '0.26';
use Protocol::WebSocket::Frame;
use Protocol::WebSocket::Handshake::Client;
use Protocol::WebSocket::Handshake::Server;
use Protocol::WebSocket::URL;
1;
__END__
=encoding UTF-8
=head1 NAME
Protocol::WebSocket - WebSocket protocol
=head1 SYNOPSIS
# Server side
my $hs = Protocol::WebSocket::Handshake::Server->new;
$hs->parse('some data from the client');
$hs->is_done; # tells us when handshake is done
my $frame = $hs->build_frame;
$frame->append('some data from the client');
while (defined(my $message = $frame->next)) {
if ($frame->is_close) {
# Send close frame back
send(
$hs->build_frame(
type => 'close',
version => $version
)->to_bytes
);
return;
}
# We got a message!
}
=head1 DESCRIPTION
Client/server WebSocket message and frame parser/constructor. This module does
not provide a WebSocket server or client, but is made for using in http servers
or clients to provide WebSocket support.
L<Protocol::WebSocket> supports the following WebSocket protocol versions:
draft-ietf-hybi-17 (latest)
draft-ietf-hybi-10
draft-ietf-hybi-00 (with HAProxy support)
draft-hixie-75
By default the latest version is used. The WebSocket version is detected
automatically on the server side. On the client side you have set a C<version>
attribute to an appropriate value.
L<Protocol::WebSocket> itself does not contain any code and cannot be used
directly. Instead the following modules should be used:
=head2 High-level modules
=head3 L<Protocol::WebSocket::Server>
Server helper class.
=head3 L<Protocol::WebSocket::Client>
Client helper class.
=head2 Low-level modules
=head3 L<Protocol::WebSocket::Handshake::Server>
Server handshake parser and constructor.
=head3 L<Protocol::WebSocket::Handshake::Client>
Client handshake parser and constructor.
=head3 L<Protocol::WebSocket::Frame>
WebSocket frame parser and constructor.
=head3 L<Protocol::WebSocket::Request>
Low level WebSocket request parser and constructor.
=head3 L<Protocol::WebSocket::Response>
Low level WebSocket response parser and constructor.
=head3 L<Protocol::WebSocket::URL>
Low level WebSocket url parser and constructor.
=head1 EXAMPLES
For examples on how to use L<Protocol::WebSocket> with various event loops see
C<examples/> directory in the distribution.
=head1 CREDITS
In order of appearance:
Paul "LeoNerd" Evans
Jon Gentle
Lee Aylward
Chia-liang Kao
Atomer Ju
Chuck Bredestege
Matthew Lien (BlueT)
Joao Orui
Toshio Ito (debug-ito)
Neil Bowers
Michal Špaček
Graham Ollis
Anton Petrusevich
Eric Wastl
=head1 AUTHOR
Viacheslav Tykhanovskyi, C<vti@cpan.org>.
=head1 COPYRIGHT
Copyright (C) 2010-2018, Viacheslav Tykhanovskyi.
This program is free software, you can redistribute it and/or modify it under
the same terms as Perl 5.10.
=cut
package Protocol::WebSocket::Client;
use strict;
use warnings;
require Carp;
use Protocol::WebSocket::URL;
use Protocol::WebSocket::Handshake::Client;
use Protocol::WebSocket::Frame;
sub new {
my $class = shift;
$class = ref $class if ref $class;
my (%params) = @_;
my $self = {};
bless $self, $class;
Carp::croak('url is required') unless $params{url};
$self->{url} = Protocol::WebSocket::URL->new->parse($params{url})
or Carp::croak("Can't parse url");
$self->{version} = $params{version};
$self->{on_connect} = $params{on_connect};
$self->{on_write} = $params{on_write};
$self->{on_frame} = $params{on_frame};
$self->{on_eof} = $params{on_eof};
$self->{on_error} = $params{on_error};
$self->{hs} =
Protocol::WebSocket::Handshake::Client->new(url => $self->{url});
my %frame_buffer_params = (
max_fragments_amount => $params{max_fragments_amount}
);
$frame_buffer_params{max_payload_size} = $params{max_payload_size} if exists $params{max_payload_size};
$self->{frame_buffer} = $self->_build_frame(%frame_buffer_params);
return $self;
}
sub url { shift->{url} }
sub version { shift->{version} }
sub on {
my $self = shift;
my ($event, $cb) = @_;
$self->{"on_$event"} = $cb;
return $self;
}
sub read {
my $self = shift;
my ($buffer) = @_;
my $hs = $self->{hs};
my $frame_buffer = $self->{frame_buffer};
unless ($hs->is_done) {
if (!$hs->parse($buffer)) {
$self->{on_error}->($self, $hs->error);
return $self;
}
$self->{on_connect}->($self) if $self->{on_connect} && $hs->is_done;
}
if ($hs->is_done) {
$frame_buffer->append($buffer);
while (my $bytes = $frame_buffer->next) {
$self->{on_read}->($self, $bytes);
#$self->{on_frame}->($self, $bytes);
}
}
return $self;
}
sub write {
my $self = shift;
my ($buffer) = @_;
my $frame =
ref $buffer
? $buffer
: $self->_build_frame(masked => 1, buffer => $buffer);
$self->{on_write}->($self, $frame->to_bytes);
return $self;
}
sub connect {
my $self = shift;
my $hs = $self->{hs};
$self->{on_write}->($self, $hs->to_string);
return $self;
}
sub disconnect {
my $self = shift;
my $frame = $self->_build_frame(type => 'close');
$self->{on_write}->($self, $frame->to_bytes);
return $self;
}
sub _build_frame {
my $self = shift;
return Protocol::WebSocket::Frame->new(version => $self->{version}, @_);
}
1;
__END__
=head1 NAME
Protocol::WebSocket::Client - WebSocket client
=head1 SYNOPSIS
my $sock = ...get non-blocking socket...;
my $client = Protocol::WebSocket->new(url => 'ws://localhost:3000');
$client->on(
write => sub {
my $client = shift;
my ($buf) = @_;
syswrite $sock, $buf;
}
);
$client->on(
read => sub {
my $client = shift;
my ($buf) = @_;
...do smth with read data...
}
);
# Sends a correct handshake header
$client->connect;
# Register on connect handler
$client->on(
connect => sub {
$client->write('hi there');
}
);
# Parses incoming data and on every frame calls on_read
$client->read(...data from socket...);
# Sends correct close header
$client->disconnect;
=head1 DESCRIPTION
L<Protocol::WebSocket::Client> is a convenient class for writing a WebSocket
client.
=cut
package Protocol::WebSocket::Cookie;
use strict;
use warnings;
sub new {
my $class = shift;
$class = ref $class if ref $class;
my $self = {@_};
bless $self, $class;
return $self;
}
sub pairs { @_ > 1 ? $_[0]->{pairs} = $_[1] : $_[0]->{pairs} }
my $TOKEN = qr/[^;,\s"]+/;
my $NAME = qr/[^;,\s"=]+/;
my $QUOTED_STRING = qr/"(?:\\"|[^"])+"/;
my $VALUE = qr/(?:$TOKEN|$QUOTED_STRING)/;
sub parse {
my $self = shift;
my $string = shift;
$self->{pairs} = [];
return unless defined $string && $string ne '';
while ($string =~ m/\s*($NAME)\s*(?:=\s*($VALUE))?;?/g) {
my ($attr, $value) = ($1, $2);
if (defined $value) {
$value =~ s/^"//;
$value =~ s/"$//;
$value =~ s/\\"/"/g;
}
push @{$self->{pairs}}, [$attr, $value];
}
return $self;
}
sub to_string {
my $self = shift;
my $string = '';
my @pairs;
foreach my $pair (@{$self->pairs}) {
my $string = '';
$string .= $pair->[0];
if (defined $pair->[1]) {
$string .= '=';
$string
.= $pair->[1] !~ m/^$VALUE$/ ? "\"$pair->[1]\"" : $pair->[1];
}
push @pairs, $string;
}
return join '; ' => @pairs;
}
1;
__END__
=head1 NAME
Protocol::WebSocket::Cookie - Base class for WebSocket cookies
=head1 DESCRIPTION
A base class for L<Protocol::WebSocket::Cookie::Request> and
L<Protocol::WebSocket::Cookie::Response>.
=head1 ATTRIBUTES
=head2 C<pairs>
=head1 METHODS
=head2 C<new>
Create a new L<Protocol::WebSocket::Cookie> instance.
=head2 C<parse>
=head2 C<to_string>
=cut
package Protocol::WebSocket::Cookie::Request;
use strict;
use warnings;
use base 'Protocol::WebSocket::Cookie';
sub parse {
my $self = shift;
$self->SUPER::parse(@_);
my $cookies = [];
my $version = 1;
if ($self->pairs->[0] eq '$Version') {
my $pair = shift @{$self->pairs};
$version = $pair->[1];
}
my $cookie;
foreach my $pair (@{$self->pairs}) {
next unless defined $pair->[0];
if ($pair->[0] =~ m/^[^\$]/) {
push @$cookies, $cookie if defined $cookie;
$cookie = $self->_build_cookie(
name => $pair->[0],
value => $pair->[1],
version => $version
);
}
elsif ($pair->[0] eq '$Path') {
$cookie->path($pair->[1]);
}
elsif ($pair->[0] eq '$Domain') {
$cookie->domain($pair->[1]);
}
}
push @$cookies, $cookie if defined $cookie;
return $cookies;
}
sub name { @_ > 1 ? $_[0]->{name} = $_[1] : $_[0]->{name} }
sub value { @_ > 1 ? $_[0]->{value} = $_[1] : $_[0]->{value} }
sub version { @_ > 1 ? $_[0]->{version} = $_[1] : $_[0]->{version} }
sub path { @_ > 1 ? $_[0]->{path} = $_[1] : $_[0]->{path} }
sub domain { @_ > 1 ? $_[0]->{domain} = $_[1] : $_[0]->{domain} }
sub _build_cookie { shift; Protocol::WebSocket::Cookie::Request->new(@_) }
1;
__END__
=head1 NAME
Protocol::WebSocket::Cookie::Request - WebSocket Cookie Request
=head1 SYNOPSIS
# Constructor
# Parser
my $cookie = Protocol::WebSocket::Cookie::Request->new;
$cookies = $cookie->parse(
'$Version=1; foo="bar"; $Path=/; bar=baz; $Domain=.example.com');
=head1 DESCRIPTION
Construct or parse a WebSocket request cookie.
=head1 ATTRIBUTES
=head2 C<name>
=head2 C<value>
=head2 C<version>
=head2 C<path>
=head2 C<domain>
=head1 METHODS
=head2 C<parse>
Parse a WebSocket request cookie.
=head2 C<to_string>
Construct a WebSocket request cookie.
=cut
package Protocol::WebSocket::Cookie::Response;
use strict;
use warnings;
use base 'Protocol::WebSocket::Cookie';
sub parse {
my $self = shift;
$self->SUPER::parse(@_);
}
sub to_string {
my $self = shift;
my $pairs = [];
push @$pairs, [$self->{name}, $self->{value}];
push @$pairs, ['Comment', $self->{comment}] if defined $self->{comment};
push @$pairs, ['CommentURL', $self->{comment_url}]
if defined $self->{comment_url};
push @$pairs, ['Discard'] if $self->{discard};
push @$pairs, ['Max-Age' => $self->{max_age}] if defined $self->{max_age};
push @$pairs, ['Path' => $self->{path}] if defined $self->{path};
if (defined $self->{portlist}) {
$self->{portlist} = [$self->{portlist}]
unless ref $self->{portlist} eq 'ARRAY';
my $list = join ' ' => @{$self->{portlist}};
push @$pairs, ['Port' => "\"$list\""];
}
push @$pairs, ['Secure'] if $self->{secure};
push @$pairs, ['Version' => '1'];
$self->pairs($pairs);
return $self->SUPER::to_string;
}
1;
__END__
=head1 NAME
Protocol::WebSocket::Cookie::Response - WebSocket Cookie Response
=head1 SYNOPSIS
# Constructor
my $cookie = Protocol::WebSocket::Cookie::Response->new(
name => 'foo',
value => 'bar',
discard => 1,
max_age => 0
);
$cookie->to_string; # foo=bar; Discard; Max-Age=0; Version=1
# Parser
my $cookie = Protocol::WebSocket::Cookie::Response->new;
$cookie->parse('foo=bar; Discard; Max-Age=0; Version=1');
=head1 DESCRIPTION
Construct or parse a WebSocket response cookie.
=head1 METHODS
=head2 C<parse>
Parse a WebSocket response cookie.
=head2 C<to_string>
Construct a WebSocket response cookie.
=cut
This diff is collapsed.
package Protocol::WebSocket::Handshake;
use strict;
use warnings;
use Protocol::WebSocket::Request;
use Protocol::WebSocket::Response;
sub new {
my $class = shift;
$class = ref $class if ref $class;
my $self = {@_};
bless $self, $class;
return $self;
}
sub error { @_ > 1 ? $_[0]->{error} = $_[1] : $_[0]->{error} }
sub version { $_[0]->req->version }
sub req { shift->{req} ||= Protocol::WebSocket::Request->new }
sub res { shift->{res} ||= Protocol::WebSocket::Response->new }
1;
__END__