commit 61195bd6b2646c0518709a7ba5308f6e65dc1258 Author: Tobias B Date: Sat Jun 20 02:17:30 2026 +0200 Initial commit of the Heaven's Glaives lookup tool Public-facing Mojolicious app for looking up Heaven's Glaives deaths in any WCL report. The nginx vhost, rc.d script, and the runtime SQLite cache are intentionally excluded via .gitignore. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..35dcb07 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +glaived.fnord.mx.nginx.conf +glaived.rc +lookup.db diff --git a/README.md b/README.md new file mode 100644 index 0000000..0b3e874 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# Heaven's Glaives Lookup + +Died to Heaven's Glaives on Mythic L'ura and want +to know who else ate it? Paste your Warcraft Logs report code in at +**[glaived.fnord.mx](https://glaived.fnord.mx/)** and it'll tell you the death +count for that ability. + +## How to use it + +1. Grab your report code from the Warcraft Logs URL, e.g. + `https://www.warcraftlogs.com/reports/j8aqTD2W9XG4PFxJ` → the code is + `j8aqTD2W9XG4PFxJ`. +2. Paste it into the box on glaived.fnord.mx and hit submit. +3. (Optional) adjust the "ignore after N deaths" cutoff if you want — it + defaults to 2. + +That's it. The link you land on works for sharing later too. + +## What's in this repo + +A small Perl/Mojolicious app (`app.pl`, `lib/WCL.pm`, `templates/`). It talks to the Warcraft Logs API, +caches results, and renders the page. diff --git a/app.pl b/app.pl new file mode 100755 index 0000000..79f3404 --- /dev/null +++ b/app.pl @@ -0,0 +1,219 @@ +#!/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; diff --git a/lib/WCL.pm b/lib/WCL.pm new file mode 100644 index 0000000..7594505 --- /dev/null +++ b/lib/WCL.pm @@ -0,0 +1,110 @@ +package WCL; +use strict; +use warnings; +use JSON::PP; +use MIME::Base64 qw(encode_base64); +use Exporter 'import'; + +our @EXPORT_OK = qw( + wcl_token wcl_query fetch_glaive_deaths + HEAVENS_GLAIVES_ID ENCOUNTER_NAME DIFFICULTY +); + +use constant HEAVENS_GLAIVES_ID => 1254076; +use constant ENCOUNTER_NAME => 'Midnight Falls'; +use constant DIFFICULTY => 5; + +my $FIGHTS_QUERY = <<'GQL'; +query($code: String!) { + reportData { + report(code: $code) { + startTime title + zone { name } + fights { id name difficulty } + } + } +} +GQL + +my $TABLE_QUERY = <<'GQL'; +query($code: String!, $fightIDs: [Int]!, $wipeCutoff: Int!) { + reportData { + report(code: $code) { + table(dataType: Deaths, fightIDs: $fightIDs, wipeCutoff: $wipeCutoff, + startTime: 0, endTime: 999999999999) + } + } +} +GQL + +sub wcl_token { + my ($http, $client_id, $client_secret) = @_; + my $auth = encode_base64("$client_id:$client_secret", ''); + my $resp = $http->post_form( + 'https://www.warcraftlogs.com/oauth/token', + { grant_type => 'client_credentials' }, + { headers => { Authorization => "Basic $auth" } }, + ); + die "WCL token request failed ($resp->{status} $resp->{reason})\n" unless $resp->{success}; + return decode_json($resp->{content})->{access_token}; +} + +sub wcl_query { + my ($http, $token, $query, $variables) = @_; + my $resp = $http->post( + 'https://www.warcraftlogs.com/api/v2/client', + { + headers => { + Authorization => "Bearer $token", + 'Content-Type' => 'application/json', + }, + content => encode_json({ query => $query, variables => $variables // {} }), + }, + ); + die "WCL query failed ($resp->{status} $resp->{reason})\n" unless $resp->{success}; + my $decoded = decode_json($resp->{content}); + return $decoded->{data}; +} + +sub epoch_to_date { + my ($epoch) = @_; + my @t = localtime($epoch); + return sprintf '%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]; +} + +sub fetch_glaive_deaths { + my ($http, $token, $code, $wipe_cutoff) = @_; + + my $fdata = wcl_query($http, $token, $FIGHTS_QUERY, { code => $code }); + my $report = $fdata->{reportData}{report}; + return undef unless $report; + + my @fight_ids = map { $_->{id} } + grep { $_->{name} eq ENCOUNTER_NAME && ($_->{difficulty} // -1) == DIFFICULTY } + @{ $report->{fights} }; + + my @deaths; + if (@fight_ids) { + my $tdata = wcl_query($http, $token, $TABLE_QUERY, { + code => $code, + fightIDs => \@fight_ids, + wipeCutoff => $wipe_cutoff, + }); + my $entries = $tdata->{reportData}{report}{table}{data}{entries} // []; + for my $e (@$entries) { + my $kb = $e->{killingBlow} or next; + next unless ($kb->{guid} // -1) == HEAVENS_GLAIVES_ID; + push @deaths, $e->{name}; + } + } + + return { + title => $report->{title}, + raid_date => epoch_to_date($report->{startTime} / 1000), + zone_name => $report->{zone}{name} // 'Unknown', + fight_count => scalar(@fight_ids), + deaths => \@deaths, + }; +} + +1; diff --git a/public/glaive.jpg b/public/glaive.jpg new file mode 100644 index 0000000..9d66bcd Binary files /dev/null and b/public/glaive.jpg differ diff --git a/templates/lookup.html.ep b/templates/lookup.html.ep new file mode 100644 index 0000000..7c7434c --- /dev/null +++ b/templates/lookup.html.ep @@ -0,0 +1,217 @@ +% layout undef; + + + + + +Heaven's Glaives Lookup + + + + + +

Heaven's Glaives Lookup

+

Paste a Warcraft Logs report code to see Heaven's Glaives deaths (Mythic Midnight Falls / L'ura).

+ +% if (stash('error')) { +
<%= stash('error') %>
+% } + +
+ + + + > + Advanced + + + + + + + +% if (stash('result')) { +

+ <%= stash('result')->{raid_date} %> — <%= stash('result')->{title} %> + <%= stash('total') %> death<%= stash('total') == 1 ? '' : 's' %> +

+

<%= stash('result')->{fight_count} %> Mythic Midnight Falls pull(s) · <%= stash('result')->{zone_name} %>

+ + + +% my $rank = 1; +% for my $row (@{ stash('rows') }) { + +% } +% if (!@{ stash('rows') }) { + +% } + +
#PlayerDeaths
<%= $rank++ %><%= $row->{player_name} %><%= $row->{n} %>
No Heaven's Glaives deaths in this report.
+% } + +% if (@{ stash('recent') // [] }) { +

Recent lookups

+ +% } + + + + +