glaived/app.pl

#!/usr/bin/env perl
use strict;
use warnings;
use Mojolicious::Lite -signatures;
use FindBin qw($Bin);
use lib "$Bin/lib";
use WCL qw(wcl_token fetch_glaive_deaths);
use DBI;
use JSON::PP;
use HTTP::Tiny;

$ENV{MOJO_REVERSE_PROXY} = 1;

app->config(hypnotoad => { listen => ['http://127.0.0.1:8081'] });

use constant DB_PATH           => "$Bin/lookup.db";
use constant CODE_RE           => qr/^[A-Za-z0-9]{16}$/;
use constant DEFAULT_CUTOFF    => 2;
use constant MIN_CUTOFF        => 0;
use constant MAX_CUTOFF        => 20;
use constant RATE_LIMIT_N      => 20;
use constant RATE_LIMIT_WINDOW => 600;
use constant RECENT_COOKIE     => 'recent';
use constant RECENT_MAX        => 10;

my $client_id     = $ENV{LOOKUP_WCL_CLIENT_ID}     or die "set LOOKUP_WCL_CLIENT_ID\n";
my $client_secret = $ENV{LOOKUP_WCL_CLIENT_SECRET} or die "set LOOKUP_WCL_CLIENT_SECRET\n";

my $http = HTTP::Tiny->new;
my $token;

my $dbh = DBI->connect("dbi:SQLite:dbname=" . DB_PATH, '', '', {
    RaiseError => 1, AutoCommit => 1, sqlite_unicode => 1,
});
$dbh->do(<<'SQL');
CREATE TABLE IF NOT EXISTS cache (
    report_code TEXT    NOT NULL,
    wipe_cutoff INTEGER NOT NULL,
    title       TEXT    NOT NULL,
    raid_date   TEXT    NOT NULL,
    zone_name   TEXT    NOT NULL,
    fight_count INTEGER NOT NULL,
    deaths_json TEXT    NOT NULL,
    fetched_at  INTEGER NOT NULL,
    PRIMARY KEY (report_code, wipe_cutoff)
)
SQL
$dbh->do(<<'SQL');
CREATE TABLE IF NOT EXISTS rate_limit (
    ip           TEXT    NOT NULL,
    window_start INTEGER NOT NULL,
    count        INTEGER NOT NULL,
    PRIMARY KEY (ip, window_start)
)
SQL

sub get_token {
    $token //= wcl_token($http, $client_id, $client_secret);
    return $token;
}

sub check_rate_limit {
    my ($ip) = @_;
    my $window_start = int(time() / RATE_LIMIT_WINDOW) * RATE_LIMIT_WINDOW;

    $dbh->do(
        'INSERT INTO rate_limit (ip, window_start, count) VALUES (?, ?, 1)
         ON CONFLICT(ip, window_start) DO UPDATE SET count = count + 1',
        undef, $ip, $window_start
    );
    my ($count) = $dbh->selectrow_array(
        'SELECT count FROM rate_limit WHERE ip = ? AND window_start = ?',
        undef, $ip, $window_start
    );

    if (int(rand(50)) == 0) {
        $dbh->do('DELETE FROM rate_limit WHERE window_start < ?', undef, $window_start - RATE_LIMIT_WINDOW);
    }

    return $count <= RATE_LIMIT_N;
}

sub cache_lookup {
    my ($code, $cutoff) = @_;
    my $row = $dbh->selectrow_hashref(
        'SELECT * FROM cache WHERE report_code = ? AND wipe_cutoff = ?',
        undef, $code, $cutoff
    );
    return undef unless $row;
    return {
        title       => $row->{title},
        raid_date   => $row->{raid_date},
        zone_name   => $row->{zone_name},
        fight_count => $row->{fight_count},
        deaths      => decode_json($row->{deaths_json}),
    };
}

sub cache_store {
    my ($code, $cutoff, $result) = @_;
    $dbh->do(
        'INSERT INTO cache (report_code, wipe_cutoff, title, raid_date, zone_name, fight_count, deaths_json, fetched_at)
         VALUES (?,?,?,?,?,?,?,?)',
        undef, $code, $cutoff, $result->{title}, $result->{raid_date}, $result->{zone_name},
        $result->{fight_count}, encode_json($result->{deaths}), time()
    );
}

sub death_counts {
    my ($deaths) = @_;
    my %n;
    $n{$_}++ for @$deaths;
    my @rows = map { { player_name => $_, n => $n{$_} } }
               sort { $n{$b} <=> $n{$a} || $a cmp $b }
               keys %n;
    return \@rows;
}

sub parse_recent_cookie {
    my ($c) = @_;
    my $raw = $c->cookie(RECENT_COOKIE) // '';
    my @pairs;
    for my $entry (split /,/, $raw) {
        my ($code, $cutoff) = split /:/, $entry, 2;
        next unless defined $code && $code =~ CODE_RE;
        next unless defined $cutoff && $cutoff =~ /^\d+$/;
        push @pairs, [$code, $cutoff + 0];
    }
    return \@pairs;
}

sub write_recent_cookie {
    my ($c, $pairs) = @_;
    my $value = join ',', map { "$_->[0]:$_->[1]" } @$pairs;
    $c->cookie(RECENT_COOKIE, $value, {
        expires => time() + 365 * 86400, path => '/', httponly => 1, secure => 1,
    });
}

sub bump_recent {
    my ($pairs, $code, $cutoff) = @_;
    my @rest = grep { !($_->[0] eq $code && $_->[1] == $cutoff) } @$pairs;
    my @updated = ([$code, $cutoff], @rest);
    splice(@updated, RECENT_MAX) if @updated > RECENT_MAX;
    return \@updated;
}

sub recent_entries {
    my ($pairs) = @_;
    my @out;
    for my $p (@$pairs) {
        my ($code, $cutoff) = @$p;
        my $cached = cache_lookup($code, $cutoff);
        next unless $cached;
        push @out, {
            code => $code, cutoff => $cutoff,
            title => $cached->{title}, raid_date => $cached->{raid_date},
            total => scalar(@{ $cached->{deaths} }),
        };
    }
    return \@out;
}

get '/' => sub ($c) {
    my $raw_code     = $c->param('code');
    my $recent_pairs = parse_recent_cookie($c);

    return $c->render(template => 'lookup', recent => recent_entries($recent_pairs))
        unless defined $raw_code && length $raw_code;

    my ($code) = $raw_code =~ /^\s*(\S+)\s*$/;
    $code //= '';

    unless ($code =~ CODE_RE) {
        return $c->render(template => 'lookup', status => 400, recent => recent_entries($recent_pairs),
            error => 'Invalid report code format. Expected a 16-character WCL report code.');
    }

    my $raw_cutoff = $c->param('cutoff');
    my $cutoff = (defined $raw_cutoff && $raw_cutoff =~ /^\d+$/) ? $raw_cutoff + 0 : DEFAULT_CUTOFF;
    $cutoff = MIN_CUTOFF if $cutoff < MIN_CUTOFF;
    $cutoff = MAX_CUTOFF if $cutoff > MAX_CUTOFF;

    my $ip = $c->tx->remote_address;
    unless (check_rate_limit($ip)) {
        return $c->render(template => 'lookup', code => $code, cutoff => $cutoff, status => 429,
            recent => recent_entries($recent_pairs),
            error => 'Too many requests. Please try again in a few minutes.');
    }

    my $result = cache_lookup($code, $cutoff);

    unless ($result) {
        eval {
            $result = fetch_glaive_deaths($http, get_token(), $code, $cutoff);
        };
        if ($@) {
            $c->app->log->error("WCL fetch failed for $code: $@");
            return $c->render(template => 'lookup', code => $code, cutoff => $cutoff, status => 502,
                recent => recent_entries($recent_pairs),
                error => 'Warcraft Logs API error, please try again later.');
        }
        unless ($result) {
            return $c->render(template => 'lookup', code => $code, cutoff => $cutoff, status => 404,
                recent => recent_entries($recent_pairs),
                error => 'Report not found.');
        }
        cache_store($code, $cutoff, $result);
    }

    $recent_pairs = bump_recent($recent_pairs, $code, $cutoff);
    write_recent_cookie($c, $recent_pairs);

    return $c->render(template => 'lookup', code => $code, cutoff => $cutoff, result => $result,
        rows => death_counts($result->{deaths}), total => scalar(@{ $result->{deaths} }),
        recent => recent_entries($recent_pairs));
};

app->start;