225 lines
7.3 KiB
Perl
Executable File
225 lines
7.3 KiB
Perl
Executable File
#!/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 CACHE_TTL => 900;
|
|
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, %opts) = @_;
|
|
my $row = $dbh->selectrow_hashref(
|
|
'SELECT * FROM cache WHERE report_code = ? AND wipe_cutoff = ?',
|
|
undef, $code, $cutoff
|
|
);
|
|
return undef unless $row;
|
|
return undef if !$opts{ignore_ttl} && time() - $row->{fetched_at} > CACHE_TTL;
|
|
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 (?,?,?,?,?,?,?,?)
|
|
ON CONFLICT(report_code, wipe_cutoff) DO UPDATE SET
|
|
title = excluded.title, raid_date = excluded.raid_date, zone_name = excluded.zone_name,
|
|
fight_count = excluded.fight_count, deaths_json = excluded.deaths_json, fetched_at = excluded.fetched_at',
|
|
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, ignore_ttl => 1);
|
|
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;
|