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 FindBin;

use Pod::Usage;

use AnyEvent::Socket;
use AnyEvent::Handle;
use Text::MicroTemplate::File;
use Path::Class qw/file dir/;
use JSON;
use Plack::Request;
use Plack::Builder;

my $mtf = Text::MicroTemplate::File->new(
    include_path => ["templates"],
);

my(@clients, %room);

my $app = sub {
    my $env = shift;
    my $req = Plack::Request->new($env);
    my $res = $req->new_response(200);

    if ($req->path eq '/') {
        $res->content_type('text/html; charset=utf-8');
        $res->content($mtf->render_file('index.mt'));
    } elsif ($req->path =~ m!^/chat!) {
        my $room = ($req->path =~ m!^/chat/(.+)!)[0];
        my $host = $req->header('Host');
        $res->content_type('text/html;charset=utf-8');
        $res->content($mtf->render_file('room.mt', $host, $room));
    } elsif ($req->path =~ m!^/ws!) {
        my $room = ($req->path =~ m!^/ws/(.+)!)[0];

        unless (    $env->{HTTP_CONNECTION} eq 'Upgrade'
                and $env->{HTTP_UPGRADE} eq 'WebSocket') {
            $res->code(400);
            return $res->finalize;
        }

        return sub {
            my $respond = shift;

            # XXX: we could use $respond to send handshake response
            # headers, but 101 status message should be 'Web Socket
            # Protocol Handshake' rather than 'Switching Protocols'
            # and we should send HTTP/1.1 response which Twiggy
            # doesn't implement yet.

            my $hs = join "\015\012",
                "HTTP/1.1 101 Web Socket Protocol Handshake",
                "Upgrade: WebSocket",
                "Connection: Upgrade",
                "WebSocket-Origin: $env->{HTTP_ORIGIN}",
                "WebSocket-Location: ws://$env->{HTTP_HOST}$env->{SCRIPT_NAME}$env->{PATH_INFO}",
                '', '';

            my $fh = $env->{'psgix.io'}
                or return $respond->([ 501, [ "Content-Type", "text/plain" ], [ "This server does not support psgix.io extension" ] ]);

            my $h = AnyEvent::Handle->new( fh => $fh );
            $h->on_error(sub {
                warn 'err: ', $_[2];
                delete $room{ $room }[fileno($fh)] if $room;
                undef $h;
            });

            $h->push_write($hs);

            # connection ready
            $room{ $room }[ fileno($fh) ] = $h;

            $h->on_read(sub {
                shift->push_read( line => "\xff", sub {
                    my ($h, $json) = @_;
                    $json =~ s/^\0//;

                    my $data = JSON::decode_json($json);
                    $data->{address} = $req->address;
                    $data->{time} = time;

                    my $msg = JSON::encode_json($data);

                    # broadcast
                    for my $c (grep { defined } @{ $room{$room} || [] }) {
                        $c->push_write("\x00" . $msg . "\xff");
                    }
                });
            });
        };
    } else {
        $res->code(404);
    }

    $res->finalize;
};

builder {
    enable "Static", path => sub { s!^/static/!! }, root => 'static';
    $app;
};