diff --git a/mod_def_list.txt b/mod_def_list.txt index 9d276ce72..e104ea0a8 100644 --- a/mod_def_list.txt +++ b/mod_def_list.txt @@ -1 +1 @@ -cron dfsadmin exports inetd init mount samba useradmin fdisk format proc webmin quota software pap acl apache lpadmin bind8 sendmail squid bsdexports hpuxexports net dhcpd custom telnet servers time wuftpd syslog mysql man inittab raid postfix webminlog postgresql xinetd status cpan pam nis shell grub fetchmail passwd at proftpd sshd heartbeat cluster-software cluster-useradmin qmailadmin mon jabber stunnel usermin fsdump lvm procmail cluster-webmin firewall sgiexports vgetty openslp webalizer shorewall adsl-client updown ppp-client pptp-server pptp-client ipsec ldap-useradmin change-user cluster-shell cluster-cron spam htaccess-htpasswd logrotate cluster-passwd mailboxes ipfw sarg bandwidth cluster-copy backup-config smart-status idmapd krb5 smf ipfilter rbac tunnel zones cluster-usermin dovecot syslog-ng mailcap ldap-client phpini filter bacula-backup ldap-server exim tcpwrappers package-updates system-status webmincron ajaxterm shorewall6 iscsi-server iscsi-client gray-theme iscsi-target iscsi-tgtd bsdfdisk fail2ban authentic-theme firewalld filemin firewall6 logviewer \ No newline at end of file +cron dfsadmin exports inetd init mount samba useradmin fdisk format proc webmin quota software pap acl apache lpadmin bind8 sendmail squid bsdexports hpuxexports net dhcpd custom servers time wuftpd syslog mysql man inittab raid postfix webminlog postgresql xinetd status cpan pam nis shell grub fetchmail passwd at proftpd sshd heartbeat cluster-software cluster-useradmin qmailadmin mon jabber stunnel usermin fsdump lvm procmail cluster-webmin firewall sgiexports vgetty openslp webalizer shorewall adsl-client updown ppp-client pptp-server pptp-client ipsec ldap-useradmin change-user cluster-shell cluster-cron spam htaccess-htpasswd logrotate cluster-passwd mailboxes ipfw sarg bandwidth cluster-copy backup-config smart-status idmapd krb5 smf ipfilter rbac tunnel zones cluster-usermin dovecot syslog-ng mailcap ldap-client phpini filter bacula-backup ldap-server exim tcpwrappers package-updates system-status webmincron shorewall6 iscsi-server iscsi-client gray-theme iscsi-target iscsi-tgtd bsdfdisk fail2ban authentic-theme firewalld filemin firewall6 logviewer xterm \ No newline at end of file diff --git a/xterm/index.cgi b/xterm/index.cgi index b67304b9b..72ba49960 100644 --- a/xterm/index.cgi +++ b/xterm/index.cgi @@ -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(); diff --git a/xterm/lib/Net/WebSocket/Server.pm b/xterm/lib/Net/WebSocket/Server.pm new file mode 100644 index 000000000..925a6c0e2 --- /dev/null +++ b/xterm/lib/Net/WebSocket/Server.pm @@ -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 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, at C-time), this module installs a C handler of C<'IGNORE'>. Write failures are handled situationally rather than in a global C handler, but this still must be done to prevent the signal from killing the server process. If you require your own C handler, assign to C<$SIG{PIPE}> after this module is loaded. + +=head1 AUTHOR + +Eric Wastl, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. 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 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=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 + +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. diff --git a/xterm/lib/Net/WebSocket/Server/Connection.pm b/xterm/lib/Net/WebSocket/Server/Connection.pm new file mode 100644 index 000000000..83b4ef986 --- /dev/null +++ b/xterm/lib/Net/WebSocket/Server/Connection.pm @@ -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. + +=head1 SYNOPSIS + +Within the L callback of a +L, + + $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 and passed to the registered +L handler there for configuration. + +=head1 CONSTRUCTION + +=over + +=item C<< Net::WebSocket::Server::Connection->new(I<%opts>) >> + +Creates a new C object with the given +configuration. This is typically done for you by +L; you rarely need to construct +your own explicitly. Takes the following parameters: + +=over + +=item C + +The underlying L-like object. Once set, this cannot be +changed. Required. + +=item C + +The associated L object. Once +set, this cannot be changed. Required. + +=item C + +A boolean value indicating whether C should be set on the socket +after the handshake is complete. Default C<1>. See L. + +=item C + +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 as the +C parameter. + +=item C + +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 as the +C parameter. + +=item C> + +The callback to invoke when the given C<$event> occurs, such as C. See +L. + +=back + +=back + +=head1 METHODS + +=over + +=item C)> + + $connection->on( + utf8 => sub { ... }, + ), + +Takes a list of C<< $event => $callback >> pairs; C<$event> names should not +include an C prefix. See L. + +=item C + +Returns the associated L object. + +=item C + +Returns the underlying socket object. + +=item C + +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 + +Returns the remote IP of the connection. + +=item C + +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])> + +A boolean value indicating whether C should be set on the socket +after the handshake is complete. If the handshake is already complete, +immediately modifies the socket's C 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])> + +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 as the +C parameter. + +=item C])> + +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 as the +C parameter. + +This value cannot be modified once the handshake is completed. + +=item C, I<$reason>)> + +Invokes the registered C handler, sends a C packet with the +given C<$code> and C<$reason>, and disconnects the socket. + +=item C)> + +Sends a C message with the given content. The message will be +UTF8-encoded automatically. + +=item C)> + +Sends a C message with the given content. + +=item C, I<$raw_data>)> + +Sends a message with the given type and content. Typically, one should use the +L and L methods instead. + +=item C + +Attempts to read from the socket, invoking callbacks for any received messages. +The associated L will call this +automatically when data is ready to be read. + +=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<$handshake>)> + +Invoked when a handshake message has been received from the client; the +C<$handshake> parameter is the underlying +L +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)> + +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, 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, I<$message>)> + +Invoked when a C message is received from the client. The C<$message>, +if any, is decoded and provided. + +=item C, I<$message>)> + +Invoked when a C message is received from the client. The C<$message>, +if any, is provided. + +=item C, I<$message>)> + +Invoked when a C message is received from the client. The C<$message>, +if any, is provided. If the associated +L object is configured with a +nonzero L, this event will +also occur in response to the C messages automatically sent to keep the +connection alive. + +=back + +=head1 AUTHOR + +Eric Wastl, C<< >> + +=head1 SEE ALSO + +L + +=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 + +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. diff --git a/xterm/lib/Protocol/WebSocket.pm b/xterm/lib/Protocol/WebSocket.pm new file mode 100644 index 000000000..9bb1b456a --- /dev/null +++ b/xterm/lib/Protocol/WebSocket.pm @@ -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 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 +attribute to an appropriate value. + +L itself does not contain any code and cannot be used +directly. Instead the following modules should be used: + +=head2 High-level modules + +=head3 L + +Server helper class. + +=head3 L + +Client helper class. + +=head2 Low-level modules + +=head3 L + +Server handshake parser and constructor. + +=head3 L + +Client handshake parser and constructor. + +=head3 L + +WebSocket frame parser and constructor. + +=head3 L + +Low level WebSocket request parser and constructor. + +=head3 L + +Low level WebSocket response parser and constructor. + +=head3 L + +Low level WebSocket url parser and constructor. + +=head1 EXAMPLES + +For examples on how to use L with various event loops see +C 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. + +=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 diff --git a/xterm/lib/Protocol/WebSocket/Client.pm b/xterm/lib/Protocol/WebSocket/Client.pm new file mode 100644 index 000000000..df9f6aa3c --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Client.pm @@ -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 is a convenient class for writing a WebSocket +client. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Cookie.pm b/xterm/lib/Protocol/WebSocket/Cookie.pm new file mode 100644 index 000000000..ecfea524a --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Cookie.pm @@ -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 and +L. + +=head1 ATTRIBUTES + +=head2 C + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + +=head2 C + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Cookie/Request.pm b/xterm/lib/Protocol/WebSocket/Cookie/Request.pm new file mode 100644 index 000000000..17615ad58 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Cookie/Request.pm @@ -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 + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head1 METHODS + +=head2 C + +Parse a WebSocket request cookie. + +=head2 C + +Construct a WebSocket request cookie. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Cookie/Response.pm b/xterm/lib/Protocol/WebSocket/Cookie/Response.pm new file mode 100644 index 000000000..28e0022f3 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Cookie/Response.pm @@ -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 a WebSocket response cookie. + +=head2 C + +Construct a WebSocket response cookie. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Frame.pm b/xterm/lib/Protocol/WebSocket/Frame.pm new file mode 100644 index 000000000..9af60ae76 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Frame.pm @@ -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 is used, this is not secure, so when +L is installed it is used instead. + +=head1 METHODS + +=head2 C + + Protocol::WebSocket::Frame->new('data'); # same as (buffer => 'data') + Protocol::WebSocket::Frame->new(buffer => 'data', type => 'close'); + +Create a new L 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 => STR (default: C<"">) + +The payload of the frame. + +=item C => TYPE_STR (default: C<"text">) + +The type of the frame. Accepted values are: + + continuation + text + binary + ping + pong + close + +=item C => INT (default: 1) + +The opcode of the frame. If C field is set to a valid string, this field is ignored. + +=item C => BOOL (default: 1) + +"fin" flag of the frame. "fin" flag must be 1 in the ending frame of fragments. + +=item C => BOOL (default: 0) + +If set to true, the frame will be masked. + +=item C => VERSION_STR (default: C<'draft-ietf-hybi-17'>) + +WebSocket protocol version string. See L for valid version strings. + +=back + +=head2 C + +Check if frame is of continuation type. + +=head2 C + +Check if frame is of text type. + +=head2 C + +Check if frame is of binary type. + +=head2 C + +Check if frame is a ping request. + +=head2 C + +Check if frame is a pong response. + +=head2 C + +Check if frame is of close type. + +=head2 C + + $opcode = $frame->opcode; + $frame->opcode(8); + +Get/set opcode of the frame. + +=head2 C + + $masked = $frame->masked; + $frame->masked(1); + +Get/set masking of the frame. + +=head2 C + + $frame->append($chunk); + +Append a frame chunk. + +Beware that this method is B. +It makes C<$chunk> empty unless C<$chunk> is read-only. + +=head2 C + + $frame->append(...); + + $frame->next; # next message + +Return the next message as a Perl string (UTF-8 decoded). + +=head2 C + +Return the next message as is. + +=head2 C + +Construct a WebSocket message. + +=head2 C + +The maximum size of the payload. You may set this to C<0> or C to disable +checking the payload size. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Handshake.pm b/xterm/lib/Protocol/WebSocket/Handshake.pm new file mode 100644 index 000000000..4c83caee1 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Handshake.pm @@ -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 and +L. + +=head1 ATTRIBUTES + +=head2 C + + $handshake->error; + +Set or get handshake error. + +=head2 C + + $handshake->version; + +Set or get handshake version. + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + + $handshake->req; + +WebSocket request object. + +=head2 C + + $handshake->res; + +WebSocket response object. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Handshake/Client.pm b/xterm/lib/Protocol/WebSocket/Handshake/Client.pm new file mode 100644 index 000000000..529b3a681 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Handshake/Client.pm @@ -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 + + $handshake->url('ws://example.com/demo'); + +Set or get WebSocket url. + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + + $handshake->parse($buffer); + +Parse a WebSocket server response. Returns C and sets C attribute +on error. Buffer is modified. + +=head2 C + +Construct a WebSocket client request. + +=head2 C + +Check whether handshake is done. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Handshake/Server.pm b/xterm/lib/Protocol/WebSocket/Handshake/Server.pm new file mode 100644 index 000000000..35deff386 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Handshake/Server.pm @@ -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 + +Create a new L instance. + +=head2 C + + my $env = { + HTTP_HOST => 'example.com', + HTTP_CONNECTION => 'Upgrade', + ... + }; + my $handshake = Protocol::WebSocket::Handshake::Server->new_from_psgi($env); + +Create a new L instance from L +environment. + +=head2 C + + $handshake->parse($buffer); + $handshake->parse($handle); + +Parse a WebSocket client request. Returns C and sets C attribute +on error. + +When buffer is passed it's modified (unless readonly). + +=head2 C + + $handshake->build_frame; + +Builds L with an appropriate version. + +=head2 C + +Construct a WebSocket server response. + +=head2 C + +Check whether handshake is in body state. + +=head2 C + +Check whether handshake is done. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Message.pm b/xterm/lib/Protocol/WebSocket/Message.pm new file mode 100644 index 000000000..433738143 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Message.pm @@ -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 and +L. + +=head1 ATTRIBUTES + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + +=head2 C + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Request.pm b/xterm/lib/Protocol/WebSocket/Request.pm new file mode 100644 index 000000000..d23ed4cc5 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Request.pm @@ -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 + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + + my $env = { + HTTP_HOST => 'example.com', + HTTP_CONNECTION => 'Upgrade', + ... + }; + my $req = Protocol::WebSocket::Request->new_from_psgi($env); + +Create a new L instance from L environment. + +=head2 C + + $req->parse($buffer); + $req->parse($handle); + +Parse a WebSocket request. Incoming buffer is modified. + +=head2 C + +Construct a WebSocket request. + +=head2 C + + $self->connection; + +A shortcut for C<$self->field('Connection')>. + +=head2 C + +=head2 C + + $self->upgrade; + +A shortcut for C<$self->field('Upgrade')>. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Response.pm b/xterm/lib/Protocol/WebSocket/Response.pm new file mode 100644 index 000000000..2d4f56734 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Response.pm @@ -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 + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + + $res->parse($buffer); + +Parse a WebSocket response. Incoming buffer is modified. + +=head2 C + +Construct a WebSocket response. + +=head2 C + +=head2 C + +=head2 C + +=head2 C + + $self->key1; + +Set or get C field. + +=head2 C + + $self->key2; + +Set or get C field. + +=head2 C + + $self->number1; + $self->number1(123456); + +Set or extract from C generated C value. + +=head2 C + + $self->number2; + $self->number2(123456); + +Set or extract from C generated C value. + +=head2 C + + $self->status; + +Get response status (101). + +=head2 C + + $self->body; + +Get response body. + +=head2 C + + my $arrayref = $self->headers; + +Get response headers. + +=cut diff --git a/xterm/lib/Protocol/WebSocket/Stateful.pm b/xterm/lib/Protocol/WebSocket/Stateful.pm new file mode 100644 index 000000000..c067b0539 --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/Stateful.pm @@ -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 + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + +=head2 C + +=head2 C + +=head2 C + +=cut diff --git a/xterm/lib/Protocol/WebSocket/URL.pm b/xterm/lib/Protocol/WebSocket/URL.pm new file mode 100644 index 000000000..e2372933f --- /dev/null +++ b/xterm/lib/Protocol/WebSocket/URL.pm @@ -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 + +=head2 C + +=head2 C + +=head2 C + +=head1 METHODS + +=head2 C + +Create a new L instance. + +=head2 C + +Parse a WebSocket URL. + +=head2 C + +Construct a WebSocket URL. + +=cut diff --git a/xterm/shellserver.pl b/xterm/shellserver.pl index 7a8a7c115..7c6d1fd5c 100755 --- a/xterm/shellserver.pl +++ b/xterm/shellserver.pl @@ -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