#!/usr/bin/perl -w
use strict;
use IO::Socket;
use IO::Select;
use Encode;
use Digest::SHA1 qw(sha1_base64);
use Digest::MD5 qw(md5); # for legacy

binmode STDIN, ":utf8";
binmode STDOUT, ":utf8";

my $config = {};
open(CONFIG, '<:utf8', '.config') or die $!;
foreach my $key (qw(hostname port)) {
    my $value = <CONFIG>;
    die "unexpected empty read in config file. $!" unless defined $value;
    chomp $value;
    $value =~ m/^(.*)$/os; # untaint - we trust the config file!
    $config->{$key} = $1;
}
close CONFIG;

$| = 1;

my $server = IO::Socket::INET->new(LocalHost => $config->{hostname},
                                   LocalPort => $config->{port},
                                   Proto => 'tcp',
                                   Listen => 5,
                                   ReuseAddr => 1) or die;
my $sockets = IO::Select->new($server);
my $clients = {};
my @failedClients;

my $active = 1;
local $SIG{'TERM'} = sub { $active = 0; };
local $SIG{'INT'} = sub { $active = 0; };

while ($active) {
    foreach my $socket ($sockets->can_read()) {
        if ($socket == $server) {
            if ($socket = $server->accept) {
                $sockets->add($socket);
                $clients->{$socket->fileno} = { socket => $socket, connected => 0, closed => 0, handshake => '' };
            }
        } else {
            my $client = $clients->{$socket->fileno};
            eval {
                my $data = '';
                if ($socket->sysread($data, 1024)) {
                    processInput($client, $data);
                } else {
                    # connection lost (probably)
                    push(@failedClients, $client);
                }
            };
            if ($@) {
                if (!$client->{closed}) {
                    warn "internal error during read: $@\n";
                }
                push(@failedClients, $client);
            }
        }
    }
    while (@failedClients) {
        my @failedClientsCopy = @failedClients;
        @failedClients = ();
        foreach my $client (@failedClientsCopy) {
            handleFailedClient($client);
        }
    }
}
$server->shutdown(2);

sub handleFailedClient {
    my($client) = @_;
    if ($client->{connected}) {
        eval {
            disconnected($client);
        };
        if ($@) {
            warn "while disconnecting: $@\n";
        }
    }
    my $socket = $client->{socket};
    delete $clients->{$socket->fileno};
    $sockets->remove($socket);
    $socket->shutdown(2) if $socket->connected;
}


# ------------------------------------------------------------------------
# WebSocket

sub processInput {
    my($client, $data) = @_;
    my $index = 0;
    while ($index < length($data)) {
        my $char = bytes::substr($data, $index, 1);
        if (not $client->{connected}) {
            $client->{handshake} .= $char;
            if ($client->{legacy} and ($client->{handshake} =~ m/\x{D}\x{A}\x{D}\x{A}(........)$/os)) {
                my @lines = split(/\x{D}\x{A}/, $client->{handshake});
                shift @lines;
                foreach (@lines) {
                    last if $_ eq '';
                    m/^([^:]+): (.*)$/gos or die 'malformed field in handshake';
                    die 'duplicate field' if exists $client->{fields}->{lc $1};
                    $client->{fields}->{lc $1} = $2;
                }
                my $key1 = getKey($client->{fields}->{'sec-websocket-key1'});
                my $key2 = getKey($client->{fields}->{'sec-websocket-key2'});
                my $key3 = substr($client->{handshake}, -8);
                my $key = md5(pack("NNa8", $key1, $key2, $key3));
                my $hostname = $config->{hostname};
                my $port = $config->{chatServerPort};
                socketWrite($client, "HTTP/1.1 101 WebSocket Protocol Handshake\r\n");
                socketWrite($client, "Upgrade: WebSocket\r\n");
                socketWrite($client, "Connection: Upgrade\r\n");
                socketWrite($client, "Sec-WebSocket-Location: ws://$hostname:$port/\r\n");
                socketWrite($client, "Sec-WebSocket-Origin: http://$hostname\r\n");
                socketWrite($client, "\r\n");
                socketWrite($client, $key);
                clientConnected($client);
            } elsif ($client->{handshake} =~ m/\x{D}\x{A}\x{D}\x{A}$/os) {
                if ($client->{handshake} =~ m/\x{D}\x{A}Sec-WebSocket-Key: ([0A-Za-z0-9+\/]*=*)\x{D}\x{A}/os) {
                    my $key = $1;
                    my $acceptKey = sha1_base64("${key}258EAFA5-E914-47DA-95CA-C5AB0DC85B11"); # does not pad the output with =s...
                    socketWrite($client, "HTTP/1.1 101 WebSocket\x{D}\x{A}");
                    socketWrite($client, "Upgrade: websocket\x{D}\x{A}");
                    socketWrite($client, "Connection: Upgrade\x{D}\x{A}");
                    socketWrite($client, "Sec-WebSocket-Accept: ${acceptKey}=\x{D}\x{A}"); # ...so we add the one = required here
                    socketWrite($client, "\x{D}\x{A}");
                    clientConnected($client);
                } else {
                    $client->{legacy} = 1;
                }
            }
        } elsif ($client->{mode} eq 'client') {
            frameparser: {
                if ($client->{framepart} eq 'byte1') {
                    $client->{frame} = {
                        final => (bytes::ord($char) & 0x80) == 0x80,
                        opcode => (bytes::ord($char) & 0x0F),
                    };
                    $client->{framepart} = 'byte2';
                } elsif ($client->{framepart} eq 'byte2') {
                    $client->{frame}->{length} = bytes::ord($char) & 0x7F;
                    if ($client->{frame}->{length} == 126) {
                        $client->{framepart} = 'collect-n-bytes';
                        $client->{pending} = 2;
                        $client->{buffer} = '';
                        $client->{nextframepart} = 'set-length';
                    } elsif ($client->{frame}->{length} == 127) {
                        $client->{framepart} = 'collect-n-bytes';
                        $client->{pending} = 8;
                        $client->{buffer} = '';
                        $client->{nextframepart} = 'set-length';
                    } else {
                        $client->{framepart} = 'collect-n-bytes';
                        $client->{pending} = 4;
                        $client->{buffer} = '';
                        $client->{nextframepart} = 'set-mask';
                    }
                } elsif ($client->{framepart} eq 'collect-n-bytes') {
                    $client->{buffer} .= $char;
                    $client->{pending} -= 1;
                    if (not $client->{pending}) {
                        $client->{framepart} = $client->{nextframepart};
                        delete $client->{nextframepart};
                        delete $client->{pending};
                        $char = undef;
                        redo frameparser;
                    }
                } elsif ($client->{framepart} eq 'set-length') {
                    $client->{frame}->{length} = 0;
                    for (my $i = 0; $i < length($client->{buffer}); $i += 1) {
                        $client->{frame}->{length} = bytes::ord(substr($client->{buffer}, $i, 1)) | ($client->{frame}->{length} << ($i * 8));
                    }
                    $client->{framepart} = 'collect-n-bytes';
                    $client->{pending} = 4;
                    $client->{nextframepart} = 'set-mask';
                    delete $client->{buffer};
                } elsif ($client->{framepart} eq 'set-mask') {
                    $client->{mask} = $client->{buffer};
                    delete $client->{buffer};
                    if ($client->{frame}->{length} > 0) {
                        $client->{framepart} = 'collect-n-bytes';
                        $client->{pending} = $client->{frame}->{length};
                        $client->{buffer} = '';
                        $client->{nextframepart} = 'unmask';
                    } else {
                        $client->{buffer} = '';
                        $client->{framepart} = 'unmask';
                        redo frameparser;
                    }
                } elsif ($client->{framepart} eq 'unmask') { # run after collect-n-bytes
                    $client->{frame}->{data} = '';
                    if (length($client->{buffer}) > 0) {
                        use bytes; # implies 'bytes::' in front of length, chr, ord, and substr below
                        for (my $i = 0; $i < length($client->{buffer}); $i += 1) {
                            $client->{frame}->{data} .= chr(ord(substr($client->{buffer}, $i, 1)) ^ ord(substr($client->{mask}, $i % length($client->{mask}), 1)));
                        }
                    }
                    processFrame($client);
                    delete $client->{buffer};
                    delete $client->{frame};
                    $client->{framepart} = 'byte1';
                } elsif ($client->{framepart} eq 'legacy-start') {
                    # expecting start of frame
                    if (bytes::ord($char) == 0x00) {
                        $client->{buffer} = '';
                        $client->{framepart} = 'legacy-data';
                    } elsif (bytes::ord($char) == 0xff) {
                        $client->{framepart} = 'legacy-end';
                    } else {
                        die 'unknown frame type';
                    }
                } elsif ($client->{framepart} eq 'legacy-data') {
                    # expecting data from frame of type 0x00
                    if (bytes::ord($char) != 0xff) {
                        $client->{buffer} .= $char;
                    } else {
                        # end of frame
                        $client->{data} = decode('UTF-8', $client->{buffer});
                        processTextFrame($client);
                        delete $client->{buffer};
                        delete $client->{data};
                        $client->{framepart} = 'legacy-start';
                    }
                } elsif ($client->{framepart} eq 'legacy-end') {
                    # expecting 0x00 indicating communication termination from client
                    die 'unexpected 0xff frame data' unless bytes::ord($char) == 0x00;
                    $client->{closed} = 1;
                    die 'received close frame';
                } else {
                    die 'unexpected frame parse state';
                }
            }
        } else {
            die 'unexpected socket mode';
        }
        $index += 1;
    }
}

sub clientConnected {
    my($client) = @_;
    $client->{mode} = 'client';
    $client->{connected} = 1;
    $client->{framepart} = $client->{legacy} ? 'legacy-start' : 'byte1';
    connected($client);
}

sub processFrame {
    my($client) = @_;
    if ($client->{frame}->{opcode} == 0x01) {
        # text - frame 1
        $client->{datatype} = 'text';
        $client->{data} = '';
    } elsif ($client->{frame}->{opcode} == 0x02) {
        # binary - frame 1
        $client->{datatype} = 'binary';
        $client->{data} = '';
    } elsif ($client->{frame}->{opcode} == 0x00) {
        # continuation frame
    } elsif ($client->{frame}->{opcode} < 0x08) {
        die 'unrecognised frame type from client';
    } else {
        # deal with annoying frames
        if ($client->{frame}->{opcode} == 0x08) {
            # close frame
            $client->{closed} = 1;
            die 'received close frame';
        } elsif ($client->{frame}->{opcode} == 0x09) {
            # ping frame - ignore
        } elsif ($client->{frame}->{opcode} == 0x0A) {
            # pong frame - ignore
        } else {
            die 'unrecognised control frame type from client';
        }
        return; # control frames don't affect data
    }
    $client->{data} .= $client->{frame}->{data};
    if ($client->{frame}->{final}) {
        if ($client->{datatype} eq 'text') {
            $client->{data} = decode('UTF-8', $client->{data});
            processTextFrame($client);
        } else {
            die 'unsupported frame type from client';
        }
        delete $client->{datatype};
        delete $client->{data};
    }
}

sub sendText {
    my($client, $data) = @_;
    if ($client->{legacy}) {
        socketWrite($client, bytes::chr(0x00) . encode('UTF-8', $data) . bytes::chr(0xff));
    } else {
        my $length;
        if (bytes::length($data) > 65536) {
            $length = pack('CNN', 127, bytes::length($data) >> 32, bytes::length($data) & 0xFFFFFFFF);
        } elsif (bytes::length($data) > 126) {
            $length = pack('Cn', 126, bytes::length($data));
        } else {
            $length = bytes::chr(bytes::length($data));
        }
        socketWrite($client, bytes::chr(0x81) . $length . encode('UTF-8', $data));
    }
}

sub getKey {
    my($raw) = @_;
    die 'missing key field' unless defined $raw;
    my $spaces =()= $raw =~ m/ /gos;
    $raw =~ s/[^0-9]//gos;
    return (0+$raw)/$spaces;
}

sub socketWrite {
    my($client, $data) = @_;
    eval {
        $client->{socket}->syswrite($data);
    };
    if ($@) {
        push(@failedClients, $client);
    }
}

# ------------------------------------------------------------------------

sub connected {
    my($client) = @_;
    print "|>>\n";
}

sub processTextFrame {
    my($client) = @_;
    my $data = $client->{data};
    # ...
    print ">>> $data\n";
}

sub disconnected {
    my($client) = @_;
    print ">>|\n";
}