#!/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;