/usr/share/usermin/vendor_perl/Net/WebSocket
Edit: /usr/share/usermin/vendor_perl/Net/WebSocket/Server.pm (18199B)
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
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 and C 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 for an example of setting up an SSL (C) 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
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 object with the given configuration.
Takes the following parameters:
=over
=item C
If not a reference, the TCP port on which to listen. If a reference, a
preconfigured L TCP server to use. Default C<80>.
To create an SSL WebSocket server (such that you can connect to it via a
C URL), pass an object which acts like L
and speaks SSL, such as L. To avoid blocking
during the SSL handshake, pass C<< SSL_startHandshake => 0 >> to the
L 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
The maximum amount of time in seconds to allow silence on each connection's
socket. Every C 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
The amount of time in seconds between C events. Set to C<0> to disable.
Default C<0>.
=item C>
The callback to invoke when the given C<$event> occurs, such as C.
See L.
=item C
=item C
Each of these takes an I of C<< $filehandle => $callback >> pairs to be
passed to the corresponding method. Default C<[]>. See
L and
L. 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)>
$server->on(
connect => sub { ... },
);
Takes a list of C<< $event => $callback >> pairs; C<$event> names should not
include an C prefix. Typically, events are configured once via the
L rather than later via this method. See L.
=item C
Starts the WebSocket server; registered callbacks will be invoked as
interesting things happen. Does not return until L is
called.
=item C
Returns a list of the current
L
objects.
=item C)>
Immediately disconnects the given C<$socket> without calling the corresponding
connection's callback or cleaning up the socket. For that, see
L, which ultimately calls this
function anyway.
=item C
Closes the listening socket and cleanly disconnects all clients, causing the
L method to return.
=item C)>
$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)>
$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])>
=item C])>
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 if it isn't being watched.
=item C)>
=item C)>
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 parameters to the
L or by passing C<$event> parameters to the
L method.
=over
=item C, I<$connection>)>
Invoked when a new connection is made. Use this event to configure the
newly-constructed
L
object. Arguments passed to the callback are the server accepting the
connection and the new connection object itself.
=item C)>
Invoked every L seconds, or never if
L 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)>
Invoked immediately before the server shuts down due to the L
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