mirror of
https://github.com/webmin/webmin.git
synced 2026-03-20 16:50:24 +00:00
Add to bundle Protocols:WebSocket and Net:WebSocket
This commit is contained in:
iliajie
@@ -1,6 +1,8 @@
|
||||
#!/usr/local/bin/perl
|
||||
# Show a terminal that is connected to a Websockets server via Webmin proxying
|
||||
|
||||
use lib ("$ENV{'DOCUMENT_ROOT'}/xterm/lib");
|
||||
|
||||
require './xterm-lib.pl';
|
||||
&ReadParse();
|
||||
|
||||
|
||||
572
xterm/lib/Net/WebSocket/Server.pm
Normal file
572
xterm/lib/Net/WebSocket/Server.pm
Normal file
@@ -0,0 +1,572 @@
|
||||
package Net::WebSocket::Server;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
|
||||
use Carp;
|
||||
use IO::Socket::INET;
|
||||
use IO::Select;
|
||||
use Net::WebSocket::Server::Connection;
|
||||
use Time::HiRes qw(time);
|
||||
use List::Util qw(min);
|
||||
|
||||
our $VERSION = '0.004000';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
$SIG{PIPE} = 'IGNORE';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
my %params = @_;
|
||||
|
||||
my $self = {
|
||||
listen => 80,
|
||||
silence_max => 20,
|
||||
tick_period => 0,
|
||||
watch_readable => [],
|
||||
watch_writable => [],
|
||||
on_connect => sub{},
|
||||
on_tick => sub{},
|
||||
on_shutdown => sub{},
|
||||
};
|
||||
|
||||
while (my ($key, $value) = each %params ) {
|
||||
croak "Invalid $class parameter '$key'" unless exists $self->{$key};
|
||||
croak "$class parameter '$key' expected type is ".ref($self->{$key}) if ref $self->{$key} && ref $value ne ref $self->{$key};
|
||||
$self->{$key} = $value;
|
||||
}
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
# send a ping every silence_max by checking whether data was received in the last silence_max/2
|
||||
$self->{silence_checkinterval} = $self->{silence_max} / 2;
|
||||
|
||||
foreach my $watchtype (qw(readable writable)) {
|
||||
$self->{"select_$watchtype"} = IO::Select->new();
|
||||
my $key = "watch_$watchtype";
|
||||
croak "$class parameter '$key' expects an arrayref containing an even number of elements" unless @{$self->{$key}} % 2 == 0;
|
||||
my @watch = @{$self->{$key}};
|
||||
$self->{$key} = {};
|
||||
$self->_watch($watchtype, @watch);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub watch_readable {
|
||||
my $self = shift;
|
||||
croak "watch_readable expects an even number of arguments" unless @_ % 2 == 0;
|
||||
$self->_watch(readable => @_);
|
||||
}
|
||||
|
||||
sub watched_readable {
|
||||
my $self = shift;
|
||||
return $self->{watch_readable}{$_[0]}{cb} if @_;
|
||||
return map {$_->{fh}, $_->{cb}} values %{$self->{watch_readable}};
|
||||
}
|
||||
|
||||
sub watch_writable {
|
||||
my $self = shift;
|
||||
croak "watch_writable expects an even number of arguments" unless @_ % 2 == 0;
|
||||
$self->_watch(writable => @_);
|
||||
}
|
||||
|
||||
sub watched_writable {
|
||||
my $self = shift;
|
||||
return $self->{watch_writable}{$_[0]}{cb} if @_;
|
||||
return map {$_->{fh}, $_->{cb}} values %{$self->{watch_writable}};
|
||||
}
|
||||
|
||||
sub _watch {
|
||||
my $self = shift;
|
||||
my $watchtype = shift;
|
||||
croak "watch_$watchtype expects an even number of arguments after the type" unless @_ % 2 == 0;
|
||||
for (my $i = 0; $i < @_; $i+=2) {
|
||||
my ($fh, $cb) = ($_[$i], $_[$i+1]);
|
||||
croak "watch_$watchtype expects the second value of each pair to be a coderef, but element $i was not" unless ref $cb eq 'CODE';
|
||||
if ($self->{"watch_$watchtype"}{$fh}) {
|
||||
carp "watch_$watchtype was given a filehandle at index $i which is already being watched; ignoring!";
|
||||
next;
|
||||
}
|
||||
$self->{"select_$watchtype"}->add($fh);
|
||||
$self->{"watch_$watchtype"}{$fh} = {fh=>$fh, cb=>$cb};
|
||||
}
|
||||
}
|
||||
|
||||
sub unwatch_readable {
|
||||
my $self = shift;
|
||||
$self->_unwatch(readable => @_);
|
||||
}
|
||||
|
||||
sub unwatch_writable {
|
||||
my $self = shift;
|
||||
$self->_unwatch(writable => @_);
|
||||
}
|
||||
|
||||
sub _unwatch {
|
||||
my $self = shift;
|
||||
my $watchtype = shift;
|
||||
foreach my $fh (@_) {
|
||||
$self->{"select_$watchtype"}->remove($fh);
|
||||
delete $self->{"watch_$watchtype"}{$fh};
|
||||
}
|
||||
}
|
||||
|
||||
sub on {
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
while (my ($key, $value) = each %params ) {
|
||||
croak "Invalid event '$key'" unless exists $self->{"on_$key"};
|
||||
croak "Expected a coderef for event '$key'" unless ref $value eq 'CODE';
|
||||
$self->{"on_$key"} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
|
||||
if (ref $self->{listen}) {
|
||||
# if we got a server, make sure it's valid by clearing errors and checking errors anyway; if there's still an error, it's closed
|
||||
$self->{listen}->clearerr;
|
||||
croak "failed to start websocket server; the TCP server provided via 'listen' is invalid. (is the listening socket is closed? are you trying to reuse a server that has already shut down?)"
|
||||
if $self->{listen}->error;
|
||||
} else {
|
||||
# if we merely got a port, set up a reasonable default tcp server
|
||||
$self->{listen} = IO::Socket::INET->new(
|
||||
Listen => 5,
|
||||
LocalPort => $self->{listen},
|
||||
Proto => 'tcp',
|
||||
ReuseAddr => 1,
|
||||
) || croak "failed to listen on port $self->{listen}: $!";
|
||||
}
|
||||
|
||||
$self->{select_readable}->add($self->{listen});
|
||||
|
||||
$self->{conns} = {};
|
||||
my $silence_nextcheck = $self->{silence_max} ? (time + $self->{silence_checkinterval}) : 0;
|
||||
my $tick_next = $self->{tick_period} ? (time + $self->{tick_period}) : 0;
|
||||
|
||||
while ($self->{listen}->opened) {
|
||||
my $silence_checktimeout = $self->{silence_max} ? ($silence_nextcheck - time) : undef;
|
||||
my $tick_timeout = $self->{tick_period} ? ($tick_next - time) : undef;
|
||||
my $timeout = min(grep {defined} ($silence_checktimeout, $tick_timeout));
|
||||
|
||||
my ($ready_read, $ready_write, undef) = IO::Select->select($self->{select_readable}, $self->{select_writable}, undef, $timeout);
|
||||
foreach my $fh ($ready_read ? @$ready_read : ()) {
|
||||
if ($fh == $self->{listen}) {
|
||||
my $sock = $self->{listen}->accept;
|
||||
next unless $sock;
|
||||
my $conn = new Net::WebSocket::Server::Connection(socket => $sock, server => $self);
|
||||
$self->{conns}{$sock} = {conn=>$conn, lastrecv=>time};
|
||||
$self->{select_readable}->add($sock);
|
||||
$self->{on_connect}($self, $conn);
|
||||
} elsif ($self->{watch_readable}{$fh}) {
|
||||
$self->{watch_readable}{$fh}{cb}($self, $fh);
|
||||
} elsif ($self->{conns}{$fh}) {
|
||||
my $connmeta = $self->{conns}{$fh};
|
||||
$connmeta->{lastrecv} = time;
|
||||
$connmeta->{conn}->recv();
|
||||
} else {
|
||||
warn "filehandle $fh became readable, but no handler took responsibility for it; removing it";
|
||||
$self->{select_readable}->remove($fh);
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $fh ($ready_write ? @$ready_write : ()) {
|
||||
if ($self->{watch_writable}{$fh}) {
|
||||
$self->{watch_writable}{$fh}{cb}($self, $fh);
|
||||
} else {
|
||||
warn "filehandle $fh became writable, but no handler took responsibility for it; removing it";
|
||||
$self->{select_writable}->remove($fh);
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{silence_max}) {
|
||||
my $now = time;
|
||||
if ($silence_nextcheck < $now) {
|
||||
my $lastcheck = $silence_nextcheck - $self->{silence_checkinterval};
|
||||
$_->{conn}->send('ping') for grep { $_->{conn}->is_ready && $_->{lastrecv} < $lastcheck } values %{$self->{conns}};
|
||||
|
||||
$silence_nextcheck = $now + $self->{silence_checkinterval};
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{tick_period} && $tick_next < time) {
|
||||
$self->{on_tick}($self);
|
||||
$tick_next += $self->{tick_period};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub connections { grep {$_->is_ready} map {$_->{conn}} values %{$_[0]{conns}} }
|
||||
|
||||
sub shutdown {
|
||||
my ($self) = @_;
|
||||
$self->{on_shutdown}($self);
|
||||
$self->{select_readable}->remove($self->{listen});
|
||||
$self->{listen}->shutdown(2);
|
||||
$self->{listen}->close();
|
||||
$_->disconnect(1001) for $self->connections;
|
||||
}
|
||||
|
||||
sub disconnect {
|
||||
my ($self, $fh) = @_;
|
||||
$self->{select_readable}->remove($fh);
|
||||
$fh->close();
|
||||
delete $self->{conns}{$fh};
|
||||
}
|
||||
|
||||
1; # End of Net::WebSocket::Server
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::WebSocket::Server - A straightforward Perl WebSocket server with minimal dependencies.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Simple echo server for C<utf8> messages.
|
||||
|
||||
use Net::WebSocket::Server;
|
||||
|
||||
Net::WebSocket::Server->new(
|
||||
listen => 8080,
|
||||
on_connect => sub {
|
||||
my ($serv, $conn) = @_;
|
||||
$conn->on(
|
||||
utf8 => sub {
|
||||
my ($conn, $msg) = @_;
|
||||
$conn->send_utf8($msg);
|
||||
},
|
||||
);
|
||||
},
|
||||
)->start;
|
||||
|
||||
Server that sends the current time to all clients every second.
|
||||
|
||||
use Net::WebSocket::Server;
|
||||
|
||||
my $ws = Net::WebSocket::Server->new(
|
||||
listen => 8080,
|
||||
tick_period => 1,
|
||||
on_tick => sub {
|
||||
my ($serv) = @_;
|
||||
$_->send_utf8(time) for $serv->connections;
|
||||
},
|
||||
)->start;
|
||||
|
||||
Broadcast-echo server for C<utf8> and C<binary> messages with origin testing.
|
||||
|
||||
use Net::WebSocket::Server;
|
||||
|
||||
my $origin = 'http://example.com';
|
||||
|
||||
Net::WebSocket::Server->new(
|
||||
listen => 8080,
|
||||
on_connect => sub {
|
||||
my ($serv, $conn) = @_;
|
||||
$conn->on(
|
||||
handshake => sub {
|
||||
my ($conn, $handshake) = @_;
|
||||
$conn->disconnect() unless $handshake->req->origin eq $origin;
|
||||
},
|
||||
utf8 => sub {
|
||||
my ($conn, $msg) = @_;
|
||||
$_->send_utf8($msg) for $conn->server->connections;
|
||||
},
|
||||
binary => sub {
|
||||
my ($conn, $msg) = @_;
|
||||
$_->send_binary($msg) for $conn->server->connections;
|
||||
},
|
||||
);
|
||||
},
|
||||
)->start;
|
||||
|
||||
See L</listen> for an example of setting up an SSL (C<wss://...>) server.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module implements the details of a WebSocket server and invokes the
|
||||
provided callbacks whenever something interesting happens. Individual
|
||||
connections to the server are represented as
|
||||
L<Net::WebSocket::Server::Connection|Net::WebSocket::Server::Connection>
|
||||
objects.
|
||||
|
||||
=head1 CONSTRUCTION
|
||||
|
||||
=over
|
||||
|
||||
=item C<< Net::WebSocket::Server->new(I<%opts>) >>
|
||||
|
||||
Net::WebSocket::Server->new(
|
||||
listen => 8080,
|
||||
on_connect => sub { ... },
|
||||
)
|
||||
|
||||
Creates a new C<Net::WebSocket::Server> object with the given configuration.
|
||||
Takes the following parameters:
|
||||
|
||||
=over
|
||||
|
||||
=item C<listen>
|
||||
|
||||
If not a reference, the TCP port on which to listen. If a reference, a
|
||||
preconfigured L<IO::Socket::INET|IO::Socket::INET> TCP server to use. Default C<80>.
|
||||
|
||||
To create an SSL WebSocket server (such that you can connect to it via a
|
||||
C<wss://...> URL), pass an object which acts like L<IO::Socket::INET|IO::Socket::INET>
|
||||
and speaks SSL, such as L<IO::Socket::SSL|IO::Socket::SSL>. To avoid blocking
|
||||
during the SSL handshake, pass C<< SSL_startHandshake => 0 >> to the
|
||||
L<IO::Socket::SSL|IO::Socket::SSL> constructor and the handshake will be handled
|
||||
automatically as part of the normal server loop. For example:
|
||||
|
||||
my $ssl_server = IO::Socket::SSL->new(
|
||||
Listen => 5,
|
||||
LocalPort => 8080,
|
||||
Proto => 'tcp',
|
||||
SSL_startHandshake => 0,
|
||||
SSL_cert_file => '/path/to/server.crt',
|
||||
SSL_key_file => '/path/to/server.key',
|
||||
) or die "failed to listen: $!";
|
||||
|
||||
Net::WebSocket::Server->new(
|
||||
listen => $ssl_server,
|
||||
on_connect => sub { ... },
|
||||
)->start;
|
||||
|
||||
=item C<silence_max>
|
||||
|
||||
The maximum amount of time in seconds to allow silence on each connection's
|
||||
socket. Every C<silence_max/2> seconds, each connection is checked for
|
||||
whether data was received since the last check; if not, a WebSocket ping
|
||||
message is sent. Set to C<0> to disable. Default C<20>.
|
||||
|
||||
=item C<tick_period>
|
||||
|
||||
The amount of time in seconds between C<tick> events. Set to C<0> to disable.
|
||||
Default C<0>.
|
||||
|
||||
=item C<on_C<$event>>
|
||||
|
||||
The callback to invoke when the given C<$event> occurs, such as C<on_connect>.
|
||||
See L</EVENTS>.
|
||||
|
||||
=item C<watch_readable>
|
||||
|
||||
=item C<watch_writable>
|
||||
|
||||
Each of these takes an I<arrayref> of C<< $filehandle => $callback >> pairs to be
|
||||
passed to the corresponding method. Default C<[]>. See
|
||||
L<watch_readable()|/watch_readable(@pairs)> and
|
||||
L<watch_writable()|/watch_writable(@pairs)>. For example:
|
||||
|
||||
Net::WebSocket::Server->new(
|
||||
# ...other relevant arguments...
|
||||
watch_readable => [
|
||||
\*STDIN => \&on_stdin,
|
||||
],
|
||||
watch_writable => [
|
||||
$log1_fh => sub { ... },
|
||||
$log2_fh => sub { ... },
|
||||
],
|
||||
)->start;
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item C<on(I<%events>)>
|
||||
|
||||
$server->on(
|
||||
connect => sub { ... },
|
||||
);
|
||||
|
||||
Takes a list of C<< $event => $callback >> pairs; C<$event> names should not
|
||||
include an C<on_> prefix. Typically, events are configured once via the
|
||||
L<constructor|/CONSTRUCTION> rather than later via this method. See L</EVENTS>.
|
||||
|
||||
=item C<start()>
|
||||
|
||||
Starts the WebSocket server; registered callbacks will be invoked as
|
||||
interesting things happen. Does not return until L<shutdown()|/shutdown> is
|
||||
called.
|
||||
|
||||
=item C<connections()>
|
||||
|
||||
Returns a list of the current
|
||||
L<Net::WebSocket::Server::Connection|Net::WebSocket::Server::Connection>
|
||||
objects.
|
||||
|
||||
=item C<disconnect(I<$socket>)>
|
||||
|
||||
Immediately disconnects the given C<$socket> without calling the corresponding
|
||||
connection's callback or cleaning up the socket. For that, see
|
||||
L<Net::WebSocket::Server::Connection/disconnect>, which ultimately calls this
|
||||
function anyway.
|
||||
|
||||
=item C<shutdown()>
|
||||
|
||||
Closes the listening socket and cleanly disconnects all clients, causing the
|
||||
L<start()|/start> method to return.
|
||||
|
||||
=item C<watch_readable(I<@pairs>)>
|
||||
|
||||
$server->watch_readable(
|
||||
\*STDIN => \&on_stdin,
|
||||
);
|
||||
|
||||
Takes a list of C<< $filehandle => $callback >> pairs. The given filehandles
|
||||
will be monitored for readability; when readable, the given callback will be
|
||||
invoked. Arguments passed to the callback are the server itself and the
|
||||
filehandle which became readable.
|
||||
|
||||
=item C<watch_writable(I<@pairs>)>
|
||||
|
||||
$server->watch_writable(
|
||||
$log1_fh => sub { ... },
|
||||
$log2_fh => sub { ... },
|
||||
);
|
||||
|
||||
Takes a list of C<< $filehandle => $callback >> pairs. The given filehandles
|
||||
will be monitored for writability; when writable, the given callback will be
|
||||
invoked. Arguments passed to the callback are the server itself and the
|
||||
filehandle which became writable.
|
||||
|
||||
=item C<watched_readable([I<$filehandle>])>
|
||||
|
||||
=item C<watched_writable([I<$filehandle>])>
|
||||
|
||||
These methods return a list of C<< $filehandle => $callback >> pairs that are
|
||||
curently being watched for readability / writability. If a filehandle is
|
||||
given, its callback is returned, or C<undef> if it isn't being watched.
|
||||
|
||||
=item C<unwatch_readable(I<@filehandles>)>
|
||||
|
||||
=item C<unwatch_writable(I<@filehandles>)>
|
||||
|
||||
These methods cause the given filehandles to no longer be watched for
|
||||
readability / writability.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
Attach a callback for an event by either passing C<on_$event> parameters to the
|
||||
L<constructor|/CONSTRUCTION> or by passing C<$event> parameters to the
|
||||
L<on()|/on> method.
|
||||
|
||||
=over
|
||||
|
||||
=item C<connect(I<$server>, I<$connection>)>
|
||||
|
||||
Invoked when a new connection is made. Use this event to configure the
|
||||
newly-constructed
|
||||
L<Net::WebSocket::Server::Connection|Net::WebSocket::Server::Connection>
|
||||
object. Arguments passed to the callback are the server accepting the
|
||||
connection and the new connection object itself.
|
||||
|
||||
=item C<tick(I<$server>)>
|
||||
|
||||
Invoked every L<tick_period|/tick_period> seconds, or never if
|
||||
L<tick_period|/tick_period> is C<0>. Useful to perform actions that aren't in
|
||||
response to a message from a client. Arguments passed to the callback are only
|
||||
the server itself.
|
||||
|
||||
=item C<shutdown(I<$server>)>
|
||||
|
||||
Invoked immediately before the server shuts down due to the L<shutdown()>
|
||||
method being invoked. Any client connections will still be available until
|
||||
the event handler returns. Arguments passed to the callback are only the
|
||||
server that is being shut down.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
When loaded (via C<use>, at C<BEGIN>-time), this module installs a C<SIGPIPE> handler of C<'IGNORE'>. Write failures are handled situationally rather than in a global C<SIGPIPE> handler, but this still must be done to prevent the signal from killing the server process. If you require your own C<SIGPIPE> handler, assign to C<$SIG{PIPE}> after this module is loaded.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eric Wastl, C<< <topaz at cpan.org> >>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to C<bug-net-websocket-server at rt.cpan.org>, or through
|
||||
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-WebSocket-Server>. I will be notified, and then you'll
|
||||
automatically be notified of progress on your bug as I make changes.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
You can find documentation for this module with the perldoc command.
|
||||
|
||||
perldoc Net::WebSocket::Server
|
||||
|
||||
You can also look for information at:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * RT: CPAN's request tracker (report bugs here)
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-WebSocket-Server>
|
||||
|
||||
=item * AnnoCPAN: Annotated CPAN documentation
|
||||
|
||||
L<http://annocpan.org/dist/Net-WebSocket-Server>
|
||||
|
||||
=item * CPAN Ratings
|
||||
|
||||
L<http://cpanratings.perl.org/d/Net-WebSocket-Server>
|
||||
|
||||
=item * Search CPAN
|
||||
|
||||
L<http://search.cpan.org/dist/Net-WebSocket-Server/>
|
||||
|
||||
=back
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2013 Eric Wastl.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the the Artistic License (2.0). You may obtain a
|
||||
copy of the full license at:
|
||||
|
||||
L<http://www.perlfoundation.org/artistic_license_2_0>
|
||||
|
||||
Any use, modification, and distribution of the Standard or Modified
|
||||
Versions is governed by this Artistic License. By using, modifying or
|
||||
distributing the Package, you accept this license. Do not use, modify,
|
||||
or distribute the Package, if you do not accept this license.
|
||||
|
||||
If your Modified Version has been derived from a Modified Version made
|
||||
by someone other than you, you are nevertheless required to ensure that
|
||||
your Modified Version complies with the requirements of this license.
|
||||
|
||||
This license does not grant you the right to use any trademark, service
|
||||
mark, tradename, or logo of the Copyright Holder.
|
||||
|
||||
This license includes the non-exclusive, worldwide, free-of-charge
|
||||
patent license to make, have made, use, offer to sell, sell, import and
|
||||
otherwise transfer the Package with respect to any patent claims
|
||||
licensable by the Copyright Holder that are necessarily infringed by the
|
||||
Package. If you institute patent litigation (including a cross-claim or
|
||||
counterclaim) against any party alleging that the Package constitutes
|
||||
direct or contributory patent infringement, then this Artistic License
|
||||
to you shall terminate on the date that such litigation is filed.
|
||||
|
||||
Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
|
||||
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
|
||||
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
|
||||
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
|
||||
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
|
||||
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
|
||||
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
|
||||
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
502
xterm/lib/Net/WebSocket/Server/Connection.pm
Normal file
502
xterm/lib/Net/WebSocket/Server/Connection.pm
Normal file
@@ -0,0 +1,502 @@
|
||||
package Net::WebSocket::Server::Connection;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
|
||||
use Carp;
|
||||
use Protocol::WebSocket::Handshake::Server;
|
||||
use Protocol::WebSocket::Frame;
|
||||
use Socket qw(IPPROTO_TCP TCP_NODELAY);
|
||||
use Encode;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
my %params = @_;
|
||||
|
||||
my $self = {
|
||||
socket => undef,
|
||||
server => undef,
|
||||
nodelay => 1,
|
||||
max_send_size => eval { Protocol::WebSocket::Frame->new->{max_payload_size} } || 65536,
|
||||
max_recv_size => eval { Protocol::WebSocket::Frame->new->{max_payload_size} } || 65536,
|
||||
on_handshake => sub{},
|
||||
on_ready => sub{},
|
||||
on_disconnect => sub{},
|
||||
on_utf8 => sub{},
|
||||
on_pong => sub{},
|
||||
on_binary => sub{},
|
||||
};
|
||||
|
||||
while (my ($key, $value) = each %params ) {
|
||||
croak "Invalid $class parameter '$key'" unless exists $self->{$key};
|
||||
croak "$class parameter '$key' expects a coderef" if ref $self->{$key} eq 'CODE' && ref $value ne 'CODE';
|
||||
$self->{$key} = $value;
|
||||
}
|
||||
|
||||
croak "$class construction requires '$_'" for grep { !defined $self->{$_} } qw(socket server);
|
||||
|
||||
$self->{handshake} = new Protocol::WebSocket::Handshake::Server();
|
||||
$self->{disconnecting} = 0;
|
||||
$self->{ip} = $self->{socket}->peerhost;
|
||||
$self->{port} = $self->{socket}->peerport;
|
||||
|
||||
# only attempt to start SSL if this is an IO::Socket::SSL-like socket that also has not completed its SSL handshake (SSL_startHandshake => 0)
|
||||
$self->{needs_ssl} = 1 if $self->{socket}->can("accept_SSL") && !$self->{socket}->opened;
|
||||
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
sub on {
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
while (my ($key, $value) = each %params ) {
|
||||
croak "Invalid event '$key'" unless exists $self->{"on_$key"};
|
||||
croak "Expected a coderef for event '$key'" unless ref $value eq 'CODE';
|
||||
$self->{"on_$key"} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
### accessors
|
||||
|
||||
sub server { $_[0]->{server} }
|
||||
|
||||
sub socket { $_[0]->{socket} }
|
||||
|
||||
sub is_ready { !$_[0]->{handshake} }
|
||||
|
||||
sub ip { $_[0]{ip} }
|
||||
|
||||
sub port { $_[0]{port} }
|
||||
|
||||
sub nodelay {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{nodelay} = $_[0];
|
||||
setsockopt($self->{socket}, IPPROTO_TCP, TCP_NODELAY, $self->{nodelay} ? 1 : 0) unless $self->{handshake};
|
||||
}
|
||||
return $self->{nodelay};
|
||||
}
|
||||
|
||||
sub max_send_size {
|
||||
my $self = shift;
|
||||
$self->{max_send_size} = $_[0] if @_;
|
||||
return $self->{max_send_size};
|
||||
}
|
||||
|
||||
sub max_recv_size {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
croak "Cannot change max_recv_size; handshake is already complete" if $self->{parser};
|
||||
$self->{max_recv_size} = $_[0];
|
||||
}
|
||||
return $self->{max_recv_size};
|
||||
}
|
||||
|
||||
|
||||
### methods
|
||||
|
||||
sub disconnect {
|
||||
my ($self, $code, $reason) = @_;
|
||||
return if $self->{disconnecting};
|
||||
$self->{disconnecting} = 1;
|
||||
|
||||
$self->_event('on_disconnect', $code, $reason);
|
||||
|
||||
my $data = '';
|
||||
if (defined $code || defined $reason) {
|
||||
$code ||= 1000;
|
||||
$reason = '' unless defined $reason;
|
||||
$data = pack("na*", $code, $reason);
|
||||
}
|
||||
$self->send(close => $data) unless $self->{handshake};
|
||||
|
||||
$self->{server}->disconnect($self->{socket});
|
||||
}
|
||||
|
||||
sub send_binary {
|
||||
$_[0]->send(binary => $_[1]);
|
||||
}
|
||||
|
||||
sub send_utf8 {
|
||||
$_[0]->send(text => Encode::encode('UTF-8', $_[1]));
|
||||
}
|
||||
|
||||
sub send {
|
||||
my ($self, $type, $data) = @_;
|
||||
|
||||
if ($self->{handshake}) {
|
||||
carp "tried to send data before finishing handshake";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $frame = new Protocol::WebSocket::Frame(type => $type, max_payload_size => $self->{max_send_size});
|
||||
$frame->append($data) if defined $data;
|
||||
|
||||
my $bytes = eval { $frame->to_bytes };
|
||||
if (!defined $bytes) {
|
||||
carp "error while building message: $@" if $@;
|
||||
return;
|
||||
}
|
||||
|
||||
syswrite($self->{socket}, $bytes);
|
||||
}
|
||||
|
||||
sub recv {
|
||||
my ($self) = @_;
|
||||
|
||||
if ($self->{needs_ssl}) {
|
||||
my $ssl_done = $self->{socket}->accept_SSL;
|
||||
if ($self->{socket}->errstr) {
|
||||
$self->disconnect;
|
||||
return;
|
||||
}
|
||||
return unless $ssl_done;
|
||||
$self->{needs_ssl} = 0;
|
||||
}
|
||||
|
||||
my ($len, $data) = (0, "");
|
||||
if (!($len = sysread($self->{socket}, $data, 8192))) {
|
||||
$self->disconnect();
|
||||
return;
|
||||
}
|
||||
|
||||
# read remaining data
|
||||
$len = sysread($self->{socket}, $data, 8192, length($data)) while $len >= 8192;
|
||||
|
||||
if ($self->{handshake}) {
|
||||
$self->{handshake}->parse($data);
|
||||
if ($self->{handshake}->error) {
|
||||
$self->disconnect(1002);
|
||||
} elsif ($self->{handshake}->is_done) {
|
||||
$self->_event(on_handshake => $self->{handshake});
|
||||
return unless do { local $SIG{__WARN__} = sub{}; $self->{socket}->connected };
|
||||
|
||||
syswrite($self->{socket}, $self->{handshake}->to_string);
|
||||
delete $self->{handshake};
|
||||
|
||||
$self->{parser} = new Protocol::WebSocket::Frame(max_payload_size => $self->{max_recv_size});
|
||||
setsockopt($self->{socket}, IPPROTO_TCP, TCP_NODELAY, 1) if $self->{nodelay};
|
||||
$self->_event('on_ready');
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{parser}->append($data);
|
||||
|
||||
my $bytes;
|
||||
while (defined ($bytes = eval { $self->{parser}->next_bytes })) {
|
||||
if ($self->{parser}->is_binary) {
|
||||
$self->_event(on_binary => $bytes);
|
||||
} elsif ($self->{parser}->is_text) {
|
||||
$self->_event(on_utf8 => Encode::decode('UTF-8', $bytes));
|
||||
} elsif ($self->{parser}->is_pong) {
|
||||
$self->_event(on_pong => $bytes);
|
||||
} elsif ($self->{parser}->is_close) {
|
||||
$self->disconnect(length $bytes ? unpack("na*",$bytes) : ());
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
if ($@) {
|
||||
$self->disconnect(1002);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
### internal methods
|
||||
|
||||
sub _event {
|
||||
my ($self, $event, @args) = @_;
|
||||
$self->{$event}($self, @args);
|
||||
}
|
||||
|
||||
1; # End of Net::WebSocket::Server
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::WebSocket::Server::Connection - A WebSocket connection managed by L<Net::WebSocket::Server|Net::WebSocket::Server>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Within the L<connect|Net::WebSocket::Server/connect> callback of a
|
||||
L<Net::WebSocket::Server>,
|
||||
|
||||
$conn->on(
|
||||
utf8 => sub {
|
||||
my ($conn, $msg) = @_;
|
||||
$conn->send_utf8($msg);
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an interface to a WebSocket connection including
|
||||
handshakes and sending / receiving messages. It is constructed by a running
|
||||
L<Net::WebSocket::Server|Net::WebSocket::Server> and passed to the registered
|
||||
L<connect|Net::WebSocket::Server/connect> handler there for configuration.
|
||||
|
||||
=head1 CONSTRUCTION
|
||||
|
||||
=over
|
||||
|
||||
=item C<< Net::WebSocket::Server::Connection->new(I<%opts>) >>
|
||||
|
||||
Creates a new C<Net::WebSocket::Server::Connection> object with the given
|
||||
configuration. This is typically done for you by
|
||||
L<Net::WebSocket::Server|Net::WebSocket::Server>; you rarely need to construct
|
||||
your own explicitly. Takes the following parameters:
|
||||
|
||||
=over
|
||||
|
||||
=item C<socket>
|
||||
|
||||
The underlying L<IO::Socket|IO::Socket>-like object. Once set, this cannot be
|
||||
changed. Required.
|
||||
|
||||
=item C<server>
|
||||
|
||||
The associated L<Net::WebSocket::Server|Net::WebSocket::Server> object. Once
|
||||
set, this cannot be changed. Required.
|
||||
|
||||
=item C<nodelay>
|
||||
|
||||
A boolean value indicating whether C<TCP_NODELAY> should be set on the socket
|
||||
after the handshake is complete. Default C<1>. See L<nodelay()|/nodelay([$enable])>.
|
||||
|
||||
=item C<max_send_size>
|
||||
|
||||
The maximum size of an outgoing payload. Default
|
||||
C<< Protocol::WebSocket::Frame->new->{max_payload_size} >>.
|
||||
|
||||
When building an outgoing message, this value is passed to new instances of
|
||||
L<Protocol::WebSocket::Frame|Protocol::WebSocket::Frame> as the
|
||||
C<max_payload_size> parameter.
|
||||
|
||||
=item C<max_recv_size>
|
||||
|
||||
The maximum size of an incoming payload. Default
|
||||
C<< Protocol::WebSocket::Frame->new->{max_payload_size} >>.
|
||||
|
||||
Once the handshake process is complete, this value is passed to the parser
|
||||
instance of L<Protocol::WebSocket::Frame|Protocol::WebSocket::Frame> as the
|
||||
C<max_payload_size> parameter.
|
||||
|
||||
=item C<on_C<$event>>
|
||||
|
||||
The callback to invoke when the given C<$event> occurs, such as C<ready>. See
|
||||
L</EVENTS>.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item C<on(I<%events>)>
|
||||
|
||||
$connection->on(
|
||||
utf8 => sub { ... },
|
||||
),
|
||||
|
||||
Takes a list of C<< $event => $callback >> pairs; C<$event> names should not
|
||||
include an C<on_> prefix. See L</EVENTS>.
|
||||
|
||||
=item C<server()>
|
||||
|
||||
Returns the associated L<Net::WebSocket::Server|Net::WebSocket::Server> object.
|
||||
|
||||
=item C<socket()>
|
||||
|
||||
Returns the underlying socket object.
|
||||
|
||||
=item C<is_ready()>
|
||||
|
||||
Returns true if the connection is fully established and ready for data, or
|
||||
false if the connection is in the middle of the handshake process.
|
||||
|
||||
=item C<ip()>
|
||||
|
||||
Returns the remote IP of the connection.
|
||||
|
||||
=item C<port()>
|
||||
|
||||
Returns the remote TCP port of the connection. (This will be some high-numbered
|
||||
port chosen by the remote host; it can be useful during debugging to help humans
|
||||
tell apart connections from the same IP.)
|
||||
|
||||
=item C<nodelay([I<$enable>])>
|
||||
|
||||
A boolean value indicating whether C<TCP_NODELAY> should be set on the socket
|
||||
after the handshake is complete. If the handshake is already complete,
|
||||
immediately modifies the socket's C<TCP_NODELAY> setting.
|
||||
|
||||
This setting indicates to the operating system that small packets should not be
|
||||
delayed for bundling into fewer, larger packets, but should instead be sent
|
||||
immediately. While enabling this setting can incur additional strain on the
|
||||
network, it tends to be the desired behavior for WebSocket servers, so it is
|
||||
enabled by default.
|
||||
|
||||
=item C<max_send_size([I<$size>])>
|
||||
|
||||
Sets the maximum allowed size of an outgoing payload. Returns the current or
|
||||
newly-set value.
|
||||
|
||||
When building an outgoing message, this value is passed to new instances of
|
||||
L<Protocol::WebSocket::Frame|Protocol::WebSocket::Frame> as the
|
||||
C<max_payload_size> parameter.
|
||||
|
||||
=item C<max_recv_size([I<$size>])>
|
||||
|
||||
Sets the maximum allowed size of an incoming payload. Returns the current or
|
||||
newly-set value.
|
||||
|
||||
Once the handshake process is complete, this value is passed to the parser
|
||||
instance of L<Protocol::WebSocket::Frame|Protocol::WebSocket::Frame> as the
|
||||
C<max_payload_size> parameter.
|
||||
|
||||
This value cannot be modified once the handshake is completed.
|
||||
|
||||
=item C<disconnect(I<$code>, I<$reason>)>
|
||||
|
||||
Invokes the registered C<disconnect> handler, sends a C<close> packet with the
|
||||
given C<$code> and C<$reason>, and disconnects the socket.
|
||||
|
||||
=item C<send_utf8(I<$message>)>
|
||||
|
||||
Sends a C<utf8> message with the given content. The message will be
|
||||
UTF8-encoded automatically.
|
||||
|
||||
=item C<send_binary(I<$message>)>
|
||||
|
||||
Sends a C<binary> message with the given content.
|
||||
|
||||
=item C<send(I<$type>, I<$raw_data>)>
|
||||
|
||||
Sends a message with the given type and content. Typically, one should use the
|
||||
L<send_utf8()|/send_utf8> and L<send_binary()|/send_binary> methods instead.
|
||||
|
||||
=item C<recv()>
|
||||
|
||||
Attempts to read from the socket, invoking callbacks for any received messages.
|
||||
The associated L<Net::WebSocket::Server|Net::WebSocket::Server> will call this
|
||||
automatically when data is ready to be read.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
Attach a callback for an event by either passing C<on_$event> parameters to the
|
||||
L<constructor|/CONSTRUCTION> or by passing C<$event> parameters to the L<on()|/on> method.
|
||||
|
||||
=over
|
||||
|
||||
=item C<handshake(I<$connection>, I<$handshake>)>
|
||||
|
||||
Invoked when a handshake message has been received from the client; the
|
||||
C<$handshake> parameter is the underlying
|
||||
L<Protocol::WebSocket::Handshake::Server|Protocol::WebSocket::Handshake::Server>
|
||||
object. Use this event to inspect the handshake origin, cookies, etc for
|
||||
validity. To abort the handshake process, call
|
||||
L<< $connection->disconnect()|/disconnect >>.
|
||||
|
||||
For example:
|
||||
|
||||
if ($handshake->req->origin ne $expected_origin) {
|
||||
$connection->disconnect();
|
||||
return;
|
||||
}
|
||||
|
||||
if ($handshake->req->subprotocol ne $expected_subprotocol) {
|
||||
$connection->disconnect();
|
||||
return;
|
||||
}
|
||||
|
||||
=item C<ready(I<$connection>)>
|
||||
|
||||
Invoked when the handshake has been completed and the connection is ready to
|
||||
send and receive WebSocket messages. Use this event to perform any final
|
||||
initialization or for the earliest chance to send messages to the client.
|
||||
|
||||
=item C<disconnect(I<$connection>, I<$code>, I<$reason>)>
|
||||
|
||||
Invoked when the connection is disconnected for any reason. The C<$code> and
|
||||
C<$reason>, if any, are also provided. Use this event for last-minute cleanup
|
||||
of the connection, but by this point it may not be safe to assume that sent
|
||||
messages will be received.
|
||||
|
||||
=item C<utf8(I<$connection>, I<$message>)>
|
||||
|
||||
Invoked when a C<utf8> message is received from the client. The C<$message>,
|
||||
if any, is decoded and provided.
|
||||
|
||||
=item C<binary(I<$connection>, I<$message>)>
|
||||
|
||||
Invoked when a C<binary> message is received from the client. The C<$message>,
|
||||
if any, is provided.
|
||||
|
||||
=item C<pong(I<$connection>, I<$message>)>
|
||||
|
||||
Invoked when a C<pong> message is received from the client. The C<$message>,
|
||||
if any, is provided. If the associated
|
||||
L<Net::WebSocket::Server|Net::WebSocket::Server> object is configured with a
|
||||
nonzero L<silence_max|Net::WebSocket::Server/silence_max>, this event will
|
||||
also occur in response to the C<ping> messages automatically sent to keep the
|
||||
connection alive.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eric Wastl, C<< <topaz at cpan.org> >>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Net::WebSocket::Server|Net::WebSocket::Server>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2013 Eric Wastl.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the the Artistic License (2.0). You may obtain a
|
||||
copy of the full license at:
|
||||
|
||||
L<http://www.perlfoundation.org/artistic_license_2_0>
|
||||
|
||||
Any use, modification, and distribution of the Standard or Modified
|
||||
Versions is governed by this Artistic License. By using, modifying or
|
||||
distributing the Package, you accept this license. Do not use, modify,
|
||||
or distribute the Package, if you do not accept this license.
|
||||
|
||||
If your Modified Version has been derived from a Modified Version made
|
||||
by someone other than you, you are nevertheless required to ensure that
|
||||
your Modified Version complies with the requirements of this license.
|
||||
|
||||
This license does not grant you the right to use any trademark, service
|
||||
mark, tradename, or logo of the Copyright Holder.
|
||||
|
||||
This license includes the non-exclusive, worldwide, free-of-charge
|
||||
patent license to make, have made, use, offer to sell, sell, import and
|
||||
otherwise transfer the Package with respect to any patent claims
|
||||
licensable by the Copyright Holder that are necessarily infringed by the
|
||||
Package. If you institute patent litigation (including a cross-claim or
|
||||
counterclaim) against any party alleging that the Package constitutes
|
||||
direct or contributory patent infringement, then this Artistic License
|
||||
to you shall terminate on the date that such litigation is filed.
|
||||
|
||||
Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
|
||||
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
|
||||
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
|
||||
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
|
||||
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
|
||||
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
|
||||
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
|
||||
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
156
xterm/lib/Protocol/WebSocket.pm
Normal file
156
xterm/lib/Protocol/WebSocket.pm
Normal file
@@ -0,0 +1,156 @@
|
||||
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
|
||||
174
xterm/lib/Protocol/WebSocket/Client.pm
Normal file
174
xterm/lib/Protocol/WebSocket/Client.pm
Normal file
@@ -0,0 +1,174 @@
|
||||
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
|
||||
92
xterm/lib/Protocol/WebSocket/Cookie.pm
Normal file
92
xterm/lib/Protocol/WebSocket/Cookie.pm
Normal file
@@ -0,0 +1,92 @@
|
||||
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
|
||||
97
xterm/lib/Protocol/WebSocket/Cookie/Request.pm
Normal file
97
xterm/lib/Protocol/WebSocket/Cookie/Request.pm
Normal file
@@ -0,0 +1,97 @@
|
||||
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
|
||||
84
xterm/lib/Protocol/WebSocket/Cookie/Response.pm
Normal file
84
xterm/lib/Protocol/WebSocket/Cookie/Response.pm
Normal file
@@ -0,0 +1,84 @@
|
||||
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
|
||||
474
xterm/lib/Protocol/WebSocket/Frame.pm
Normal file
474
xterm/lib/Protocol/WebSocket/Frame.pm
Normal file
@@ -0,0 +1,474 @@
|
||||
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
|
||||
70
xterm/lib/Protocol/WebSocket/Handshake.pm
Normal file
70
xterm/lib/Protocol/WebSocket/Handshake.pm
Normal file
@@ -0,0 +1,70 @@
|
||||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Handshake - Base WebSocket Handshake class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a base class for L<Protocol::WebSocket::Handshake::Client> and
|
||||
L<Protocol::WebSocket::Handshake::Server>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<error>
|
||||
|
||||
$handshake->error;
|
||||
|
||||
Set or get handshake error.
|
||||
|
||||
=head2 C<version>
|
||||
|
||||
$handshake->version;
|
||||
|
||||
Set or get handshake version.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Handshake> instance.
|
||||
|
||||
=head2 C<req>
|
||||
|
||||
$handshake->req;
|
||||
|
||||
WebSocket request object.
|
||||
|
||||
=head2 C<res>
|
||||
|
||||
$handshake->res;
|
||||
|
||||
WebSocket response object.
|
||||
|
||||
=cut
|
||||
152
xterm/lib/Protocol/WebSocket/Handshake/Client.pm
Normal file
152
xterm/lib/Protocol/WebSocket/Handshake/Client.pm
Normal file
@@ -0,0 +1,152 @@
|
||||
package Protocol::WebSocket::Handshake::Client;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Protocol::WebSocket::Handshake';
|
||||
|
||||
require Carp;
|
||||
|
||||
use Protocol::WebSocket::URL;
|
||||
use Protocol::WebSocket::Frame;
|
||||
|
||||
sub new {
|
||||
my $self = shift->SUPER::new(@_);
|
||||
|
||||
$self->_set_url($self->{url}) if defined $self->{url};
|
||||
|
||||
if (my $version = $self->{version}) {
|
||||
$self->req->version($version);
|
||||
$self->res->version($version);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub url {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
|
||||
return $self->{url} unless $url;
|
||||
|
||||
$self->_set_url($url);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $req = $self->req;
|
||||
my $res = $self->res;
|
||||
|
||||
unless ($res->is_done) {
|
||||
unless ($res->parse($_[0])) {
|
||||
$self->error($res->error);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($res->is_done) {
|
||||
if ( $req->version eq 'draft-ietf-hybi-00'
|
||||
&& $req->checksum ne $res->checksum)
|
||||
{
|
||||
$self->error('Checksum is wrong.');
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is_done { shift->res->is_done }
|
||||
sub to_string { shift->req->to_string }
|
||||
|
||||
sub build_frame {
|
||||
my $self = shift;
|
||||
|
||||
return Protocol::WebSocket::Frame->new(masked => 1, version => $self->version, @_);
|
||||
}
|
||||
|
||||
sub _build_url { Protocol::WebSocket::URL->new }
|
||||
|
||||
sub _set_url {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
|
||||
$url = $self->_build_url->parse($url) unless ref $url;
|
||||
|
||||
$self->req->secure(1) if $url->secure;
|
||||
|
||||
my $req = $self->req;
|
||||
|
||||
my $host = $url->host;
|
||||
$host .= ':' . $url->port
|
||||
if defined $url->port
|
||||
&& ($url->secure ? $url->port ne '443' : $url->port ne '80');
|
||||
$req->host($host);
|
||||
|
||||
$req->resource_name($url->resource_name);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Handshake::Client - WebSocket Client Handshake
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $h =
|
||||
Protocol::WebSocket::Handshake::Client->new(url => 'ws://example.com');
|
||||
|
||||
# Create request
|
||||
$h->to_string;
|
||||
|
||||
# Parse server response
|
||||
$h->parse(<<"EOF");
|
||||
WebSocket HTTP message
|
||||
EOF
|
||||
|
||||
$h->error; # Check if there were any errors
|
||||
$h->is_done; # Returns 1
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Construct or parse a client WebSocket handshake. This module is written for
|
||||
convenience, since using request and response directly requires the same code
|
||||
again and again.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<url>
|
||||
|
||||
$handshake->url('ws://example.com/demo');
|
||||
|
||||
Set or get WebSocket url.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Handshake::Client> instance.
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
$handshake->parse($buffer);
|
||||
|
||||
Parse a WebSocket server response. Returns C<undef> and sets C<error> attribute
|
||||
on error. Buffer is modified.
|
||||
|
||||
=head2 C<to_string>
|
||||
|
||||
Construct a WebSocket client request.
|
||||
|
||||
=head2 C<is_done>
|
||||
|
||||
Check whether handshake is done.
|
||||
|
||||
=cut
|
||||
161
xterm/lib/Protocol/WebSocket/Handshake/Server.pm
Normal file
161
xterm/lib/Protocol/WebSocket/Handshake/Server.pm
Normal file
@@ -0,0 +1,161 @@
|
||||
package Protocol::WebSocket::Handshake::Server;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Protocol::WebSocket::Handshake';
|
||||
|
||||
use Protocol::WebSocket::Request;
|
||||
use Protocol::WebSocket::Frame;
|
||||
|
||||
sub new_from_psgi {
|
||||
my $class = shift;
|
||||
|
||||
my $req = Protocol::WebSocket::Request->new_from_psgi(@_);
|
||||
my $self = $class->new(req => $req);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $req = $self->req;
|
||||
my $res = $self->res;
|
||||
|
||||
return 1 if $req->is_done;
|
||||
|
||||
unless ($req->parse($_[0])) {
|
||||
$self->error($req->error);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($req->is_body || $req->is_done) {
|
||||
$res->version($req->version);
|
||||
$res->host($req->host);
|
||||
|
||||
$res->secure($req->secure);
|
||||
$res->resource_name($req->resource_name);
|
||||
$res->origin($req->origin);
|
||||
}
|
||||
|
||||
if ($req->version eq 'draft-ietf-hybi-00') {
|
||||
if ($self->is_done) {
|
||||
$res->checksum(undef);
|
||||
$res->number1($req->number1);
|
||||
$res->number2($req->number2);
|
||||
$res->challenge($req->challenge);
|
||||
}
|
||||
else {
|
||||
$res->checksum('');
|
||||
}
|
||||
}
|
||||
elsif ($self->is_done && $req->version eq 'draft-ietf-hybi-10'
|
||||
|| $req->version eq 'draft-ietf-hybi-17')
|
||||
{
|
||||
$res->key($req->key);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is_body { shift->req->is_body }
|
||||
sub is_done { shift->req->is_done }
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->is_body) {
|
||||
return $self->{partial} = $self->res->to_string;
|
||||
}
|
||||
elsif ($self->{partial}) {
|
||||
my $to_string = $self->res->to_string;
|
||||
|
||||
$to_string =~ s/^\Q$self->{partial}\E//;
|
||||
|
||||
return $to_string;
|
||||
}
|
||||
|
||||
return $self->res->to_string;
|
||||
}
|
||||
|
||||
sub build_frame {
|
||||
my $self = shift;
|
||||
|
||||
return Protocol::WebSocket::Frame->new(version => $self->version, @_);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Handshake::Server - WebSocket Server Handshake
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $h = Protocol::WebSocket::Handshake::Server->new;
|
||||
|
||||
# Parse client request
|
||||
$h->parse(<<"EOF");
|
||||
WebSocket HTTP message
|
||||
EOF
|
||||
|
||||
$h->error; # Check if there were any errors
|
||||
$h->is_done; # Returns 1
|
||||
|
||||
# Create response
|
||||
$h->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Construct or parse a server WebSocket handshake. This module is written for
|
||||
convenience, since using request and response directly requires the same code
|
||||
again and again.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Handshake::Server> instance.
|
||||
|
||||
=head2 C<new_from_psgi>
|
||||
|
||||
my $env = {
|
||||
HTTP_HOST => 'example.com',
|
||||
HTTP_CONNECTION => 'Upgrade',
|
||||
...
|
||||
};
|
||||
my $handshake = Protocol::WebSocket::Handshake::Server->new_from_psgi($env);
|
||||
|
||||
Create a new L<Protocol::WebSocket::Handshake::Server> instance from L<PSGI>
|
||||
environment.
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
$handshake->parse($buffer);
|
||||
$handshake->parse($handle);
|
||||
|
||||
Parse a WebSocket client request. Returns C<undef> and sets C<error> attribute
|
||||
on error.
|
||||
|
||||
When buffer is passed it's modified (unless readonly).
|
||||
|
||||
=head2 C<build_frame>
|
||||
|
||||
$handshake->build_frame;
|
||||
|
||||
Builds L<Protocol::WebSocket::Frame> with an appropriate version.
|
||||
|
||||
=head2 C<to_string>
|
||||
|
||||
Construct a WebSocket server response.
|
||||
|
||||
=head2 C<is_body>
|
||||
|
||||
Check whether handshake is in body state.
|
||||
|
||||
=head2 C<is_done>
|
||||
|
||||
Check whether handshake is done.
|
||||
|
||||
=cut
|
||||
248
xterm/lib/Protocol/WebSocket/Message.pm
Normal file
248
xterm/lib/Protocol/WebSocket/Message.pm
Normal file
@@ -0,0 +1,248 @@
|
||||
package Protocol::WebSocket::Message;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Protocol::WebSocket::Stateful';
|
||||
|
||||
use Scalar::Util qw(readonly);
|
||||
require Digest::MD5;
|
||||
|
||||
our $MAX_MESSAGE_SIZE = 10 * 2048;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
|
||||
my $self = {@_};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{version} ||= '';
|
||||
|
||||
$self->{buffer} = '';
|
||||
|
||||
$self->{fields} ||= {};
|
||||
|
||||
$self->{max_message_size} ||= $MAX_MESSAGE_SIZE;
|
||||
|
||||
$self->{cookies} ||= [];
|
||||
|
||||
$self->state('first_line');
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub secure { @_ > 1 ? $_[0]->{secure} = $_[1] : $_[0]->{secure} }
|
||||
|
||||
sub fields { shift->{fields} }
|
||||
|
||||
sub field {
|
||||
my $self = shift;
|
||||
my $name = lc shift;
|
||||
|
||||
return $self->fields->{$name} unless @_;
|
||||
|
||||
$self->fields->{$name} = $_[0];
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{error} unless @_;
|
||||
|
||||
my $error = shift;
|
||||
$self->{error} = $error;
|
||||
$self->state('error');
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub subprotocol {
|
||||
@_ > 1 ? $_[0]->{subprotocol} = $_[1] : $_[0]->{subprotocol};
|
||||
}
|
||||
|
||||
sub host { @_ > 1 ? $_[0]->{host} = $_[1] : $_[0]->{host} }
|
||||
sub origin { @_ > 1 ? $_[0]->{origin} = $_[1] : $_[0]->{origin} }
|
||||
|
||||
sub version { @_ > 1 ? $_[0]->{version} = $_[1] : $_[0]->{version} }
|
||||
|
||||
sub number1 { @_ > 1 ? $_[0]->{number1} = $_[1] : $_[0]->{number1} }
|
||||
sub number2 { @_ > 1 ? $_[0]->{number2} = $_[1] : $_[0]->{number2} }
|
||||
sub challenge { @_ > 1 ? $_[0]->{challenge} = $_[1] : $_[0]->{challenge} }
|
||||
|
||||
sub checksum {
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
$self->{checksum} = $_[0];
|
||||
return $self;
|
||||
}
|
||||
|
||||
return $self->{checksum} if defined $self->{checksum};
|
||||
|
||||
Carp::croak(qq/number1 is required/) unless defined $self->number1;
|
||||
Carp::croak(qq/number2 is required/) unless defined $self->number2;
|
||||
Carp::croak(qq/challenge is required/) unless defined $self->challenge;
|
||||
|
||||
my $checksum = '';
|
||||
$checksum .= pack 'N' => $self->number1;
|
||||
$checksum .= pack 'N' => $self->number2;
|
||||
$checksum .= $self->challenge;
|
||||
$checksum = Digest::MD5::md5($checksum);
|
||||
|
||||
return $self->{checksum} ||= $checksum;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
return 1 unless defined $_[0];
|
||||
|
||||
return if $self->error;
|
||||
|
||||
return unless $self->_append(@_);
|
||||
|
||||
while (!$self->is_state('body') && defined(my $line = $self->_get_line)) {
|
||||
if ($self->state eq 'first_line') {
|
||||
return unless defined $self->_parse_first_line($line);
|
||||
|
||||
$self->state('fields');
|
||||
}
|
||||
elsif ($line ne '') {
|
||||
return unless defined $self->_parse_field($line);
|
||||
}
|
||||
else {
|
||||
$self->state('body');
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return 1 unless $self->is_state('body');
|
||||
|
||||
my $rv = $self->_parse_body;
|
||||
return unless defined $rv;
|
||||
|
||||
# Need more data
|
||||
return $rv unless ref $rv;
|
||||
|
||||
$_[0] = $self->{buffer} unless readonly $_[0] || ref $_[0];
|
||||
return $self->done;
|
||||
}
|
||||
|
||||
sub _extract_number {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
|
||||
my $number = join '' => $key =~ m/\d+/g;
|
||||
my $spaces = $key =~ s/ / /g;
|
||||
|
||||
return if $spaces == 0;
|
||||
|
||||
return int($number / $spaces);
|
||||
}
|
||||
|
||||
sub _append {
|
||||
my $self = shift;
|
||||
|
||||
return if $self->error;
|
||||
|
||||
if (ref $_[0]) {
|
||||
$_[0]->read(my $buf, $self->{max_message_size});
|
||||
$self->{buffer} .= $buf;
|
||||
}
|
||||
else {
|
||||
$self->{buffer} .= $_[0];
|
||||
$_[0] = '' unless readonly $_[0];
|
||||
}
|
||||
|
||||
if (length $self->{buffer} > $self->{max_message_size}) {
|
||||
$self->error('Message is too long');
|
||||
return;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _get_line {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->{buffer} =~ s/^(.*?)\x0d?\x0a//) {
|
||||
return $1;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _parse_first_line {shift}
|
||||
|
||||
sub _parse_field {
|
||||
my $self = shift;
|
||||
my $line = shift;
|
||||
|
||||
my ($name, $value) = split /:\s*/ => $line => 2;
|
||||
unless (defined $name && defined $value) {
|
||||
$self->error('Invalid field');
|
||||
return;
|
||||
}
|
||||
|
||||
#$name =~ s/^Sec-WebSocket-Origin$/Origin/i; # FIXME
|
||||
$self->field($name => $value);
|
||||
|
||||
if ($name =~ m/^x-forwarded-proto$/i) {
|
||||
$self->secure(1);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _parse_body {shift}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Message - Base class for WebSocket request and response
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A base class for L<Protocol::WebSocket::Request> and
|
||||
L<Protocol::WebSocket::Response>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<version>
|
||||
|
||||
=head2 C<fields>
|
||||
|
||||
=head2 C<field>
|
||||
|
||||
=head2 C<host>
|
||||
|
||||
=head2 C<origin>
|
||||
|
||||
=head2 C<secure>
|
||||
|
||||
=head2 C<subprotocol>
|
||||
|
||||
=head2 C<error>
|
||||
|
||||
=head2 C<number1>
|
||||
|
||||
=head2 C<number2>
|
||||
|
||||
=head2 C<challenge>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Message> instance.
|
||||
|
||||
=head2 C<checksum>
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
=cut
|
||||
530
xterm/lib/Protocol/WebSocket/Request.pm
Normal file
530
xterm/lib/Protocol/WebSocket/Request.pm
Normal file
@@ -0,0 +1,530 @@
|
||||
package Protocol::WebSocket::Request;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Protocol::WebSocket::Message';
|
||||
|
||||
require Carp;
|
||||
use MIME::Base64 ();
|
||||
|
||||
use Protocol::WebSocket::Cookie::Request;
|
||||
|
||||
sub new {
|
||||
my $self = shift->SUPER::new(@_);
|
||||
my (%params) = @_;
|
||||
|
||||
$self->{headers} = $params{headers} || [];
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub new_from_psgi {
|
||||
my $class = shift;
|
||||
my $env = @_ > 1 ? {@_} : shift;
|
||||
|
||||
Carp::croak('env is required') unless keys %$env;
|
||||
|
||||
my $version = '';
|
||||
|
||||
my $cookies;
|
||||
|
||||
my $fields = {
|
||||
upgrade => $env->{HTTP_UPGRADE},
|
||||
connection => $env->{HTTP_CONNECTION},
|
||||
host => $env->{HTTP_HOST},
|
||||
};
|
||||
|
||||
if ($env->{HTTP_WEBSOCKET_PROTOCOL}) {
|
||||
$fields->{'websocket-protocol'} =
|
||||
$env->{HTTP_WEBSOCKET_PROTOCOL};
|
||||
}
|
||||
elsif ($env->{HTTP_SEC_WEBSOCKET_PROTOCOL}) {
|
||||
$fields->{'sec-websocket-protocol'} =
|
||||
$env->{HTTP_SEC_WEBSOCKET_PROTOCOL};
|
||||
}
|
||||
|
||||
if (exists $env->{HTTP_SEC_WEBSOCKET_VERSION}) {
|
||||
$fields->{'sec-websocket-version'} =
|
||||
$env->{HTTP_SEC_WEBSOCKET_VERSION};
|
||||
if ($env->{HTTP_SEC_WEBSOCKET_VERSION} eq '13') {
|
||||
$version = 'draft-ietf-hybi-17';
|
||||
}
|
||||
else {
|
||||
$version = 'draft-ietf-hybi-10';
|
||||
}
|
||||
}
|
||||
|
||||
if ($env->{HTTP_SEC_WEBSOCKET_KEY}) {
|
||||
$fields->{'sec-websocket-key'} = $env->{HTTP_SEC_WEBSOCKET_KEY};
|
||||
}
|
||||
elsif ($env->{HTTP_SEC_WEBSOCKET_KEY1}) {
|
||||
$version = 'draft-ietf-hybi-00';
|
||||
$fields->{'sec-websocket-key1'} = $env->{HTTP_SEC_WEBSOCKET_KEY1};
|
||||
$fields->{'sec-websocket-key2'} = $env->{HTTP_SEC_WEBSOCKET_KEY2};
|
||||
}
|
||||
|
||||
if ($version eq 'draft-ietf-hybi-10') {
|
||||
$fields->{'sec-websocket-origin'} = $env->{HTTP_SEC_WEBSOCKET_ORIGIN};
|
||||
}
|
||||
else {
|
||||
$fields->{origin} = $env->{HTTP_ORIGIN};
|
||||
}
|
||||
|
||||
if ($env->{HTTP_COOKIE}) {
|
||||
$cookies = Protocol::WebSocket::Cookie->new->parse($env->{HTTP_COOKIE});
|
||||
}
|
||||
|
||||
my $self = $class->new(
|
||||
version => $version,
|
||||
fields => $fields,
|
||||
cookies => $cookies,
|
||||
resource_name => "$env->{SCRIPT_NAME}$env->{PATH_INFO}"
|
||||
. ($env->{QUERY_STRING} ? "?$env->{QUERY_STRING}" : "")
|
||||
);
|
||||
$self->state('body');
|
||||
|
||||
if ( $env->{HTTP_X_FORWARDED_PROTO}
|
||||
&& $env->{HTTP_X_FORWARDED_PROTO} eq 'https')
|
||||
{
|
||||
$self->secure(1);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub cookies {
|
||||
if(@_ > 1) {
|
||||
my $cookie = Protocol::WebSocket::Cookie->new;
|
||||
return unless $_[1];
|
||||
|
||||
if (my $cookies = $cookie->parse($_[1])) {
|
||||
$_[0]->{cookies} = $cookies;
|
||||
}
|
||||
} else {
|
||||
return $_[0]->{cookies};
|
||||
}
|
||||
}
|
||||
|
||||
sub resource_name {
|
||||
@_ > 1 ? $_[0]->{resource_name} = $_[1] : $_[0]->{resource_name} || '/';
|
||||
}
|
||||
|
||||
sub upgrade { shift->field('Upgrade') }
|
||||
sub connection { shift->field('Connection') }
|
||||
|
||||
sub number1 { shift->_number('number1', 'key1', @_) }
|
||||
sub number2 { shift->_number('number2', 'key2', @_) }
|
||||
|
||||
sub key { shift->_key('key' => @_) }
|
||||
sub key1 { shift->_key('key1' => @_) }
|
||||
sub key2 { shift->_key('key2' => @_) }
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
my $version = $self->version || 'draft-ietf-hybi-17';
|
||||
|
||||
my $string = '';
|
||||
|
||||
Carp::croak(qq/resource_name is required/)
|
||||
unless defined $self->resource_name;
|
||||
$string .= "GET " . $self->resource_name . " HTTP/1.1\x0d\x0a";
|
||||
|
||||
$string .= "Upgrade: WebSocket\x0d\x0a";
|
||||
$string .= "Connection: Upgrade\x0d\x0a";
|
||||
|
||||
Carp::croak(qq/Host is required/) unless defined $self->host;
|
||||
$string .= "Host: " . $self->host . "\x0d\x0a";
|
||||
|
||||
if (ref $self->{cookies} eq 'Protocol::WebSocket::Cookie') {
|
||||
my $cookie_string = $self->{cookies}->to_string;
|
||||
$string .= 'Cookie: ' . $cookie_string . "\x0d\x0a"
|
||||
if $cookie_string;
|
||||
}
|
||||
|
||||
my $origin = $self->origin ? $self->origin : 'http://' . $self->host;
|
||||
$origin =~ s{^http:}{https:} if $self->secure;
|
||||
$string .= (
|
||||
$version eq 'draft-ietf-hybi-10'
|
||||
? "Sec-WebSocket-Origin"
|
||||
: "Origin"
|
||||
)
|
||||
. ': '
|
||||
. $origin
|
||||
. "\x0d\x0a";
|
||||
|
||||
if ($version eq 'draft-ietf-hybi-10' || $version eq 'draft-ietf-hybi-17') {
|
||||
my $key = $self->key;
|
||||
|
||||
if (!$key) {
|
||||
$key = '';
|
||||
$key .= chr(int(rand(256))) for 1 .. 16;
|
||||
|
||||
$key = MIME::Base64::encode_base64($key);
|
||||
$key =~ s{\s+}{}g;
|
||||
}
|
||||
|
||||
$string
|
||||
.= 'Sec-WebSocket-Protocol: ' . $self->subprotocol . "\x0d\x0a"
|
||||
if defined $self->subprotocol;
|
||||
|
||||
$string .= 'Sec-WebSocket-Key: ' . $key . "\x0d\x0a";
|
||||
$string
|
||||
.= 'Sec-WebSocket-Version: '
|
||||
. ($version eq 'draft-ietf-hybi-17' ? 13 : 8)
|
||||
. "\x0d\x0a";
|
||||
}
|
||||
elsif ($version eq 'draft-ietf-hybi-00') {
|
||||
$self->_generate_keys;
|
||||
|
||||
$string
|
||||
.= 'Sec-WebSocket-Protocol: ' . $self->subprotocol . "\x0d\x0a"
|
||||
if defined $self->subprotocol;
|
||||
|
||||
$string .= 'Sec-WebSocket-Key1: ' . $self->key1 . "\x0d\x0a";
|
||||
$string .= 'Sec-WebSocket-Key2: ' . $self->key2 . "\x0d\x0a";
|
||||
|
||||
$string .= 'Content-Length: ' . length($self->challenge) . "\x0d\x0a";
|
||||
}
|
||||
elsif ($version eq 'draft-hixie-75') {
|
||||
$string .= 'WebSocket-Protocol: ' . $self->subprotocol . "\x0d\x0a"
|
||||
if defined $self->subprotocol;
|
||||
}
|
||||
else {
|
||||
Carp::croak('Version ' . $self->version . ' is not supported');
|
||||
}
|
||||
my @headers = @{$self->{headers}};
|
||||
while (my ($key, $value) = splice @headers, 0, 2) {
|
||||
$key =~ s{[\x0d\x0a]}{}gsm;
|
||||
$value =~ s{[\x0d\x0a]}{}gsm;
|
||||
|
||||
$string .= "$key: $value\x0d\x0a";
|
||||
}
|
||||
|
||||
$string .= "\x0d\x0a";
|
||||
|
||||
$string .= $self->challenge if $version eq 'draft-ietf-hybi-00';
|
||||
|
||||
return $string;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $retval = $self->SUPER::parse($_[0]);
|
||||
|
||||
if (!$self->{finalized} && ($self->is_body || $self->is_done)) {
|
||||
$self->{finalized} = 1;
|
||||
|
||||
if ($self->key1 && $self->key2) {
|
||||
$self->version('draft-ietf-hybi-00');
|
||||
}
|
||||
elsif ($self->key) {
|
||||
if ($self->field('sec-websocket-version') eq '13') {
|
||||
$self->version('draft-ietf-hybi-17');
|
||||
}
|
||||
else {
|
||||
$self->version('draft-ietf-hybi-10');
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->version('draft-hixie-75');
|
||||
}
|
||||
|
||||
if (!$self->_finalize) {
|
||||
$self->error('Not a valid request');
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
return $retval;
|
||||
}
|
||||
|
||||
sub _parse_first_line {
|
||||
my ($self, $line) = @_;
|
||||
|
||||
my ($req, $resource_name, $http) = split ' ' => $line;
|
||||
|
||||
unless ($req && $resource_name && $http) {
|
||||
$self->error('Wrong request line');
|
||||
return;
|
||||
}
|
||||
|
||||
unless ($req eq 'GET' && $http eq 'HTTP/1.1') {
|
||||
$self->error('Wrong method or http version');
|
||||
return;
|
||||
}
|
||||
|
||||
$self->resource_name($resource_name);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _parse_body {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->key1 && $self->key2) {
|
||||
return 1 if length $self->{buffer} < 8;
|
||||
|
||||
my $challenge = substr $self->{buffer}, 0, 8, '';
|
||||
$self->challenge($challenge);
|
||||
}
|
||||
|
||||
if (length $self->{buffer}) {
|
||||
$self->error('Leftovers');
|
||||
return;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _number {
|
||||
my $self = shift;
|
||||
my ($name, $key, $value) = @_;
|
||||
|
||||
if (defined $value) {
|
||||
$self->{$name} = $value;
|
||||
return $self;
|
||||
}
|
||||
|
||||
return $self->{$name} if defined $self->{$name};
|
||||
|
||||
return $self->{$name} ||= $self->_extract_number($self->$key);
|
||||
}
|
||||
|
||||
sub _key {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
|
||||
unless (defined $value) {
|
||||
if (my $value = delete $self->{$name}) {
|
||||
$self->field("Sec-WebSocket-" . ucfirst($name) => $value);
|
||||
}
|
||||
|
||||
return $self->field("Sec-WebSocket-" . ucfirst($name));
|
||||
}
|
||||
|
||||
$self->field("Sec-WebSocket-" . ucfirst($name) => $value);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _generate_keys {
|
||||
my $self = shift;
|
||||
|
||||
unless ($self->key1) {
|
||||
my ($number, $key) = $self->_generate_key;
|
||||
$self->number1($number);
|
||||
$self->key1($key);
|
||||
}
|
||||
|
||||
unless ($self->key2) {
|
||||
my ($number, $key) = $self->_generate_key;
|
||||
$self->number2($number);
|
||||
$self->key2($key);
|
||||
}
|
||||
|
||||
$self->challenge($self->_generate_challenge) unless $self->challenge;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _generate_key {
|
||||
my $self = shift;
|
||||
|
||||
# A random integer from 1 to 12 inclusive
|
||||
my $spaces = int(rand(12)) + 1;
|
||||
|
||||
# The largest integer not greater than 4,294,967,295 divided by spaces
|
||||
my $max = int(4_294_967_295 / $spaces);
|
||||
|
||||
# A random integer from 0 to $max inclusive
|
||||
my $number = int(rand($max + 1));
|
||||
|
||||
# The result of multiplying $number and $spaces together
|
||||
my $product = $number * $spaces;
|
||||
|
||||
# A string consisting of $product, expressed in base ten
|
||||
my $key = "$product";
|
||||
|
||||
# Insert between one and twelve random characters from the ranges U+0021
|
||||
# to U+002F and U+003A to U+007E into $key at random positions.
|
||||
my $random_characters = int(rand(12)) + 1;
|
||||
|
||||
for (1 .. $random_characters) {
|
||||
|
||||
# From 0 to the last position
|
||||
my $random_position = int(rand(length($key) + 1));
|
||||
|
||||
# Random character
|
||||
my $random_character = chr(
|
||||
int(rand(2))
|
||||
? int(rand(0x2f - 0x21 + 1)) + 0x21
|
||||
: int(rand(0x7e - 0x3a + 1)) + 0x3a
|
||||
);
|
||||
|
||||
# Insert random character at random position
|
||||
substr $key, $random_position, 0, $random_character;
|
||||
}
|
||||
|
||||
# Insert $spaces U+0020 SPACE characters into $key at random positions
|
||||
# other than the start or end of the string.
|
||||
for (1 .. $spaces) {
|
||||
|
||||
# From 1 to the last-1 position
|
||||
my $random_position = int(rand(length($key) - 1)) + 1;
|
||||
|
||||
# Insert
|
||||
substr $key, $random_position, 0, ' ';
|
||||
}
|
||||
|
||||
return ($number, $key);
|
||||
}
|
||||
|
||||
sub _generate_challenge {
|
||||
my $self = shift;
|
||||
|
||||
# A string consisting of eight random bytes (or equivalently, a random 64
|
||||
# bit integer encoded in big-endian order).
|
||||
my $challenge = '';
|
||||
|
||||
$challenge .= chr(int(rand(256))) for 1 .. 8;
|
||||
|
||||
return $challenge;
|
||||
}
|
||||
|
||||
sub _finalize {
|
||||
my $self = shift;
|
||||
|
||||
return unless $self->upgrade && lc $self->upgrade eq 'websocket';
|
||||
|
||||
my $connection = $self->connection;
|
||||
return unless $connection;
|
||||
|
||||
my @connections = split /\s*,\s*/, $connection;
|
||||
return unless grep { lc $_ eq 'upgrade' } @connections;
|
||||
|
||||
my $origin = $self->field('Sec-WebSocket-Origin') || $self->field('Origin');
|
||||
#return unless $origin;
|
||||
$self->origin($origin);
|
||||
|
||||
if (defined $self->origin) {
|
||||
$self->secure(1) if $self->origin =~ m{^https:};
|
||||
}
|
||||
|
||||
my $host = $self->field('Host');
|
||||
return unless $host;
|
||||
$self->host($host);
|
||||
|
||||
my $subprotocol = $self->field('Sec-WebSocket-Protocol')
|
||||
|| $self->field('WebSocket-Protocol');
|
||||
$self->subprotocol($subprotocol) if $subprotocol;
|
||||
|
||||
$self->cookies($self->field('Cookie'));
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _build_cookie { Protocol::WebSocket::Cookie::Request->new }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Request - WebSocket Request
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Constructor
|
||||
my $req = Protocol::WebSocket::Request->new(
|
||||
host => 'example.com',
|
||||
resource_name => '/demo'
|
||||
);
|
||||
$req->to_string; # GET /demo HTTP/1.1
|
||||
# Upgrade: WebSocket
|
||||
# Connection: Upgrade
|
||||
# Host: example.com
|
||||
# Origin: http://example.com
|
||||
# Sec-WebSocket-Key1: 32 0 3lD& 24+< i u4 8! -6/4
|
||||
# Sec-WebSocket-Key2: 2q 4 2 54 09064
|
||||
#
|
||||
# x#####
|
||||
|
||||
# Parser
|
||||
my $req = Protocol::WebSocket::Request->new;
|
||||
$req->parse("GET /demo HTTP/1.1\x0d\x0a");
|
||||
$req->parse("Upgrade: WebSocket\x0d\x0a");
|
||||
$req->parse("Connection: Upgrade\x0d\x0a");
|
||||
$req->parse("Host: example.com\x0d\x0a");
|
||||
$req->parse("Origin: http://example.com\x0d\x0a");
|
||||
$req->parse(
|
||||
"Sec-WebSocket-Key1: 18x 6]8vM;54 *(5: { U1]8 z [ 8\x0d\x0a");
|
||||
$req->parse(
|
||||
"Sec-WebSocket-Key2: 1_ tx7X d < nw 334J702) 7]o}` 0\x0d\x0a");
|
||||
$req->parse("\x0d\x0aTm[K T2u");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Construct or parse a WebSocket request.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<host>
|
||||
|
||||
=head2 C<key1>
|
||||
|
||||
=head2 C<key2>
|
||||
|
||||
=head2 C<number1>
|
||||
|
||||
=head2 C<number2>
|
||||
|
||||
=head2 C<origin>
|
||||
|
||||
=head2 C<resource_name>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Request> instance.
|
||||
|
||||
=head2 C<new_from_psgi>
|
||||
|
||||
my $env = {
|
||||
HTTP_HOST => 'example.com',
|
||||
HTTP_CONNECTION => 'Upgrade',
|
||||
...
|
||||
};
|
||||
my $req = Protocol::WebSocket::Request->new_from_psgi($env);
|
||||
|
||||
Create a new L<Protocol::WebSocket::Request> instance from L<PSGI> environment.
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
$req->parse($buffer);
|
||||
$req->parse($handle);
|
||||
|
||||
Parse a WebSocket request. Incoming buffer is modified.
|
||||
|
||||
=head2 C<to_string>
|
||||
|
||||
Construct a WebSocket request.
|
||||
|
||||
=head2 C<connection>
|
||||
|
||||
$self->connection;
|
||||
|
||||
A shortcut for C<$self->field('Connection')>.
|
||||
|
||||
=head2 C<cookies>
|
||||
|
||||
=head2 C<upgrade>
|
||||
|
||||
$self->upgrade;
|
||||
|
||||
A shortcut for C<$self->field('Upgrade')>.
|
||||
|
||||
=cut
|
||||
347
xterm/lib/Protocol/WebSocket/Response.pm
Normal file
347
xterm/lib/Protocol/WebSocket/Response.pm
Normal file
@@ -0,0 +1,347 @@
|
||||
package Protocol::WebSocket::Response;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Protocol::WebSocket::Message';
|
||||
|
||||
require Carp;
|
||||
use MIME::Base64 ();
|
||||
use Digest::SHA ();
|
||||
|
||||
use Protocol::WebSocket::URL;
|
||||
use Protocol::WebSocket::Cookie::Response;
|
||||
|
||||
sub location { @_ > 1 ? $_[0]->{location} = $_[1] : $_[0]->{location} }
|
||||
|
||||
sub resource_name {
|
||||
@_ > 1 ? $_[0]->{resource_name} = $_[1] : $_[0]->{resource_name};
|
||||
}
|
||||
|
||||
sub cookies { @_ > 1 ? $_[0]->{cookies} = $_[1] : $_[0]->{cookies} }
|
||||
|
||||
sub cookie {
|
||||
my $self = shift;
|
||||
|
||||
push @{$self->{cookies}}, $self->_build_cookie(@_);
|
||||
}
|
||||
|
||||
sub key { @_ > 1 ? $_[0]->{key} = $_[1] : $_[0]->{key} }
|
||||
|
||||
sub number1 { shift->_number('number1', 'key1', @_) }
|
||||
sub number2 { shift->_number('number2', 'key2', @_) }
|
||||
|
||||
sub _number {
|
||||
my $self = shift;
|
||||
my ($name, $key, $value) = @_;
|
||||
|
||||
my $method = "SUPER::$name";
|
||||
return $self->$method($value) if defined $value;
|
||||
|
||||
$value = $self->$method();
|
||||
$value = $self->_extract_number($self->$key) if not defined $value;
|
||||
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub key1 { @_ > 1 ? $_[0]->{key1} = $_[1] : $_[0]->{key1} }
|
||||
sub key2 { @_ > 1 ? $_[0]->{key2} = $_[1] : $_[0]->{key2} }
|
||||
|
||||
sub status {
|
||||
return '101';
|
||||
}
|
||||
|
||||
sub headers {
|
||||
my $self = shift;
|
||||
|
||||
my $version = $self->version || 'draft-ietf-hybi-10';
|
||||
|
||||
my $headers = [];
|
||||
|
||||
push @$headers, Upgrade => 'WebSocket';
|
||||
push @$headers, Connection => 'Upgrade';
|
||||
|
||||
if ($version eq 'draft-hixie-75' || $version eq 'draft-ietf-hybi-00') {
|
||||
Carp::croak(qq/host is required/) unless defined $self->host;
|
||||
|
||||
my $location = $self->_build_url(
|
||||
host => $self->host,
|
||||
secure => $self->secure,
|
||||
resource_name => $self->resource_name,
|
||||
);
|
||||
my $origin =
|
||||
$self->origin ? $self->origin : 'http://' . $location->host;
|
||||
$origin =~ s{^http:}{https:} if !$self->origin && $self->secure;
|
||||
|
||||
if ($version eq 'draft-hixie-75') {
|
||||
push @$headers, 'WebSocket-Protocol' => $self->subprotocol
|
||||
if defined $self->subprotocol;
|
||||
push @$headers, 'WebSocket-Origin' => $origin;
|
||||
push @$headers, 'WebSocket-Location' => $location->to_string;
|
||||
}
|
||||
elsif ($version eq 'draft-ietf-hybi-00') {
|
||||
push @$headers, 'Sec-WebSocket-Protocol' => $self->subprotocol
|
||||
if defined $self->subprotocol;
|
||||
push @$headers, 'Sec-WebSocket-Origin' => $origin;
|
||||
push @$headers, 'Sec-WebSocket-Location' => $location->to_string;
|
||||
}
|
||||
}
|
||||
elsif ($version eq 'draft-ietf-hybi-10' || $version eq 'draft-ietf-hybi-17') {
|
||||
Carp::croak(qq/key is required/) unless defined $self->key;
|
||||
|
||||
my $key = $self->key;
|
||||
$key .= '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; # WTF
|
||||
$key = Digest::SHA::sha1($key);
|
||||
$key = MIME::Base64::encode_base64($key);
|
||||
$key =~ s{\s+}{}g;
|
||||
|
||||
push @$headers, 'Sec-WebSocket-Accept' => $key;
|
||||
|
||||
push @$headers, 'Sec-WebSocket-Protocol' => $self->subprotocol
|
||||
if defined $self->subprotocol;
|
||||
}
|
||||
else {
|
||||
Carp::croak('Version ' . $version . ' is not supported');
|
||||
}
|
||||
|
||||
if (@{$self->cookies}) {
|
||||
my $cookie = join ',' => map { $_->to_string } @{$self->cookies};
|
||||
push @$headers, 'Set-Cookie' => $cookie;
|
||||
}
|
||||
|
||||
return $headers;
|
||||
}
|
||||
|
||||
sub body {
|
||||
my $self = shift;
|
||||
|
||||
return $self->checksum if $self->version eq 'draft-ietf-hybi-00';
|
||||
|
||||
return '';
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
my $status = $self->status;
|
||||
|
||||
my $string = '';
|
||||
$string .= "HTTP/1.1 $status WebSocket Protocol Handshake\x0d\x0a";
|
||||
|
||||
for (my $i = 0; $i < @{$self->headers}; $i += 2) {
|
||||
my $key = $self->headers->[$i];
|
||||
my $value = $self->headers->[$i + 1];
|
||||
|
||||
$string .= "$key: $value\x0d\x0a";
|
||||
}
|
||||
|
||||
$string .= "\x0d\x0a";
|
||||
|
||||
$string .= $self->body;
|
||||
|
||||
return $string;
|
||||
}
|
||||
|
||||
sub _parse_first_line {
|
||||
my ($self, $line) = @_;
|
||||
|
||||
my $status = $self->status;
|
||||
unless ($line =~ m{^HTTP/1\.1 $status }) {
|
||||
my $vis = $line;
|
||||
if( length( $vis ) > 80 ) {
|
||||
substr( $vis, 77 )= '...';
|
||||
}
|
||||
$self->error('Wrong response line. Got [[' . $vis . "]], expected [[HTTP/1.1 $status ]]");
|
||||
return;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _parse_body {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->field('Sec-WebSocket-Accept')) {
|
||||
$self->version('draft-ietf-hybi-10');
|
||||
}
|
||||
elsif ($self->field('Sec-WebSocket-Origin')) {
|
||||
$self->version('draft-ietf-hybi-00');
|
||||
|
||||
return 1 if length $self->{buffer} < 16;
|
||||
|
||||
my $checksum = substr $self->{buffer}, 0, 16, '';
|
||||
$self->checksum($checksum);
|
||||
}
|
||||
else {
|
||||
$self->version('draft-hixie-75');
|
||||
}
|
||||
|
||||
return $self if $self->_finalize;
|
||||
|
||||
$self->error('Not a valid response');
|
||||
return;
|
||||
}
|
||||
|
||||
sub _finalize {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->version eq 'draft-hixie-75') {
|
||||
my $location = $self->field('WebSocket-Location');
|
||||
return unless defined $location;
|
||||
$self->location($location);
|
||||
|
||||
my $url = $self->_build_url;
|
||||
return unless $url->parse($self->location);
|
||||
|
||||
$self->secure($url->secure);
|
||||
$self->host($url->host);
|
||||
$self->resource_name($url->resource_name);
|
||||
|
||||
$self->origin($self->field('WebSocket-Origin'));
|
||||
|
||||
$self->subprotocol($self->field('WebSocket-Protocol'));
|
||||
}
|
||||
elsif ($self->version eq 'draft-ietf-hybi-00') {
|
||||
my $location = $self->field('Sec-WebSocket-Location');
|
||||
return unless defined $location;
|
||||
$self->location($location);
|
||||
|
||||
my $url = $self->_build_url;
|
||||
return unless $url->parse($self->location);
|
||||
|
||||
$self->secure($url->secure);
|
||||
$self->host($url->host);
|
||||
$self->resource_name($url->resource_name);
|
||||
|
||||
$self->origin($self->field('Sec-WebSocket-Origin'));
|
||||
$self->subprotocol($self->field('Sec-WebSocket-Protocol'));
|
||||
}
|
||||
else {
|
||||
$self->subprotocol($self->field('Sec-WebSocket-Protocol'));
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_url { shift; Protocol::WebSocket::URL->new(@_) }
|
||||
sub _build_cookie { shift; Protocol::WebSocket::Cookie::Response->new(@_) }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Response - WebSocket Response
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Constructor
|
||||
$res = Protocol::WebSocket::Response->new(
|
||||
host => 'example.com',
|
||||
resource_name => '/demo',
|
||||
origin => 'file://',
|
||||
number1 => 777_007_543,
|
||||
number2 => 114_997_259,
|
||||
challenge => "\x47\x30\x22\x2D\x5A\x3F\x47\x58"
|
||||
);
|
||||
$res->to_string; # HTTP/1.1 101 WebSocket Protocol Handshake
|
||||
# Upgrade: WebSocket
|
||||
# Connection: Upgrade
|
||||
# Sec-WebSocket-Origin: file://
|
||||
# Sec-WebSocket-Location: ws://example.com/demo
|
||||
#
|
||||
# 0st3Rl&q-2ZU^weu
|
||||
|
||||
# Parser
|
||||
$res = Protocol::WebSocket::Response->new;
|
||||
$res->parse("HTTP/1.1 101 WebSocket Protocol Handshake\x0d\x0a");
|
||||
$res->parse("Upgrade: WebSocket\x0d\x0a");
|
||||
$res->parse("Connection: Upgrade\x0d\x0a");
|
||||
$res->parse("Sec-WebSocket-Origin: file://\x0d\x0a");
|
||||
$res->parse("Sec-WebSocket-Location: ws://example.com/demo\x0d\x0a");
|
||||
$res->parse("\x0d\x0a");
|
||||
$res->parse("0st3Rl&q-2ZU^weu");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Construct or parse a WebSocket response.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<host>
|
||||
|
||||
=head2 C<location>
|
||||
|
||||
=head2 C<origin>
|
||||
|
||||
=head2 C<resource_name>
|
||||
|
||||
=head2 C<secure>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Response> instance.
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
$res->parse($buffer);
|
||||
|
||||
Parse a WebSocket response. Incoming buffer is modified.
|
||||
|
||||
=head2 C<to_string>
|
||||
|
||||
Construct a WebSocket response.
|
||||
|
||||
=head2 C<cookie>
|
||||
|
||||
=head2 C<cookies>
|
||||
|
||||
=head2 C<key>
|
||||
|
||||
=head2 C<key1>
|
||||
|
||||
$self->key1;
|
||||
|
||||
Set or get C<Sec-WebSocket-Key1> field.
|
||||
|
||||
=head2 C<key2>
|
||||
|
||||
$self->key2;
|
||||
|
||||
Set or get C<Sec-WebSocket-Key2> field.
|
||||
|
||||
=head2 C<number1>
|
||||
|
||||
$self->number1;
|
||||
$self->number1(123456);
|
||||
|
||||
Set or extract from C<Sec-WebSocket-Key1> generated C<number> value.
|
||||
|
||||
=head2 C<number2>
|
||||
|
||||
$self->number2;
|
||||
$self->number2(123456);
|
||||
|
||||
Set or extract from C<Sec-WebSocket-Key2> generated C<number> value.
|
||||
|
||||
=head2 C<status>
|
||||
|
||||
$self->status;
|
||||
|
||||
Get response status (101).
|
||||
|
||||
=head2 C<body>
|
||||
|
||||
$self->body;
|
||||
|
||||
Get response body.
|
||||
|
||||
=head2 C<headers>
|
||||
|
||||
my $arrayref = $self->headers;
|
||||
|
||||
Get response headers.
|
||||
|
||||
=cut
|
||||
52
xterm/lib/Protocol/WebSocket/Stateful.pm
Normal file
52
xterm/lib/Protocol/WebSocket/Stateful.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Protocol::WebSocket::Stateful;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
|
||||
my $self = {@_};
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub state { @_ > 1 ? $_[0]->{state} = $_[1] : $_[0]->{state} }
|
||||
|
||||
sub done { shift->state('done') }
|
||||
sub is_state { shift->state eq shift }
|
||||
sub is_body { shift->is_state('body') }
|
||||
sub is_done { shift->is_state('done') }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::Stateful - Base class for all classes with states
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A base class for all classes with states.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<state>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::Stateful> instance.
|
||||
|
||||
=head2 C<done>
|
||||
|
||||
=head2 C<is_state>
|
||||
|
||||
=head2 C<is_body>
|
||||
|
||||
=head2 C<is_done>
|
||||
|
||||
=cut
|
||||
115
xterm/lib/Protocol/WebSocket/URL.pm
Normal file
115
xterm/lib/Protocol/WebSocket/URL.pm
Normal file
@@ -0,0 +1,115 @@
|
||||
package Protocol::WebSocket::URL;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
|
||||
my $self = {@_};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{secure} ||= 0;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub secure { @_ > 1 ? $_[0]->{secure} = $_[1] : $_[0]->{secure} }
|
||||
|
||||
sub host { @_ > 1 ? $_[0]->{host} = $_[1] : $_[0]->{host} }
|
||||
sub port { @_ > 1 ? $_[0]->{port} = $_[1] : $_[0]->{port} }
|
||||
|
||||
sub resource_name {
|
||||
@_ > 1 ? $_[0]->{resource_name} = $_[1] : $_[0]->{resource_name};
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
my $string = shift;
|
||||
|
||||
my ($scheme) = $string =~ m{^(wss?)://};
|
||||
return unless $scheme;
|
||||
|
||||
$self->secure(1) if $scheme =~ m/ss$/;
|
||||
|
||||
my ($host, $port) = $string =~ m{^$scheme://([^:\/]+)(?::(\d+))?(?:|\/|$)};
|
||||
$host = '/' unless defined $host && $host ne '';
|
||||
$self->host($host);
|
||||
$port ||= $self->secure ? 443 : 80;
|
||||
$self->port($port);
|
||||
|
||||
# path and query
|
||||
my ($pnq) = $string =~ m{^$scheme://(?:.*?)(/.*)$};
|
||||
$pnq = '/' unless defined $pnq && $pnq ne '';
|
||||
$self->resource_name($pnq);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
my $string = '';
|
||||
|
||||
$string .= 'ws';
|
||||
$string .= 's' if $self->secure;
|
||||
$string .= '://';
|
||||
$string .= $self->host;
|
||||
$string .= ':' . $self->port if defined $self->port;
|
||||
$string .= $self->resource_name || '/';
|
||||
|
||||
return $string;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Protocol::WebSocket::URL - WebSocket URL
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Construct
|
||||
my $url = Protocol::WebSocket::URL->new;
|
||||
$url->host('example.com');
|
||||
$url->port('3000');
|
||||
$url->secure(1);
|
||||
$url->to_string; # wss://example.com:3000
|
||||
|
||||
# Parse
|
||||
my $url = Protocol::WebSocket::URL->new->parse('wss://example.com:3000');
|
||||
$url->host; # example.com
|
||||
$url->port; # 3000
|
||||
$url->secure; # 1
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Construct or parse a WebSocket URL.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<host>
|
||||
|
||||
=head2 C<port>
|
||||
|
||||
=head2 C<resource_name>
|
||||
|
||||
=head2 C<secure>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<new>
|
||||
|
||||
Create a new L<Protocol::WebSocket::URL> instance.
|
||||
|
||||
=head2 C<parse>
|
||||
|
||||
Parse a WebSocket URL.
|
||||
|
||||
=head2 C<to_string>
|
||||
|
||||
Construct a WebSocket URL.
|
||||
|
||||
=cut
|
||||
@@ -1,9 +1,11 @@
|
||||
#!/usr/local/bin/perl
|
||||
# Start a websocket server connected to a shell
|
||||
|
||||
use lib ("$ENV{'PERLLIB'}/xterm/lib");
|
||||
use Net::WebSocket::Server;
|
||||
|
||||
require './xterm-lib.pl';
|
||||
|
||||
use Net::WebSocket::Server;
|
||||
our ($port, $user) = @ARGV;
|
||||
|
||||
# Switch to the user we're running as
|
||||
|
||||
Reference in New Issue
Block a user