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