The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl

use strict;
use warnings;

use IO::Socket;
use IO::Lambda qw(:all);
use IO::Lambda::Socket qw(:all);

use Protocol::WebSocket::Handshake::Server;
use Protocol::WebSocket::Frame;

my $conn_timeout = 10;

my $server = IO::Socket::INET->new(
    Listen    => 5,
    LocalPort => 3000,
    Blocking  => 0,
    ReuseAddr => 1,
) or die $!;

my $serv = lambda {
    context $server;
    accept {
        my $conn = shift;

        again;

        $conn->blocking(0);

        my $hs    = Protocol::WebSocket::Handshake::Server->new;
        my $frame = Protocol::WebSocket::Frame->new;

        my $buf = '';
        context readbuf, $conn, \$buf, qr/^(.*)$/s, $conn_timeout;

    tail {
        my ($match, $error) = @_;

        return close($conn) unless defined $match;

        substr($buf, 0, length($match)) = '';

        my $res = '';
        if (!$hs->is_done) {
            $hs->parse($match);

            if ($hs->is_done) {
                $res = $hs->to_string;
            }

            $match = '';
        }

        $frame->append($match);

        while (my $message = $frame->next) {
            $res .= $frame->new($message)->to_bytes;
        }

        again;

        $match = '';
        context writebuf, $conn, \$res, length($res), 0, $conn_timeout;
        &tail();
    }}
};

$serv->wait;