view release on metacpan or  search on metacpan

demo/shell_server.pl  view on Meta::CPAN

use lib "$FindBin::Bin/../lib";

use lib "$FindBin::Bin/lib";
use MockReader ();
use NWDemo ();

use Text::Control ();

use Net::WebSocket::Endpoint::Server ();
use Net::WebSocket::Frame::text ();
use Net::WebSocket::Frame::binary ();
use Net::WebSocket::Frame::continuation ();
use Net::WebSocket::Parser ();

use constant {
    SEND_FRAME_CLASS => 'Net::WebSocket::Frame::binary',
};

use IO::Pty ();

#for setsid()
use POSIX ();

my $host_port = $ARGV[0] || die "Need host:port or port!\n";

if (index($host_port, ':') == -1) {
    substr( $host_port, 0, 0 ) = '127.0.0.1:';
}

my ($host, $port) = split m<:>, $host_port;

#my $loop = IO::Events::Loop->new( debug => 1 );
my $loop = IO::Events::Loop->new();

my %sessions;

sub _kill_session {
    my ($session) = @_;

    if ( $sessions{$session} ) {
        $sessions{$session}{'timeout'}->stop();

        $sessions{$session}{'client'}->destroy();

        if ($sessions{$session}{'shell'}) {
            $sessions{$session}{'shell'}->destroy();
        }

        delete $sessions{$session};
    }
}

my $read_obj = MockReader->new();

my $server = IO::Events::Socket::TCP->new(
    owner => $loop,
    listen => 1,
    addr => $host,
    port => $port,
    on_read => sub {
        my $shell = (getpwuid $>)[8] or die "No shell!";

        my $session = rand;

        my $did_handshake;

        my $ept;

        my $shell_hdl;

        my $client_hdl;

        my $cpid;

        my $timeout = IO::Events::Timer->new(
            owner => $loop,
            timeout => 5,
            repetitive => 1,
            active => 1,
            on_tick => sub {
                if ($did_handshake) {
                    $ept->check_heartbeat();

                    if ($ept->is_closed()) {
                        $shell_hdl->destroy();  #kills PID and $client_hdl
                    }
                }
                else {
                    _kill_session($session);
                }
            },
        );

        my $deflate;

        $client_hdl = shift()->accept(
            owner => $loop,
            read => 1,
            write => 1,
            on_close => sub {
                _kill_session($session);
            },
            on_read => sub {
                my ($client_hdl) = @_;

                $read_obj->add( $client_hdl->read() );

                if ($did_handshake) {

                    #There could be multiple WebSocket messages
                    #in the same TCP packet.
                    while (my $msg = $ept->get_next_message()) {

                        #printf STDERR "from client: %s\n", ($msg->get_payload() =~ s<([\x80-\xff])><sprintf '\x%02x', ord $1>gre);
                        #printf STDERR ">>>>> from browser: %d bytes\n", length $msg->get_payload();
                        #printf STDERR ">>>>> from browser: %v.02x\n", $msg->get_payload();
                        #print STDERR _printable( $msg->get_payload() ) . $/;

                        my $payload = $msg->get_payload();

                        if ($deflate && $deflate->message_is_compressed($msg)) {