4 |
5 | Permission is hereby granted, free of charge, to any person obtaining
6 | a copy of this software and associated documentation files (the
7 | "Software"), to deal in the Software without restriction, including
8 | without limitation the rights to use, copy, modify, merge, publish,
9 | distribute, sublicense, and/or sell copies of the Software, and to
10 | permit persons to whom the Software is furnished to do so, subject to
11 | the following conditions:
12 |
13 | The above copyright notice and this permission notice shall be
14 | included in all copies or substantial portions of the Software.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 |
--------------------------------------------------------------------------------
/pages/layout/topbar.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | Terra Mystica
5 |
21 |
22 |
25 |
26 |
27 |
--------------------------------------------------------------------------------
/pages/content/login.pl:
--------------------------------------------------------------------------------
1 | {
2 | layout => 'sidebar',
3 | scripts => [ "/stc/common.js" ],
4 | title => 'Login',
5 | content => read_then_close(*DATA)
6 | }
7 |
8 | __DATA__
9 |
10 |
21 |
28 |
29 |
30 | Trouble logging in? Register an account
31 | or reset your password.
32 |
--------------------------------------------------------------------------------
/pages/content/reset.pl:
--------------------------------------------------------------------------------
1 | {
2 | layout => 'sidebar',
3 | scripts => [ "/stc/common.js",
4 | "/stc/reset.js" ],
5 | title => 'Reset Password',
6 | content => read_then_close(*DATA)
7 | }
8 |
9 | __DATA__
10 |
11 |
19 |
20 |
21 |
22 | A password reset email has been sent to the indicated address.
23 |
24 |
25 | Haven't received the email? Please check:
26 |
27 | That the email is not in your spam folder
28 | That you entered the correct email address above
29 |
30 |
12 | Season 38 of the Terra Mystica tournament will start on August 1st.
13 | Sign ups are now open on the
tournament website , with discussion on the
BGG thread .
14 |
Your Active / Recently Finished Games
17 |
18 |
19 | Games you Administrate
20 |
21 |
22 |
23 |
24 |
37 |
38 |
39 |
--------------------------------------------------------------------------------
/src/DB/Validation.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package DB::Validation;
4 | use Exporter::Easy (EXPORT => [ 'insert_to_validate', 'fetch_validate_payload' ]);
5 |
6 | use Bytes::Random::Secure qw(random_string_from);
7 | use JSON;
8 |
9 | sub insert_to_validate {
10 | my ($dbh, $payload) = @_;
11 |
12 | my $random = Bytes::Random::Secure->new(
13 | Bits => 512,
14 | NonBlocking => 1,
15 | );
16 | my $token = $random->string_from('ABCDEFGHIJKLMNOPQRSTUVXYZ'.
17 | 'abcdefghijklmnopqrstuvxyz'.
18 | '0123456789',
19 | 16);
20 |
21 | $dbh->do(
22 | "insert into to_validate (token, payload) values (?, ?)",
23 | {},
24 | $token, encode_json $payload);
25 |
26 | $token;
27 | }
28 |
29 | sub fetch_validate_payload {
30 | my ($dbh, $token) = @_;
31 |
32 | my @payload = $dbh->selectrow_array(
33 | "select payload from to_validate where token=?",
34 | { Slice => {} },
35 | $token);
36 |
37 | if (!@payload) {
38 | die "Invalid validation token\n";
39 | }
40 |
41 | $dbh->do("update to_validate set executed=true where token=?",
42 | {},
43 | $token);
44 |
45 | decode_json $payload[0];
46 | }
47 |
48 | 1;
49 |
--------------------------------------------------------------------------------
/src/DB/UserValidate.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package DB::UserValidate;
4 | use Exporter::Easy (EXPORT => [ 'check_email_is_registered',
5 | 'check_username_is_registered' ]);
6 |
7 | sub check_email_is_registered {
8 | my ($dbh, $address) = @_;
9 |
10 | my ($username) =
11 | $dbh->selectrow_array("select player from email where address=lower(?) and validated=true",
12 | {},
13 | $address);
14 |
15 | if (!defined $username) {
16 | die "Sorry. Adding unregistered or unvalidated email addresses to games is no longer supported. Please ask your players to register on the site, or to add an alias for their new email address on the settings page.\n";
17 | }
18 |
19 | $username;
20 | }
21 |
22 | sub check_username_is_registered {
23 | my ($dbh, $username) = @_;
24 |
25 | # XXX: primary address support
26 | my ($address, $actual_username) =
27 | $dbh->selectrow_array("select address, player from email where lower(player)=lower(?) and is_primary=true",
28 | {},
29 | $username);
30 |
31 | if (!defined $address) {
32 | die "There is no account with the username '$username'.\n";
33 | }
34 |
35 | ($actual_username, $address);
36 | }
37 |
38 | 1;
39 |
--------------------------------------------------------------------------------
/src/tracker.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -wl
2 |
3 | package terra_mystica;
4 |
5 | use strict;
6 |
7 | use JSON;
8 | use List::Util qw(max);
9 | use Time::HiRes qw(time);
10 |
11 | our $target;
12 |
13 | BEGIN {
14 | $target = shift @ARGV;
15 | unshift @INC, "$target/lib/";
16 | }
17 |
18 | use tracker;
19 |
20 | BEGIN {
21 | eval {
22 | require 'db.pm';
23 | require 'game.pm';
24 | }; if ($@) {
25 | require 'DB/Connection.pm';
26 | DB::Connection->import();
27 | require 'DB/Game.pm';
28 | DB::Game->import();
29 | }
30 | }
31 |
32 | sub print_json {
33 | my $data = shift;
34 | my $out = encode_json $data;
35 |
36 | print $out;
37 | }
38 |
39 |
40 | my $dbh = get_db_connection;
41 |
42 | while (<>) {
43 | my $id = $_;
44 | chomp $id;
45 | my @rows = get_game_commands $dbh, $id;
46 | my $begin = time;
47 |
48 | # @rows = @rows[0..(min $ENV{MAX_ROW}, scalar(@rows)-1)];
49 |
50 | my $res = evaluate_game {
51 | rows => [ @rows ],
52 | faction_info => get_game_factions($dbh, $id),
53 | players => get_game_players($dbh, $id),
54 | metadata => get_game_metadata($dbh, $id),
55 | };
56 | $res->{cost} = time - $begin;
57 | $| = 1;
58 | print_json $res;
59 | if (@{$res->{error}}) {
60 | print STDERR "$target $id: ERROR: $_" for @{$res->{error}};
61 | }
62 | }
63 |
64 |
--------------------------------------------------------------------------------
/stc/alias.js:
--------------------------------------------------------------------------------
1 | function register() {
2 | $("error").innerHTML = "";
3 | $("validate").style.display = "none";
4 |
5 | try {
6 | var fields = ["email"];
7 | var error = "";
8 |
9 | fields.each(function (field) {
10 | $(field).style.backgroundColor = "#fff";
11 | });
12 |
13 | fields.each(function (field) {
14 | if ($(field).value == "") {
15 | $(field).style.backgroundColor = "#fbb";
16 | error += "Field " + field + " must be non-empty
13 |
14 | ID
15 |
16 |
17 | Map
18 |
19 |
20 | Browser not supported.
21 |
22 |
23 |
24 | Data
25 |
26 |
28 |
29 |
30 | Save
31 | Preview
32 |
33 |
34 |
35 | Faction Info (finished)
36 |
37 |
38 | Deviation from expected score, based on performance of other
39 | players, and adjusted for estimated player skill.
40 |
41 |
42 |
43 |
44 | Faction Info (started)
45 |
46 |
47 | Frequency of faction being picked by player count.
48 |
49 |
50 |
51 |
52 |
53 |
54 | Games
55 |
56 |
--------------------------------------------------------------------------------
/src/Util/Watchdog.pm:
--------------------------------------------------------------------------------
1 | package Util::Watchdog;
2 | use Exporter::Easy (EXPORT => [ 'with_watchdog', 'feed_watchdog' ]);
3 |
4 | use Devel::StackTrace;
5 |
6 | sub with_watchdog {
7 | my $alarm_triggered = 0;
8 | my ($timeout, $fun) = @_;
9 |
10 | local $SIG{ALRM} = sub {
11 | $alarm_triggered = 1;
12 | my $trace = Devel::StackTrace->new;
13 | for my $frame ($trace->frames()) {
14 | print STDERR " ", $frame->as_string(), "\n";
15 | last if $frame->subroutine() eq 'Util::Watchdog::with_watchdog';
16 | }
17 |
18 | print "Request timed out\n";
19 | # Treat a watchdog timeout as a fatal error, rather than an
20 | # catchable exception. DBD::Pg is not async signal safe, and
21 | # gets in a permanently corrupted state if we unwind in the
22 | # middle of a DB operation. That instance of the code will
23 | # then not work again, producing user-visible errors until the
24 | # service is manually restarted. So just quit now, and let
25 | # the server process restart.
26 | exit 1;
27 | };
28 |
29 | eval {
30 | alarm $timeout;
31 | $fun->();
32 | };
33 | my $err = $@;
34 |
35 | alarm 0;
36 |
37 | if ($err) {
38 | die $err;
39 | }
40 | }
41 |
42 | sub feed_watchdog {
43 | my ($timeout) = @_;
44 |
45 | die "Can't feed watchdog -- not inside with_watchdog\n" if !$SIG{ALRM};
46 |
47 | alarm $timeout;
48 | }
49 |
50 | 1;
51 |
--------------------------------------------------------------------------------
/src/Game/Factions/Giants.pm:
--------------------------------------------------------------------------------
1 | package Game::Factions::Giants;
2 |
3 | use strict;
4 | use Readonly;
5 |
6 | Readonly our $giants => {
7 | C => 15, W => 3, P1 => 5, P2 => 7,
8 | FIRE => 1, AIR => 1, color => 'red',
9 | display => "Giants",
10 | faction_board_id => 4,
11 | ship => {
12 | level => 0, max_level => 3,
13 | advance_cost => { C => 4, P => 1 },
14 | advance_gain => [ { VP => 2 },
15 | { VP => 3 },
16 | { VP => 4 } ],
17 | },
18 | dig => {
19 | level => 0, max_level => 2,
20 | cost => [ { W => 3 }, { W => 2 }, { W => 1 } ],
21 | advance_cost => { W => 2, C => 5, P => 1 },
22 | advance_gain => [ { VP => 6 },
23 | { VP => 6 } ],
24 | },
25 | buildings => {
26 | D => { advance_cost => { W => 1, C => 2 },
27 | income => { W => [ 1, 2, 3, 4, 5, 6, 7, 8, 8 ] } },
28 | TP => { advance_cost => { W => 2, C => 3 },
29 | income => { C => [ 0, 2, 4, 6, 8 ],
30 | PW => [ 0, 1, 2, 4, 6] } },
31 | TE => { advance_cost => { W => 2, C => 5 },
32 | income => { P => [ 0, 1, 2, 3 ] } },
33 | SH => { advance_cost => { W => 4, C => 6 },
34 | advance_gain => [ { ACTG => 1 } ],
35 | income => { PW => [ 0, 4 ] } },
36 | SA => { advance_cost => { W => 4, C => 6 },
37 | income => { P => [ 0, 1 ] } },
38 | }
39 | };
40 |
--------------------------------------------------------------------------------
/pages/layout/sidebar.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | {$head_title}
5 |
2 | ServerName terra.snellman.net
3 | DocumentRoot /home/jsnell/sites/terra/git/www-prod/
4 |
5 | AddDefaultCharset utf-8
6 |
7 | RewriteEngine on
8 |
9 | RewriteRule ^(/stc/.*)$ $1 [L]
10 | RewriteRule ^(/data/.*)$ $1 [L]
11 | RewriteRule ^/validate/(.*)$ /app/register/validate/$1 [P]
12 | RewriteRule ^/validate-alias/(.*)$ /app/alias/validate/$1 [P]
13 | RewriteRule ^/validate-reset/(.*)$ /app/reset/validate/$1 [P]
14 | RewriteRule ^/((app)/(.*))?$ /$1 [L,PT]
15 |
16 | # RewriteRule ^/down.html$ /down.html [L]
17 | # RewriteRule ^(|/|.*) /down.html [R=307,L]
18 | # RewriteRule ^(|/|/index.html)$ /down.html [P]
19 |
20 | RewriteRule ^/(([a-z]+)/(.*))?$ /app/template/$1 [P]
21 | RewriteRule ^(|/|/index.html)$ /app/template/index [P]
22 |
23 | Options -Indexes +SymLinksIfOwnerMatch
24 |
25 | AddType application/json .json
26 |
27 | Header add "Cache-Control" "public, max-age=864000"
28 |
29 |
30 | FastCgiServer /home/jsnell/sites/terra/git/www-prod/lib/app.fcgi -initial-env ENV=prod -initial-env TM_CONFIG= -processes 5
31 | ScriptAlias /app/ "/home/jsnell/sites/terra/git/www-prod/lib/app.fcgi/"
32 |
33 | ScriptLog ${APACHE_LOG_DIR}/terra-debug.log
34 | ErrorLog ${APACHE_LOG_DIR}/terra-error.log
35 | LogLevel warn
36 | CustomLog ${APACHE_LOG_DIR}/terra-access.log combined
37 |
38 | CustomLog ${APACHE_LOG_DIR}/terra-timing.log "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\" %Dusec"
39 |
40 |
41 |
--------------------------------------------------------------------------------
/pages/content/alias.pl:
--------------------------------------------------------------------------------
1 | {
2 | layout => 'sidebar',
3 | scripts => [ "/stc/common.js",
4 | "/stc/alias.js" ],
5 | title => 'Register Email Alias',
6 | content => read_then_close(*DATA)
7 | }
8 |
9 | __DATA__
10 |
11 |
18 |
19 |
20 | You can register multiple email addresses under the same user
21 | account.
22 |
23 |
24 | Note that if you want to switch your ongoing games to use the new
25 | address, you'll need to ask the game admin to do that change on
26 | a game-by-game basis.
27 |
28 |
30 |
31 | The email alias will be registered as soon as we can validate the new
32 | email address. You should have received an email with the
33 | subject "Email alias validation for Terra Mystica". Please click on
34 | the link in that message to activate the new address.
35 |
36 |
37 | Haven't received the email? Please check:
38 |
39 | That the email is not in your spam folder
40 | That you entered the correct email address above
41 |
42 |
13 |
14 |
15 |
Metadata
16 |
Active
17 |
Finished
18 |
Stats
19 |
Opponents
20 |
21 |
25 |
26 |
27 |
Active / Recently Finished Games
28 |
29 |
30 |
31 |
32 |
Finished Games
33 |
34 |
35 |
36 |
37 |
Faction Statistics
38 |
Faction Wins Games Win % Average score Max score Ranks
39 |
40 |
41 |
42 |
Opponent Statistics
43 |
Opponent Games Player better Opponent better Draw
44 |
45 |
11 |
20 |
21 |
22 | The username should consist only of the letters A-Z and a-z, the
23 | digits 0-9, and the punctuation characters .
24 | _ and - .
25 |
26 |
27 | A valid email address is required, both for administration like
28 | password resets, and for facilitating email play. The address
29 | might be shown to any users playing in the same match, but not
30 | to any outsiders.
31 |
32 |
34 |
35 | Request sent.
36 |
37 | Your account will be created as soon as we can validate your
38 | email address. You should have received an email with the
39 | subject "Account activation for Terra Mystica". Please click on
40 | the link in that message to activate your account.
41 |
42 |
43 | Haven't received the email? Please check:
44 |
45 | That the email is not in your spam folder
46 | That you entered the correct email address above
47 |
48 |
11 |
53 |
56 |
--------------------------------------------------------------------------------
/src/Analyze/EloVpPredictor.pm:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -wl
2 |
3 | package Analyze::EloVpPredictor;
4 | use Exporter::Easy (EXPORT => ['faction_vp_error_by_map']);
5 |
6 | use strict;
7 |
8 | use DBI;
9 | use File::Slurp;
10 | use JSON;
11 | use List::Util qw(sum);
12 | use Statistics::Descriptive;
13 |
14 | use Analyze::RatingData;
15 |
16 | sub faction_vp_error_by_map {
17 | my ($dbh, $map) = @_;
18 |
19 | my $players = $dbh->selectall_hashref("select player, rating as score from player_ratings",
20 | 'player');
21 |
22 | my %stats = ();
23 |
24 | my $results = read_rating_data $dbh, sub {
25 | my $res = shift;
26 | return $res->{base_map} &&
27 | $res->{base_map} eq $map;
28 | }, {include_unranked => 1 };
29 |
30 | my %diffs = ();
31 | my %counts = ();
32 | for my $record (@{$results->{results}}) {
33 | my $a_vp = $record->{a}{vp};
34 | my $b_vp = $record->{b}{vp};
35 |
36 | my $a_elo = $players->{$record->{a}{username}}{score};
37 | my $b_elo = $players->{$record->{b}{username}}{score};
38 |
39 | my $a_faction = $record->{a}{faction};
40 | my $b_faction = $record->{b}{faction};
41 |
42 | next if $record->{a}{dropped} or $record->{b}{dropped};
43 | next if !$a_elo or !$b_elo;
44 |
45 | my $d_vp = $a_vp - $b_vp;
46 | my $d_elo = $a_elo - $b_elo;
47 | my $e_vp = $d_elo / 10;
48 |
49 | push @{$diffs{$a_faction}}, $d_vp - $e_vp;
50 | push @{$diffs{$b_faction}}, -($d_vp - $e_vp);
51 |
52 | for my $f ($a_faction, $b_faction) {
53 | $counts{$f}{$record->{id}}++;
54 | }
55 | }
56 |
57 | my %stat = map {
58 | my $stat = Statistics::Descriptive::Full->new();
59 | $stat->add_data(@{$diffs{$_}});
60 | my $count = scalar keys %{$counts{$_}};
61 | ($_, {
62 | count => $count,
63 | mean => $stat->mean(),
64 | sterr => $stat->standard_deviation() / sqrt($count),
65 | });
66 | } keys %diffs;
67 |
68 | \%stat;
69 | }
70 |
71 | 1;
72 |
--------------------------------------------------------------------------------
/src/Analyze/BuildStats/builds.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -lw
2 |
3 | package terra_mystica;
4 |
5 | use strict;
6 |
7 | use DBI;
8 | use Digest::SHA qw(sha1_hex);
9 | use JSON;
10 | use POSIX;
11 | use File::Basename qw(dirname);
12 | use List::Util qw(sum);
13 |
14 | BEGIN { push @INC, "$ENV{PWD}/src/"; }
15 |
16 | use Analyze::RatingData;
17 | use DB::Connection;
18 | use DB::Game;
19 | use tracker;
20 |
21 | my $dbh = get_db_connection;
22 |
23 | my $results = read_rating_data $dbh, sub {
24 | my $res = shift;
25 |
26 | return 0 if $res->{player_count} != 4;
27 |
28 | # return 0 if sha1_hex($res->{game}) !~ /^f0/;
29 | $res->{base_map} //= '126fe960806d587c78546b30f1a90853b1ada468';
30 | # return 0 if !defined $res->{base_map};
31 |
32 | # return 0 if ($res->{base_map} // '') ne 'c07f36f9e050992d2daf6d44af2bc51dca719c46';
33 |
34 | return 1;
35 | }, { include_unranked => 1};
36 |
37 | for my $id (keys %{$results->{games}}) {
38 | my $game = $results->{games}{$id};
39 | my @rows = get_game_commands $dbh, $id;
40 | my @command_stream = ();
41 |
42 | my $row = 0;
43 | for (@rows) {
44 | eval { push @command_stream, clean_commands $_ };
45 | if ($@) {
46 | chomp;
47 | print STDERR "Error on line $row [$_]:";
48 | print STDERR "$@\n";
49 | last;
50 | }
51 | $row++;
52 | }
53 |
54 | my %record = ();
55 | $record{id} = $id;
56 |
57 | for my $row (@command_stream) {
58 | my $faction = $row->[0];
59 | next if !$faction;
60 | next if $faction eq 'comment';
61 | if ($faction eq 'riverwalkers' or $faction eq 'shapeshifters') {
62 | $faction .= "_v5";
63 | }
64 | while ($row->[1] =~ /^build (\S+)/gi) {
65 | push @{$record{factions}{$faction}{builds}}, $1;
66 | }
67 | }
68 |
69 | for my $faction (keys %{$game->{factions}}) {
70 | for my $key (qw(vp rank)) {
71 | $record{factions}{$faction}{$key} = $game->{factions}{$faction}{$key};
72 | }
73 | }
74 |
75 | print encode_json \%record;
76 | }
77 |
--------------------------------------------------------------------------------
/pages/content/stats.pl:
--------------------------------------------------------------------------------
1 | {
2 | layout => 'sidebar',
3 | scripts => [ "/stc/common.js",
4 | "/stc/stats.js"],
5 | title => 'Statistics',
6 | content => read_then_close(*DATA)
7 | }
8 |
9 | __DATA__
10 |
11 |
12 | Settings
13 |
14 |
15 | Player count
17 | 3-5p
18 | 2p
19 | 3p
20 | 4p
21 | 5p
22 |
23 |
24 |
25 |
26 | Final scoring
28 | Any
29 | Original
30 | Expansion
31 |
32 |
33 |
34 |
35 | Map
37 | Any
38 | Original
39 | Original [2017 vp]
40 | Fire & Ice Side 1
41 | Fire & Ice Side 2
42 | Loon Lakes v1.6
43 | Fjords v2.1
44 |
45 |
46 |
47 |
48 | Rating
50 | All games
51 | All players rated 1000+
52 | All players rated 1250+
53 |
54 |
55 |
56 |
57 | Statistics computed from ? finished games.
58 |
59 |
Faction Statistics
60 |
61 |
62 |
63 |
64 | High Scores
65 |
66 |
67 |
68 | Start Position Statistics
69 |
70 |
71 |
72 |
73 |
74 |
75 |
--------------------------------------------------------------------------------
/src/Util/PageGenerator.pm:
--------------------------------------------------------------------------------
1 | package Util::PageGenerator;
2 | use Exporter::Easy (EXPORT => [ 'generate_page' ]);
3 |
4 | use strict;
5 |
6 | use Digest::SHA qw(sha1_hex);
7 | use File::Slurp qw(read_file);
8 | use JSON;
9 | use Text::Template;
10 |
11 | my %page_data_cache = ();
12 |
13 | sub get_page_data {
14 | my ($dir, $name) = @_;
15 | my $content_file = "$dir/content/$name.pl";
16 | die "No content file '$content_file'\n" if !-f $content_file;
17 | my $mtime = (stat($content_file))[9];
18 |
19 | if (!defined $page_data_cache{$content_file}{mtime} or
20 | $mtime > $page_data_cache{$content_file}{mtime}) {
21 | $page_data_cache{$content_file}{mtime} = $mtime;
22 | $page_data_cache{$content_file}{content} = do $content_file;
23 | }
24 |
25 | $page_data_cache{$content_file}{content};
26 | }
27 |
28 | sub generate_page {
29 | my ($root, $name, $params) = @_;
30 | my $dir = "$root/pages/";
31 |
32 | $name =~ s/[^a-z]//g;
33 | my $data = get_page_data $dir, $name;
34 |
35 | if ($data->{title} and $data->{title} !~ /Terra Mystica/) {
36 | $data->{head_title} = "$data->{title} - Terra Mystica";
37 | } else {
38 | $data->{head_title} = $data->{title};
39 | }
40 |
41 | my $layout = "$dir/layout/$data->{layout}.html";
42 | my $template = Text::Template->new(TYPE => 'FILE',
43 | SOURCE => $layout);
44 | die "Could not render page '$name', layout '$layout'\n" if !$template;
45 |
46 | if ($data->{require_access}) {
47 | if ($data->{require_access} ne $params->{access}) {
48 | print STDERR "Access denied to $name: ", encode_json $params, "\n";
49 | die "Access restricted\n";
50 | }
51 | }
52 |
53 | $data->{root} = $root;
54 |
55 | return $template->fill_in(HASH => $data);
56 | }
57 |
58 | sub static_resource_link {
59 | my ($root, $path) = @_;
60 |
61 | if ($path =~ /^http/) {
62 | return $path;
63 | } else {
64 | my $path_content = read_file "$root/$path";
65 | my $csum = sha1_hex $path_content;
66 | return "$path?tag=$csum";
67 | }
68 | }
69 |
70 | sub read_then_close {
71 | my ($fh) = @_;
72 | my $data = join '', <$fh>;
73 | close $fh;
74 | $data;
75 | }
76 |
77 | 1;
78 |
--------------------------------------------------------------------------------
/src/Server/Results.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Results;
4 |
5 | use Moose;
6 | use Server::Server;
7 | use Method::Signatures::Simple;
8 |
9 | extends 'Server::Server';
10 |
11 | use DB::Connection;
12 | use DB::Game;
13 | use DB::Secret;
14 |
15 | method handle($q, $params) {
16 | my $dbh = get_db_connection;
17 | my ($secret, $iv) = get_secret $dbh;
18 | my %params = ();
19 | my $version = 'v1';
20 | my @valid_versions = qw(v1 v2);
21 |
22 | if ($params =~ s{^v(\d+)/}{}) {
23 | $version = $1;
24 | my %valid_versions = map { ($_ => 1) } @valid_versions;
25 |
26 | if (!$valid_versions{"v$version"}) {
27 | die "Invalid version 'v$version'. (Valid values: @valid_versions)\n";
28 | }
29 | }
30 |
31 | if ($params =~ m{^(\d+)/(\d+)(?:/(\d+))?$}) {
32 | %params = (year => $1, month => $2, day => $3);
33 | } else {
34 | die "Year/month not specified (e.g. /app/results/$version/2014/01). Day is optional (e.g. /app/results/$version/2014/01/01)\n"
35 | }
36 |
37 | my $results = {
38 | version => $version,
39 | get_finished_game_results $dbh, $secret, %params
40 | };
41 |
42 | if ($version > 1) {
43 | $results->{games} = {};
44 | $results->{players} = {};
45 |
46 | for (@{$results->{results}}) {
47 | my $game = ($results->{games}{$_->{game}} //= {
48 | expansion_scoring => $_->{non_standard},
49 | player_count => $_->{player_count},
50 | base_map => ($_->{base_map} || '126fe960806d587c78546b30f1a90853b1ada468'),
51 | options => $_->{options},
52 | last_update => $_->{last_update},
53 | });
54 | delete $_->{options};
55 | delete $_->{non_standard};
56 | delete $_->{player_count};
57 | delete $_->{last_update};
58 | delete $_->{base_map};
59 |
60 | $results->{players}{$_->{id_hash}} //= {
61 | username => $_->{username}
62 | };
63 | delete $_->{username};
64 | delete $_->{game};
65 |
66 | push @{$game->{players}}, $_;
67 | }
68 |
69 | delete $results->{results};
70 | }
71 |
72 | $self->output_json($results);
73 | }
74 |
75 | 1;
76 |
77 |
--------------------------------------------------------------------------------
/src/Server/Server.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Server;
4 |
5 | use JSON;
6 | use Moose;
7 | use Method::Signatures::Simple;
8 |
9 | has 'headers' => (is => '',
10 | traits => ['Array'],
11 | default => sub { [] },
12 | handles => {
13 | headers => 'elements',
14 | push_header => 'push',
15 | });
16 | has 'status' => (is => 'rw',
17 | default => 200);
18 | has 'output' => (is => 'rw',
19 | default => '');
20 | has 'cookies' => (is => 'rw',
21 | default => sub { {} });
22 |
23 | method set_header($header, $value) {
24 | $self->push_header($header);
25 | $self->push_header($value);
26 | }
27 |
28 | method output_psgi {
29 | [$self->status,
30 | [ $self->headers() ],
31 | [ $self->output() ]];
32 | };
33 |
34 | method redirect($where) {
35 | $self->status(303);
36 | $self->set_header("Location", $where);
37 | }
38 |
39 | method allow_cross_domain($where) {
40 | $self->set_header("Access-Control-Allow-Origin", "*");
41 | }
42 |
43 | method no_cache() {
44 | $self->set_header("Cache-Control", "no-cache");
45 | }
46 |
47 | method output_json($data) {
48 | $self->output_cookies();
49 | $self->set_header("Content-type", "application/json");
50 | $self->output(encode_json($data));
51 | }
52 |
53 | method output_html($data) {
54 | $self->output_cookies();
55 | $self->set_header("Content-type", "text/html");
56 | $self->output($data);
57 | }
58 |
59 | method handle($q) {
60 | die "Server::Server::handle() not implemented";
61 | }
62 |
63 | around handle => sub {
64 | my ($orig, $self, @args) = @_;
65 | eval {
66 | $self->$orig(@args);
67 | }; if ($@) {
68 | $self->status(500);
69 | $self->output_json({ error => [ "$@" ] });
70 | }
71 | };
72 |
73 | method output_cookies() {
74 | for my $key (keys %{$self->cookies()}) {
75 | my $data = $self->cookies()->{$key};
76 | my $value = $data->[0];
77 | my @attributes = @{$data->[1]};
78 | $self->set_header("Set-Cookie",
79 | join '; ', "$key=$value", @attributes);
80 | }
81 | }
82 |
83 | method set_cookie($field, $value, $attributes) {
84 | $self->cookies()->{$field} = [$value, $attributes];
85 | }
86 |
87 | 1;
88 |
--------------------------------------------------------------------------------
/pages/content/forcedreset.pl:
--------------------------------------------------------------------------------
1 | {
2 | layout => 'sidebar',
3 | scripts => [ "/stc/common.js",
4 | "/stc/reset.js" ],
5 | title => 'Reset Password',
6 | content => read_then_close(*DATA)
7 | }
8 |
9 | __DATA__
10 |
11 | Sorry, you have to change your password before you can log in
12 | again.
13 |
14 |
15 |
16 | Q: Why do I have to do this?
17 |
18 |
19 | Somebody has been automatically trying to log in to the site on a large number of accounts using very common passwords, such as 'password' or '123456'. In some cases they've then proceeded to enter (bad) moves for a player whose password they'd guessed.
20 |
21 | Your account appears to also use a very weak password (either derived from your username, from the name of this site, or present in lists of very common passwords). To prevent the same from being done to your account (or to stop it, if it's already happening) you will need to change to a better password before anything else can be done with this account.
22 |
23 |
24 | Q: Why do I have to enter my email address here?
25 |
26 | All password changes are validated by sending an email to one of
27 | the email addresses you've registered with, to validate that it's
28 | really the account owner changing the password.
29 |
30 |
31 |
32 |
40 |
41 |
42 |
43 | A password reset email has been sent to the indicated address.
44 |
45 |
46 | Haven't received the email? Please check:
47 |
48 | That the email is not in your spam folder
49 | That you entered the correct email address above
50 |
51 |
" +
12 | (mapNamesById[elem.key] || elem.key) + " ")
13 | $H(elem.value.factions).each(function(elem) {
14 | factions[elem.key] = 1;
15 | });
16 | });
17 | $H(factions).sortBy(function(a, b) { return a.key }).each(function(elem) {
18 | var opt = new Element("option", { "value": elem.key }).updateText(
19 | factionPrettyName[elem.key]);
20 | setFactionStyleForElement(opt, elem.key);
21 | $("factionid").insert(opt);
22 | });
23 |
24 | $("rankid").insert("1 ");
25 | $("rankid").insert("2 ");
26 | $("rankid").insert("3 ");
27 | $("rankid").insert("4 ");
28 | $("rankid").insert("Any ");
29 |
30 | if (hash) {
31 | var hash = hash.substr(1);
32 | var components = hash.split(',');
33 | if (components.length) {
34 | $("mapid").value = components.shift();
35 | }
36 | if (components.length) {
37 | $("factionid").value = components.shift();
38 | }
39 | if (components.length) {
40 | $("rankid").value = components.shift();
41 | }
42 | }
43 | }
44 |
45 | function updateBuildHeatmap() {
46 | state = {};
47 | var by_map = builds[$("mapid").value];
48 | state.map = by_map.base_map;
49 | state.bridges = [];
50 | $H(state.map).each(function(elem) {
51 | var hex = elem.value;
52 | hex.label = '';
53 | if (hex.color != 'white') { hex.forceColor='#fff'; }
54 | });
55 | var by_faction = by_map.factions[$("factionid").value][$("rankid").value];
56 | $H(by_faction.build).each(function(elem) {
57 | var id = elem.key;
58 | var hex = state.map[id];
59 | var freq = elem.value / by_faction.games;
60 | hex.label = Math.floor(freq * 100) + "%";
61 | hex.forceColor = "rgb(255, " + Math.floor((1 - freq) * 255) + ", 255)";
62 | });
63 | $("gamescount").updateText(by_faction.games);
64 | drawMap();
65 |
66 | document.location.hash = $("mapid").value + "," + $("factionid").value + "," + $("rankid").value;
67 | setFactionStyleForElement($("factionid"), $("factionid").value);
68 | }
69 |
70 | function loadBuildHeatmap() {
71 | var target = "/data/buildstats.json";
72 | new Ajax.Request(target, {
73 | method: "get",
74 | parameters: {
75 | "cache-token": new Date() - Math.random(),
76 | },
77 | onSuccess: function(transport) {
78 | builds = transport.responseText.evalJSON();
79 | updateHeatmapOptions(document.location.hash);
80 | updateBuildHeatmap();
81 | $("map").show();
82 | }
83 | });
84 | }
85 |
--------------------------------------------------------------------------------
/src/Game/Factions/Icemaidens.pm:
--------------------------------------------------------------------------------
1 | package Game::Factions::Icemaidens;
2 |
3 | use strict;
4 | use Readonly;
5 |
6 | Readonly our $icemaidens => {
7 | C => 15, W => 3, P1 => 6, P2 => 6,
8 | GAIN_FAVOR => 1,
9 | PICK_COLOR => 1,
10 | WATER => 1, AIR => 1,
11 | color => 'ice',
12 | secondary_color => undef,
13 | display => "Ice Maidens",
14 | faction_board_id => undef,
15 | ship => {
16 | level => 0, max_level => 3,
17 | advance_cost => { C => 4, P => 1 },
18 | advance_gain => [ { VP => 2 }, { VP => 3 }, { VP => 4 } ],
19 | },
20 | dig => {
21 | level => 0, max_level => 2,
22 | cost => [ { W => 3 }, { W => 2 }, { W => 1 } ],
23 | advance_cost => { C => 5, W => 1, P => 1 },
24 | advance_gain => [ { VP => 6 },
25 | { VP => 6 } ],
26 | },
27 | buildings => {
28 | D => { advance_cost => { W => 1, C => 2 },
29 | income => { W => [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ] } },
30 | TP => { advance_cost => { W => 2, C => 3 },
31 | income => { C => [ 0, 2, 4, 6, 8 ],
32 | PW => [ 0, 1, 2, 4, 6 ] } },
33 | TE => { advance_cost => { W => 2, C => 5 },
34 | income => { P => [ 0, 1, 2, 3 ] } },
35 | SH => { advance_cost => { W => 4, C => 6 },
36 | pass_vp => [
37 | {},
38 | { TE => [0, 3, 6, 9] }
39 | ],
40 | income => { PW => [ 0, 4 ] } },
41 | SA => { advance_cost => { W => 4, C => 6 },
42 | income => { P => [ 0, 1 ] } },
43 | }
44 | };
45 |
46 | Readonly our $icemaidens_playtest_v1 => {
47 | C => 15, W => 3, P1 => 6, P2 => 6,
48 | GAIN_FAVOR => 1,
49 | PICK_COLOR => 1,
50 | WATER => 1, AIR => 1,
51 | color => 'ice',
52 | secondary_color => undef,
53 | display => "Ice Maidens",
54 | faction_board_id => undef,
55 | ship => {
56 | level => 0, max_level => 3,
57 | advance_cost => { C => 4, P => 1 },
58 | advance_gain => [ { VP => 2 }, { VP => 3 }, { VP => 4 } ],
59 | },
60 | dig => {
61 | level => 0, max_level => 2,
62 | cost => [ { W => 3 }, { W => 2 }, { W => 1 } ],
63 | advance_cost => { C => 5, P => 1 },
64 | advance_gain => [ { VP => 6 },
65 | { VP => 6 } ],
66 | },
67 | buildings => {
68 | D => { advance_cost => { W => 1, C => 2 },
69 | income => { W => [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ] } },
70 | TP => { advance_cost => { W => 2, C => 3 },
71 | income => { C => [ 0, 2, 4, 6, 8 ],
72 | PW => [ 0, 1, 2, 4, 6 ] } },
73 | TE => { advance_cost => { W => 2, C => 5 },
74 | income => { P => [ 0, 1, 2, 3 ] } },
75 | SH => { advance_cost => { W => 4, C => 6 },
76 | pass_vp => [
77 | {},
78 | { TE => [0, 3, 6, 9] }
79 | ],
80 | income => { PW => [ 0, 4 ] } },
81 | SA => { advance_cost => { W => 4, C => 6 },
82 | income => { P => [ 0, 1 ] } },
83 | }
84 | };
85 |
--------------------------------------------------------------------------------
/src/Server/ListGames.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::ListGames;
4 |
5 | use Moose;
6 | use Method::Signatures::Simple;
7 | use Server::Server;
8 |
9 | extends 'Server::Server';
10 |
11 | use CGI qw(:cgi);
12 |
13 | use DB::Connection;
14 | use DB::EditLink;
15 | use DB::Game;
16 | use DB::UserInfo;
17 | use Util::NaturalCmp;
18 | use Server::Session;
19 |
20 | has 'mode' => (is => 'ro', required => 1);
21 |
22 | method handle($q, $path_suffix) {
23 | $self->no_cache();
24 | $self->set_header("Connection", "Close");
25 |
26 | ensure_csrf_cookie $q, $self;
27 |
28 | my $dbh = get_db_connection;
29 | my $mode = $q->param('mode') // $self->mode() // 'all';
30 | my $status = $q->param('status') // 'running';
31 |
32 | my %res = (error => []);
33 |
34 | if ($mode eq 'user' or $mode eq 'admin' or $mode eq 'other-user') {
35 | my $user = username_from_session_token($dbh,
36 | $q->cookie('session-token') // '');
37 | if ($mode eq 'other-user') {
38 | $user = $q->param("args");
39 | } else {
40 | eval {
41 | verify_csrf_cookie_or_die $q, $self;
42 | }; if ($@) {
43 | $self->output_json({ error => ["csrf-error"] });
44 | return;
45 | }
46 | }
47 |
48 | my %status = (finished => 1, running => 0);
49 | $self->user_games($dbh,
50 | \%res,
51 | $user,
52 | $mode,
53 | $status{$status},
54 | 1*!!($mode eq 'admin'));
55 | } elsif ($mode eq 'open') {
56 | my $user = username_from_session_token($dbh,
57 | $q->cookie('session-token') // '');
58 | $self->open_games($dbh, \%res, $user);
59 | } elsif ($mode eq 'by-pattern') {
60 | $self->allow_cross_domain();
61 | my $pattern = $path_suffix;
62 | $pattern =~ s/[*]/%/g;
63 | $res{games} = get_game_list_by_pattern $dbh, $pattern;
64 | $res{error} = [];
65 | }
66 |
67 | $self->output_json({%res});
68 | }
69 |
70 | method open_games($dbh, $res, $user) {
71 | if (!defined $user) {
72 | $res->{error} = ["Not logged in (login) "];
73 | } else {
74 | my $user_info = fetch_user_metadata $dbh, $user;
75 | my $user_rating = $user_info->{rating} // 0;
76 | my $games = get_open_game_list $dbh;
77 | for my $game (@{$games}) {
78 | if (grep { $_ eq $user } @{$game->{players}}) {
79 | next;
80 | }
81 | if (($game->{minimum_rating} and
82 | $game->{minimum_rating} > $user_rating) or
83 | ($game->{maximum_rating} and
84 | $game->{maximum_rating} < $user_rating)) {
85 | $game = undef;
86 | }
87 | }
88 | $res->{games} = [ grep { $_ } @{$games} ];
89 | }
90 | }
91 |
92 | method user_games($dbh, $res, $user, $mode, $status, $admin) {
93 | if (!defined $user) {
94 | $res->{error} = ["Not logged in (login) "]
95 | } else {
96 | $res->{games} = get_user_game_list $dbh, $user, $mode, $status, $admin;
97 | }
98 | }
99 |
100 | 1;
101 |
--------------------------------------------------------------------------------
/src/Server/Plan.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Plan;
4 |
5 | use Moose;
6 | use Server::Server;
7 |
8 | extends 'Server::Server';
9 |
10 | use Crypt::CBC;
11 | use DB::Connection;
12 | use DB::Secret;
13 | use Server::Security;
14 | use Server::Session;
15 |
16 | sub verify_key {
17 | my ($dbh, $id, $faction_key, $faction_name) = @_;
18 | my ($secret, $iv) = get_secret $dbh;
19 |
20 | my $cipher = Crypt::CBC->new(-key => $secret,
21 | -blocksize => 8,
22 | -iv => $iv,
23 | -add_header => 0,
24 | -cipher => 'Blowfish');
25 | my $data = $cipher->decrypt(pack "h*", $faction_key);
26 | my $game_secret = unpack("h*", $data ^ $faction_name);
27 |
28 | my $write_id = "${id}_$game_secret";
29 | my $valid = $dbh->selectrow_array("select count(*) from game where write_id=?", {}, $write_id);
30 |
31 | die "Invalid faction key\n" if !$valid;
32 | };
33 |
34 | sub handle {
35 | my ($self, $q) = @_;
36 | $self->no_cache();
37 |
38 | my $dbh = get_db_connection;
39 |
40 | my $id = $q->param('game');
41 | $id =~ s{.*/}{};
42 | $id =~ s{[^A-Za-z0-9_]}{}g;
43 |
44 | my $faction_name = $q->param('preview-faction');
45 | my $faction_key = $q->param('faction-key');
46 | my $set_note = $q->param('set-note');
47 |
48 | my $username = username_from_session_token($dbh,
49 | $q->cookie('session-token') // '');
50 | my %res = (error => []);
51 |
52 | eval {
53 | if (!$username) {
54 | die "Not logged in\n";
55 | }
56 |
57 | if ($faction_key eq '') {
58 | get_write_id_for_user $dbh, $username, $id, $faction_name;
59 | } else {
60 | verify_key $dbh, $id, $faction_key, $faction_name;
61 |
62 | my $faction_player = $dbh->selectrow_array(
63 | "select faction_player from game_role where game=? and faction=?",
64 | {},
65 | $id,
66 | $faction_name);
67 |
68 | if ($username ne $faction_player) {
69 | die "Trying to read another player's notes?\n";
70 | }
71 | }
72 |
73 | if (defined $set_note) {
74 | $res{note} = $set_note;
75 |
76 | $dbh->do('begin');
77 | my $res = $dbh->do(
78 | "delete from game_note where faction = ? and game = ?",
79 | {},
80 | $faction_name,
81 | $id);
82 | $res = $dbh->do(
83 | "insert into game_note (faction, game, note, author) values (?, ?, ?, ?)",
84 | {},
85 | $faction_name,
86 | $id,
87 | $set_note,
88 | $username);
89 | $dbh->do('commit');
90 | } else {
91 | my $rows = $dbh->selectall_arrayref(
92 | "select note from game_note where faction = ? and game = ? and author = ?",
93 | {},
94 | $faction_name,
95 | $id,
96 | $username);
97 | $res{note} = $rows->[0][0];
98 | }
99 | }; if ($@) {
100 | $res{error} = [ "$@" ];
101 | }
102 |
103 | $self->output_json(\%res);
104 | }
105 |
106 |
107 |
--------------------------------------------------------------------------------
/src/Game/Factions/Yetis.pm:
--------------------------------------------------------------------------------
1 | package Game::Factions::Yetis;
2 |
3 | use strict;
4 | use Readonly;
5 |
6 | my @power_action_names = map { "ACT$_" } 1..6;
7 |
8 | Readonly our $yetis => {
9 | C => 15, W => 3, P1 => 0, P2 => 12,
10 | PICK_COLOR => 1,
11 | EARTH => 1, AIR => 1,
12 | discount => {
13 | (map { ($_ => { PW => 1 }) } @power_action_names),
14 | },
15 | color => 'ice',
16 | secondary_color => undef,
17 | display => "Yetis",
18 | faction_board_id => undef,
19 | building_strength => {
20 | SH => 4,
21 | SA => 4,
22 | },
23 | ship => {
24 | level => 0, max_level => 3,
25 | advance_cost => { C => 4, P => 1 },
26 | advance_gain => [ { VP => 2 },
27 | { VP => 3 },
28 | { VP => 4 } ],
29 | },
30 | dig => {
31 | level => 0, max_level => 2,
32 | cost => [ { W => 3 }, { W => 2 }, { W => 1 } ],
33 | advance_cost => { W => 1, C => 5, P => 1 },
34 | advance_gain => [ { VP => 6 },
35 | { VP => 6 } ],
36 | },
37 | buildings => {
38 | D => { advance_cost => { W => 1, C => 2 },
39 | income => { W => [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ] } },
40 | TP => { advance_cost => { W => 2, C => 3 },
41 | income => { C => [ 0, 2, 4, 6, 8 ],
42 | PW => [ 0, 2, 4, 6, 8 ] } },
43 | TE => { advance_cost => { W => 2, C => 5 },
44 | income => { P => [ 0, 1, 2, 3 ] } },
45 | SH => { advance_cost => { W => 4, C => 6 },
46 | advance_gain => [ {
47 | allow_reuse => {
48 | (map { ($_ => 1) } @power_action_names),
49 | }} ],
50 | income => { PW => [ 0, 4 ] } },
51 | SA => { advance_cost => { W => 4, C => 6 },
52 | income => { P => [ 0, 1 ] } },
53 | }};
54 |
55 | Readonly our $yetis_playtest_v1 => {
56 | C => 15, W => 3, P1 => 0, P2 => 12,
57 | PICK_COLOR => 1,
58 | EARTH => 1, AIR => 1,
59 | discount => {
60 | (map { ($_ => { PW => 1 }) } @power_action_names),
61 | },
62 | color => 'ice',
63 | secondary_color => undef,
64 | display => "Yetis",
65 | faction_board_id => undef,
66 | building_strength => {
67 | SH => 4,
68 | SA => 4,
69 | },
70 | ship => {
71 | level => 0, max_level => 3,
72 | advance_cost => { C => 4, P => 1 },
73 | advance_gain => [ { VP => 2 },
74 | { VP => 3 },
75 | { VP => 4 } ],
76 | },
77 | dig => {
78 | level => 0, max_level => 2,
79 | cost => [ { W => 3 }, { W => 2 }, { W => 1 } ],
80 | advance_cost => { W => 1, C => 5, P => 1 },
81 | advance_gain => [ { VP => 6 },
82 | { VP => 6 } ],
83 | },
84 | buildings => {
85 | D => { advance_cost => { W => 1, C => 2 },
86 | income => { W => [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ] } },
87 | TP => { advance_cost => { W => 2, C => 3 },
88 | income => { C => [ 0, 2, 4, 6, 8 ],
89 | PW => [ 0, 2, 4, 6, 8 ] } },
90 | TE => { advance_cost => { W => 2, C => 5 },
91 | income => { P => [ 0, 1, 2, 3 ] } },
92 | SH => { advance_cost => { W => 4, C => 6 },
93 | advance_gain => [ {
94 | allow_reuse => {
95 | (map { ($_ => 1) } @power_action_names),
96 | }} ],
97 | income => { PW => [ 0, 4 ] } },
98 | SA => { advance_cost => { W => 4, C => 6 },
99 | income => { P => [ 0, 1 ] } },
100 | }};
101 |
--------------------------------------------------------------------------------
/src/diffgamelist.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -wl
2 |
3 | use strict;
4 | use warnings;
5 |
6 | use File::Basename qw(dirname);
7 | use IPC::Open2;
8 | use JSON;
9 | use Text::Diff qw(diff);
10 |
11 | BEGIN { push @INC, dirname $0 };
12 |
13 | use DB::Connection;
14 |
15 | my $dir = dirname $0;
16 | my $time = 'total';
17 | my %time = ();
18 |
19 | my %procs = ();
20 | sub get_proc {
21 | my ($target) = @_;
22 | if (!$procs{$target}) {
23 | my $pid = open2(my $reader, my $writer, "perl $dir/listgames.pl $target");
24 | $procs{$target} = {
25 | output => $reader,
26 | input => $writer,
27 | pid => $pid,
28 | };
29 | }
30 |
31 | return $procs{$target};
32 | }
33 |
34 | sub request_result {
35 | my ($target, $game) = @_;
36 | my $proc = get_proc $target;
37 | my $in = $proc->{input};
38 |
39 | print $in "$game";
40 | }
41 |
42 | sub fetch_result {
43 | my ($target, $game) = @_;
44 | my $proc = get_proc $target;
45 | my $out = $proc->{output};
46 | my $res = <$out>;
47 | my $json = decode_json $res;
48 | my $cost = $json->{cost};
49 |
50 | if ($time eq 'total') {
51 | $time{$target} += $cost;
52 | } elsif ($time eq 'single') {
53 | printf " %s: %5.3f\n", $target, $cost;
54 | }
55 |
56 | for (@{$json->{res}}) {
57 | if (defined $_->{seconds_since_update}) {
58 | $_->{seconds_since_update} = int $_->{seconds_since_update};
59 | }
60 | }
61 |
62 | $json;
63 | }
64 |
65 | my ($dir1, $dir2) = (shift, shift);
66 |
67 | my $dbh = get_db_connection;
68 |
69 | my @modes = ("user 0 0",
70 | "other-user 0 0",
71 | "user 1 0",
72 | "user 0 1");
73 |
74 | my $players = $dbh->selectall_arrayref("select username from player",
75 | {});
76 |
77 | my @queries = ();
78 | for my $player (@{$players}) {
79 | $player = $player->[0];
80 | for my $mode (@modes) {
81 | push @queries, "$player $mode";
82 | }
83 | }
84 |
85 | my $count = 0;
86 | for (@queries) {
87 | my $id = $_;
88 | ++$count;
89 |
90 | {
91 | local $| = 1;
92 | printf ".";
93 | }
94 |
95 | if ($count % 75 == 0) {
96 | print "\n";
97 | if ($time eq 'total') {
98 | for my $dir ($dir1, $dir2) {
99 | printf "%s: %5.2f\n", $dir, $time{$dir};
100 | }
101 | }
102 | }
103 |
104 | request_result $dir1, $id;
105 | request_result $dir2, $id;
106 |
107 | my $a = fetch_result $dir1, $id;
108 | my $b = fetch_result $dir2, $id;
109 |
110 | my $header_printed = 0;
111 |
112 | for my $key (keys %{$a}) {
113 | my $aa = $a->{$key};
114 | my $bb = $b->{$key};
115 |
116 | if (!ref $aa or !ref $bb) {
117 | next;
118 | }
119 |
120 | if ($key eq 'ledger') {
121 | $aa = convert_ledger $aa;
122 | $bb = convert_ledger $bb;
123 | my $aj = join "\n", map { to_json($_) } @{$aa};
124 | my $bj = join "\n", map { to_json($_) } @{$bb};
125 | if ($aj ne $bj) {
126 | print "\nDiff in $id" if !$header_printed++;
127 | # print "Ledger diffs";
128 | print diff \$aj, \$bj;
129 | }
130 | } else {
131 | my $aj = to_json($aa, { pretty => 1, canonical => 1 });
132 | my $bj = to_json($bb, { pretty => 1, canonical => 1 });
133 | if ($aj ne $bj) {
134 | print "\nDiff in $id" if !$header_printed++;
135 | print diff \$aj, \$bj;
136 | }
137 | }
138 | }
139 | }
140 |
--------------------------------------------------------------------------------
/src/Server/Alias.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Alias;
4 |
5 | use Moose;
6 | use Server::Server;
7 | use Method::Signatures::Simple;
8 |
9 | extends 'Server::Server';
10 |
11 | use Net::SMTP;
12 |
13 | use DB::Connection;
14 | use DB::Secret;
15 | use DB::Validation;
16 | use Server::Session;
17 | use Util::CryptUtil;
18 | use Util::SiteConfig;
19 |
20 | has 'mode' => (is => 'ro', required => 1);
21 |
22 | method handle($q, $suffix) {
23 | $self->no_cache();
24 | my $dbh = get_db_connection;
25 | my $mode = $self->mode();
26 |
27 | if ($mode eq 'validate') {
28 | $self->validate_alias($q, $dbh, $suffix);
29 | } elsif ($mode eq 'request') {
30 | $self->request_alias($q, $dbh);
31 | } else {
32 | die "Unknown mode $mode";
33 | }
34 | }
35 |
36 | method request_alias($q, $dbh) {
37 | my @error = ();
38 |
39 | my $email = $q->param('email');
40 | my $username = username_from_session_token($dbh,
41 | $q->cookie('session-token') // '');
42 |
43 | if (!$username) {
44 | push @error, "not logged in";
45 | } else {
46 | verify_csrf_cookie_or_die $q, $self;
47 | }
48 |
49 | if (!@error) {
50 | my ($email_in_use) = $dbh->selectrow_array("select count(*) from email where lower(address) = lower(?)", {}, $email);
51 |
52 | if ($email_in_use) {
53 | push @error, "The email address is already registered";
54 | }
55 | }
56 |
57 | if (!@error) {
58 | my $data = {
59 | username => $username,
60 | email => $email,
61 | };
62 | my $token = insert_to_validate $dbh, $data;
63 |
64 | my $url = sprintf "https://$config{domain}/app/alias/validate/%s", $token;
65 |
66 | my $smtp = Net::SMTP->new('localhost', ( Debug => 0 ));
67 |
68 | $smtp->mail("www-data\@$config{email_domain}");
69 | if (!$smtp->to($email)) {
70 | push @error, "Invalid email address";
71 | } else {
72 | $smtp->data();
73 | $smtp->datasend("To: $email\n");
74 | $smtp->datasend("From: noreply+alias\@$config{email_domain}\n");
75 | $smtp->datasend("Subject: Email alias validation for Terra Mystica\n");
76 | $smtp->datasend("\n");
77 | $smtp->datasend("To validate this email as an alias, use the following link:\n");
78 | $smtp->datasend(" $url\n");
79 | $smtp->dataend();
80 | }
81 |
82 | $smtp->quit;
83 | }
84 |
85 | $self->output_json({ error => [@error] });
86 | }
87 |
88 | method validate_alias($q, $dbh, $suffix) {
89 | my $token = $suffix // $q->param('token');
90 |
91 | my ($secret, $iv) = get_secret;
92 | eval {
93 | my @data = ();
94 | my $payload = fetch_validate_payload $dbh, $token;
95 | @data = ($payload->{username}, $payload->{email});
96 |
97 | $self->add_alias($dbh, @data);
98 | $self->output_html("Email alias registered ");
99 | }; if ($@) {
100 | print STDERR "token: $token\n";
101 | print STDERR $@;
102 | $self->output_html("Validation failed ");
103 | }
104 | }
105 |
106 | method add_alias($dbh, $user, $email) {
107 | my ($already_done) = $dbh->selectrow_array("select count(*) from email where lower(address) = lower(?) and player = ?", {}, $email, $user);
108 |
109 | if (!$already_done) {
110 | $dbh->do('begin');
111 | $dbh->do('insert into email (address, player, validated, is_primary) values (lower(?), ?, ?, false)',
112 | {}, $email, $user, 1);
113 | $dbh->do('commit');
114 | }
115 |
116 | return $already_done;
117 | }
118 |
119 | 1;
120 |
--------------------------------------------------------------------------------
/stc/ratings.js:
--------------------------------------------------------------------------------
1 | var state = null;
2 | var id = document.location.pathname;
3 |
4 | function showRatings(kind, table, data) {
5 | var header = new Element("tr");
6 | if (kind == "player") {
7 | header.insert(new Element("td").updateText("Rank"));
8 | }
9 | header.insert(new Element("td").updateText("Rating"));
10 | header.insert(new Element("td").updateText("Name"));
11 | header.insert(new Element("td").updateText("Games Played"));
12 | if (kind == "player") {
13 | header.insert(new Element("td").updateText("Breakdown"));
14 | }
15 | table.insert(header);
16 |
17 | var rank = 1;
18 |
19 | $H(data).sortBy(function (a) { return -a.value.score } ).each(function(elem) {
20 | var value = elem.value;
21 | var row = new Element("tr");
22 | if (kind == "player") {
23 | if (rank == 1 || rank % 10 == 0) {
24 | row.insert(new Element("td").updateText(rank));
25 | } else {
26 | row.insert(new Element("td"));
27 | }
28 | rank++;
29 | }
30 | row.insert(new Element("td").updateText(Math.floor(value.score)));
31 | if (kind == "player") {
32 | row.insert(new Element("td").update(
33 | new Element("a", {"href":"/player/" + value.username}).
34 | updateText(value.username)));
35 | row.insert(new Element("td").updateText(value.games));
36 | var breakdown = new Element("table", {
37 | "class": "ranking-breakdown-table",
38 | });
39 | breakdown.insert(new Element("tr").insert(
40 | new Element("td").updateText("Faction")).insert(
41 | new Element("td").updateText("Delta")).insert(
42 | new Element("td").updateText("Plays")));
43 |
44 | $H(value.faction_breakdown).sortBy(function (elem) { return -elem.value.score }).each(function (elem) {
45 | var breakdown_row = new Element("tr");
46 | breakdown_row.insert(factionTableCell(elem.key));
47 | breakdown_row.insert(new Element("td").updateText(Math.round(elem.value.score)));
48 | breakdown_row.insert(new Element("td").updateText(Math.round(elem.value.count)));
49 | breakdown.insert(breakdown_row);
50 | });
51 | breakdown.hide();
52 | var cell = new Element("td");
53 | var show = new Element("a", { href: "javascript:" }).updateText("show");
54 | show.onclick = function() { show.hide(); breakdown.show(); };
55 | cell.insert(show);
56 | cell.insert(breakdown);
57 | row.insert(cell);
58 | } else {
59 | row.insert(factionTableCell(value.name));
60 | row.insert(new Element("td").updateText(value.games));
61 | }
62 | table.insert(row);
63 | });
64 | }
65 |
66 | function showLinks(id) {
67 | $(id + "-links").style.display = "block";
68 | $(id + "-show-link").style.display = "none";
69 | }
70 |
71 | function showFactionRatingsByMap(map) {
72 | showRatings("faction",
73 | $("faction-ratings-" + map),
74 | state["factions_by_map"][map]);
75 | }
76 |
77 | function loadRatings() {
78 | new Ajax.Request("/data/ratings.json", {
79 | method:"get",
80 | onSuccess: function(transport){
81 | state = transport.responseText.evalJSON();
82 | try {
83 | showRatings("player", $("player-ratings"), state["players"]);
84 | showFactionRatingsByMap("126fe960806d587c78546b30f1a90853b1ada468");
85 | showFactionRatingsByMap("95a66999127893f5925a5f591d54f8bcb9a670e6");
86 | showFactionRatingsByMap("be8f6ebf549404d015547152d5f2a1906ae8dd90");
87 | showFactionRatingsByMap("fdb13a13cd48b7a3c3525f27e4628ff6905aa5b1");
88 | $("timestamp").innerHTML = "Last updated: " + state.timestamp;
89 | } catch (e) {
90 | handleException(e);
91 | };
92 | }
93 | });
94 | }
95 |
--------------------------------------------------------------------------------
/src/Server/JoinGame.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 | no indirect;
3 |
4 | package Server::JoinGame;
5 |
6 | use Moose;
7 | use Server::Server;
8 | use Method::Signatures::Simple;
9 |
10 | extends 'Server::Server';
11 |
12 | use DB::Connection;
13 | use DB::Game;
14 | use DB::IndexGame;
15 | use DB::SaveGame;
16 | use DB::UserInfo;
17 | use Email::Notify;
18 | use Server::Session;
19 | use tracker;
20 |
21 | sub joingame {
22 | my ($dbh, $read_id, $username) = @_;
23 | begin_game_transaction $dbh, $read_id;
24 |
25 | my ($wanted_player_count, $current_count, $already_playing,
26 | $minimum_rating, $maximum_rating) =
27 | $dbh->selectrow_array("select wanted_player_count, (select count(*) from game_player where game=game.id), (select count(*) from game_player where game=game.id and player=?), game_options.minimum_rating, game_options.maximum_rating from game left join game_options on game.id=game_options.game where id=?",
28 | {},
29 | $username,
30 | $read_id);
31 |
32 | if (!defined $wanted_player_count) {
33 | die "Can't join a private game\n";
34 | }
35 | if ($already_playing) {
36 | die "You've already joined this game\n";
37 | }
38 | if ($wanted_player_count <= $current_count) {
39 | die "Game is already full\n";
40 | }
41 |
42 | {
43 | my $user_metadata = fetch_user_metadata $dbh, $username;
44 | my $user_rating = ($user_metadata->{rating} // 0);
45 | if ($user_rating < ($minimum_rating // 0)) {
46 | die "Your rating ($user_rating) is too low to join\n";
47 | }
48 | if ($user_rating > ($maximum_rating // 1e6)) {
49 | die "Your rating ($user_rating) is too high to join\n";
50 | }
51 | }
52 |
53 | {
54 | my ($games_waiting) = $dbh->selectrow_array("select count(*) from game_role join game on game.id=game_role.game where faction_player=? and action_required=true and not (game.finished or game.aborted)",
55 | {},
56 | $username);
57 | if ($games_waiting > 4) {
58 | die "It's your turn in a lot of games right now. Please make moves in those games before joining new ones.\n";
59 | }
60 | }
61 |
62 | $dbh->do("insert into game_player (game, player, sort_key, index) values (?, ?, ?, ?)",
63 | {},
64 | $read_id,
65 | $username,
66 | $current_count,
67 | $current_count);
68 | $dbh->do("update game set last_update = now() where id = ?",
69 | {},
70 | $read_id);
71 |
72 | if ($wanted_player_count == $current_count + 1) {
73 | my $write_id = $dbh->selectrow_array("select write_id from game where id=?",
74 | {},
75 | $read_id);
76 | my ($prefix_content, $orig_content) =
77 | get_game_content $dbh, $read_id, $write_id;
78 |
79 | my $res = evaluate_and_save $dbh, $read_id, $write_id, $prefix_content, $orig_content;
80 | notify_game_started $dbh, {
81 | name => $read_id,
82 | options => $res->{options},
83 | players => $res->{players},
84 | }
85 | }
86 |
87 | finish_game_transaction $dbh;
88 | }
89 |
90 | method handle($q) {
91 | my $dbh = get_db_connection;
92 |
93 | $self->no_cache();
94 | verify_csrf_cookie_or_die $q, $self;
95 |
96 | my $username = username_from_session_token($dbh,
97 | $q->cookie('session-token') // '');
98 | my $read_id = $q->param('game');
99 | my $res = {
100 | error => [],
101 | };
102 |
103 | if (!$username) {
104 | $res->error = [ "not logged in" ];
105 | } else {
106 | eval {
107 | joingame $dbh, $read_id, $username;
108 | }; if ($@) {
109 | $res->{error} = [ $@ ];
110 | print STDERR "Error in joingame: $@\n"
111 | }
112 | }
113 |
114 | $self->output_json($res);
115 | }
116 |
117 | 1;
118 |
119 |
--------------------------------------------------------------------------------
/src/Server/PasswordReset.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::PasswordReset;
4 |
5 | use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64);
6 | use Moose;
7 | use Method::Signatures::Simple;
8 | use Net::SMTP;
9 |
10 | use Bytes::Random::Secure qw(random_bytes);
11 | use DB::Connection;
12 | use DB::Secret;
13 | use DB::UserValidate;
14 | use DB::Validation;
15 | use Server::Session;
16 | use Server::Server;
17 | use Util::CryptUtil;
18 | use Util::PasswordQuality;
19 | use Util::SiteConfig;
20 |
21 | extends 'Server::Server';
22 |
23 | has 'mode' => (is => 'ro', required => 1);
24 |
25 | method handle($q, $suffix) {
26 | $self->no_cache();
27 | my $dbh = get_db_connection;
28 | my $mode = $self->mode();
29 |
30 | if ($mode eq 'validate') {
31 | $self->validate_reset($q, $dbh, $suffix);
32 | } elsif ($mode eq 'request') {
33 | $self->request_reset($q, $dbh);
34 | } else {
35 | die "Unknown mode $mode";
36 | }
37 | }
38 |
39 | method request_reset($q, $dbh) {
40 | my @error = ();
41 |
42 | my $email = $q->param('email');
43 | my $password = $q->param('password');
44 | my $password_again = $q->param('password_again');
45 | my $username;
46 |
47 | if (!@error) {
48 | if ($password ne $password_again) {
49 | push @error, "The two passwords you've entered are different. Please try again."
50 | }
51 | }
52 |
53 | if (!@error) {
54 | $username = $dbh->selectrow_array("select player from email where address = lower(?)", {}, $email);
55 |
56 | if (!$username) {
57 | push @error, "The email address is not registered";
58 | }
59 | }
60 |
61 | if (!@error) {
62 | my ($reason) = password_too_weak $username, $password;
63 | if ($reason) {
64 | push @error, "Bad password: $reason\n";
65 | }
66 | }
67 |
68 | if (!@error) {
69 | my $secret = get_secret $dbh;
70 |
71 | my $salt = en_base64 (join '', map { chr int rand 256} 1..16);
72 | my $hashed_password = bcrypt($password,
73 | '$2a$08$'.$salt);
74 | my $data = {
75 | username => $username,
76 | email => $email,
77 | hashed_password => $hashed_password
78 | };
79 | my $token = insert_to_validate $dbh, $data;
80 |
81 | my $url = sprintf "https://$config{domain}/app/reset/validate/%s", $token;
82 |
83 | my $smtp = Net::SMTP->new('localhost', ( Debug => 0 ));
84 |
85 | $smtp->mail("www-data\@$config{email_domain}");
86 | if (!$smtp->to($email)) {
87 | push @error, "Invalid email address";
88 | } else {
89 | $smtp->data();
90 | $smtp->datasend("To: $email\n");
91 | $smtp->datasend("From: noreply+registration\@$config{email_domain}\n");
92 | $smtp->datasend("Subject: Password reset for Terra Mystica\n");
93 | $smtp->datasend("\n");
94 | $smtp->datasend("Username: $username\n");
95 | $smtp->datasend("\n");
96 | $smtp->datasend("To reset your password, use the following link:\n");
97 | $smtp->datasend(" $url\n");
98 | $smtp->dataend();
99 | }
100 |
101 | $smtp->quit;
102 | }
103 |
104 | $self->output_json({ error => [@error] });
105 | }
106 |
107 | method validate_reset($q, $dbh, $suffix) {
108 | my $token = $suffix // $q->param('token');
109 |
110 | eval {
111 | my @data = ();
112 | my $payload = fetch_validate_payload $dbh, $token;
113 | @data = ($payload->{username}, $payload->{email},
114 | $payload->{hashed_password});
115 |
116 | $self->reset_password($dbh, @data);
117 | $self->output_html("The password has been reset ");
118 | }; if ($@) {
119 | print STDERR "token: $token\n";
120 | print STDERR $@;
121 | $self->output_html("Validation failed ");
122 | }
123 | }
124 |
125 | method reset_password($dbh, $user, $email, $hashed_password) {
126 | $dbh->do('begin');
127 |
128 | $dbh->do('update player set password=? where username=?',
129 | {},
130 | $hashed_password,
131 | $user);
132 |
133 | $dbh->do('commit');
134 | }
135 |
136 | 1;
137 |
--------------------------------------------------------------------------------
/stc/index.js:
--------------------------------------------------------------------------------
1 | var state = null;
2 | var id = document.location.pathname;
3 |
4 | function listGames(games, div, mode, status) {
5 | var action_required_count = 0;
6 | var fields = $H({
7 | "id": "Game",
8 | "link": "Faction",
9 | "time_since_update": "Last move",
10 | "round": "Round",
11 | "waiting_for": "Waiting for",
12 | "status_msg": "Status",
13 | "vp": "VP"
14 | });
15 | if (isMobile.any()) {
16 | fields = $H({
17 | "id": "Game",
18 | "link": "Faction",
19 | "status_msg": "Status",
20 | });
21 | }
22 |
23 | var thead = new Element("thead");
24 | var tbody = new Element("tbody");
25 | fields.each(function (field) {
26 | thead.insert(new Element("td").update(field.value));
27 | });
28 | games.each(function(elem) {
29 | elem.status = "";
30 | elem.status_msg = "";
31 | if (elem.dropped) {
32 | elem.status = "game-status-dropped";
33 | elem.status_msg = "dropped out";
34 | } else if (elem.action_required && !elem.aborted) {
35 | elem.status = "game-status-action-required";
36 | if (mode == "user") {
37 | elem.status_msg = "your turn";
38 | } else {
39 | elem.status_msg = "player's turn";
40 | }
41 |
42 | action_required_count++;
43 |
44 | if (elem.deadline_hours) {
45 | var deadline_seconds = elem.deadline_hours * 3600;
46 | if (elem.seconds_since_update >= deadline_seconds * 0.75) {
47 | var dropping_in_seconds = deadline_seconds - elem.seconds_since_update
48 | var dropping_in = seconds_to_pretty_time(dropping_in_seconds);
49 |
50 | if (dropping_in_seconds <= 0) {
51 | elem.status_msg += ", drop imminent ";
52 | } else {
53 | elem.status_msg += ", dropping in " + dropping_in;
54 | }
55 | elem.status = 'game-status-dropping-soon';
56 | }
57 | }
58 | } else if (elem.unread_chat_messages > 0) {
59 | elem.status = "game-status-action-unread-chat";
60 | elem.status_msg = "new chat";
61 | action_required_count++;
62 | }
63 |
64 | if (elem.seconds_since_update) {
65 | elem.time_since_update = seconds_to_pretty_time(elem.seconds_since_update) + " ago";
66 | }
67 | if (elem.vp) { elem.vp += " vp"; }
68 | if (elem.rank) { elem.vp += " (" + elem.rank + ")"; }
69 |
70 | if (elem.aborted) {
71 | elem.vp = "";
72 | elem.status_msg = "aborted";
73 | } else if (elem.finished) {
74 | elem.status_msg = "finished";
75 | }
76 | elem.link = new Element("a", {"href": elem.link, "class": "passthrough-color"}).update(elem.role);
77 |
78 | var row = new Element("tr", {"class": elem.status});
79 | fields.each(function(field) {
80 | var td;
81 | if (field.key == "link") {
82 | td = factionTableCell(elem.role);
83 | td.innerHTML = "";
84 | td.insert(elem.link);
85 | } else {
86 | td = new Element("td").update(elem[field.key])
87 | }
88 | row.insert(td);
89 | });
90 |
91 | $(tbody).insert(row);
92 | });
93 | if (mode == "user") {
94 | var link = new Element('a', {"href": "#", "accesskey": "n"}).update("Refresh");
95 | link.onclick = function() { fetchGames(div, mode, status, nextGame); }
96 | var td = new Element('td').insert(link);
97 | var tr = new Element('tr').insert(new Element("td")).insert(td);
98 | $(tbody).insert(tr);
99 |
100 | if (status == "running") {
101 | moveRequired = (action_required_count > 0);
102 | setTitle();
103 | }
104 | }
105 |
106 | $(div).update("");
107 | $(div).insert(thead);
108 | $(div).insert(tbody);
109 | }
110 |
111 | function nextGame(games, div, mode, status) {
112 | games.each(function(elem) {
113 | if (elem.action_required) { document.location = elem.link; }
114 | });
115 | listGames(games, div, mode, status);
116 | }
117 |
118 |
--------------------------------------------------------------------------------
/src/DB/UserInfo.pm:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -w
2 |
3 | package DB::UserInfo;
4 | use Exporter::Easy (
5 | EXPORT => [qw(fetch_user_metadata fetch_user_stats fetch_user_opponents)]
6 | );
7 |
8 | use strict;
9 |
10 | sub fetch_user_metadata {
11 | my ($dbh, $username) = @_;
12 |
13 | my ($metadata) =
14 | $dbh->selectall_arrayref("select username, displayname, rating from player left join player_ratings on player.username=player_ratings.player where username=?",
15 | { Slice => {} },
16 | $username);
17 |
18 | my ($games) =
19 | $dbh->selectall_arrayref("select game.id, game_role.dropped, game.finished, game.aborted from game_role left join game on game.id=game_role.game where game_role.faction_player=?",
20 | { Slice => {} },
21 | $username);
22 |
23 | $metadata = $metadata->[0];
24 |
25 | $metadata->{tournament} = 0;
26 | my %handled = ();
27 | for my $game (@{$games}) {
28 | next if $handled{$game->{id}}++;
29 |
30 | if ($game->{id} =~ /4pLeague_/) {
31 | $metadata->{tournament} = 1;
32 | }
33 |
34 | if ($game->{dropped}) {
35 | $metadata->{dropped}++;
36 | } elsif ($game->{aborted}) {
37 | $metadata->{aborted}++;
38 | } elsif ($game->{finished}) {
39 | $metadata->{finished}++;
40 | } else {
41 | $metadata->{running}++;
42 | }
43 | $metadata->{total_games}++;
44 | }
45 |
46 | $metadata;
47 | }
48 |
49 | sub fetch_user_stats {
50 | my ($dbh, $username) = @_;
51 | my $rows;
52 |
53 | if ($username eq 'top50') {
54 | $rows = $dbh->selectall_arrayref("select faction_full as faction, max(vp) as max_vp, sum(vp)/count(*) as mean_vp, count(*), count(case when rank = 1 then true end)*100/count(*) as win_percentage, array_agg(rank) as ranks from game_role where faction_player in (select player from player_ratings order by rating desc limit 50) and game in (select id from game where finished and not aborted and not exclude_from_stats) group by faction_full order by win_percentage desc",
55 | { Slice => {} });
56 | } else {
57 | $rows = $dbh->selectall_arrayref("select faction_full as faction, max(vp) as max_vp, sum(vp)/count(*) as mean_vp, count(*), count(case when rank = 1 then true end) as wins, count(case when rank = 1 then true end)*100/count(*) as win_percentage, array_agg(rank) as ranks from game_role where faction_player=? and game in (select id from game where finished and not aborted and not exclude_from_stats) group by faction_full order by win_percentage desc",
58 | { Slice => {} },
59 | $username);
60 | }
61 |
62 | $rows;
63 | }
64 |
65 | sub fetch_user_opponents {
66 | my ($dbh, $username) = @_;
67 |
68 | my %res = ();
69 |
70 | my ($games) =
71 | $dbh->selectall_arrayref("select game, array_agg(faction_player) as players, array_agg(rank) as ranks from game_role where game in (select game from game_role where faction_player=? and game in (select id from game where finished and not aborted)) group by game",
72 | { Slice => {} },
73 | $username);
74 |
75 | for my $game (@{$games}) {
76 | my %ranks = ();
77 |
78 | while (@{$game->{ranks}}) {
79 | my $player = pop @{$game->{players}};
80 | my $rank = pop @{$game->{ranks}};
81 |
82 | next if !defined $player;
83 |
84 | $ranks{$player} = $rank;
85 | }
86 | for my $opponent (keys %ranks) {
87 | next if $opponent eq $username;
88 |
89 | $res{$opponent}{username} = $opponent;
90 | $res{$opponent}{count}++;
91 | if ($ranks{$username} > $ranks{$opponent}) {
92 | $res{$opponent}{opponent_better}++;
93 | } elsif ($ranks{$username} < $ranks{$opponent}) {
94 | $res{$opponent}{player_better}++;
95 | } else {
96 | $res{$opponent}{draw}++;
97 | }
98 | }
99 | }
100 |
101 | my @res = sort { $b->{count} <=> $a->{count} } values %res;
102 |
103 | [ @res ];
104 | }
105 |
106 | 1;
107 |
--------------------------------------------------------------------------------
/src/Server/Chat.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Chat;
4 |
5 | use Moose;
6 | use Server::Server;
7 |
8 | extends 'Server::Server';
9 |
10 | use Crypt::CBC;
11 | use DB::Chat;
12 | use DB::Connection;
13 | use DB::Secret;
14 | use Email::Notify;
15 | use Server::Security;
16 | use Server::Session;
17 | use Util::SiteConfig;
18 |
19 | sub verify_key {
20 | my ($dbh, $id, $faction_key, $faction_name) = @_;
21 | my ($secret, $iv) = get_secret $dbh;
22 |
23 | my $cipher = Crypt::CBC->new(-key => $secret,
24 | -blocksize => 8,
25 | -iv => $iv,
26 | -add_header => 0,
27 | -cipher => 'Blowfish');
28 | my $data = $cipher->decrypt(pack "h*", $faction_key);
29 | my $game_secret = unpack("h*", $data ^ $faction_name);
30 |
31 | my $write_id = "${id}_$game_secret";
32 | my $valid = $dbh->selectrow_array("select count(*) from game where write_id=?", {}, $write_id);
33 |
34 | die "Invalid faction key\n" if !$valid;
35 | };
36 |
37 | sub handle {
38 | my ($self, $q) = @_;
39 | $self->no_cache();
40 |
41 | my $dbh = get_db_connection;
42 |
43 | my $id = $q->param('game');
44 | $id =~ s{.*/}{};
45 | $id =~ s{[^A-Za-z0-9_]}{}g;
46 |
47 | my $faction_name = $q->param('faction');
48 | my $faction_key = $q->param('faction-key');
49 | my $add_message = $q->param('add-message');
50 | my $turn = $q->param('turn');
51 | my $username = username_from_session_token($dbh,
52 | $q->cookie('session-token') // '');
53 |
54 | my %res = ( error => [] );
55 | my $prevalidated = 0;
56 |
57 | if ($faction_name eq '' and $username eq $config{site_admin_username}) {
58 | $faction_name = 'site-admin';
59 | $prevalidated = 1;
60 | }
61 |
62 | eval {
63 | if (!$prevalidated) {
64 | if ($faction_key eq '') {
65 | get_write_id_for_user $dbh, $username, $id, $faction_name;
66 | } else {
67 | verify_key $dbh, $id, $faction_key, $faction_name;
68 | }
69 | }
70 | if (defined $add_message && $add_message =~ /\S/) {
71 | $dbh->do('begin');
72 | insert_chat_message($dbh, $id, $faction_name, $add_message, $turn);
73 | $dbh->do('commit');
74 |
75 | my $factions = $dbh->selectall_arrayref(
76 | "select game_role.faction as name, email.address as email, player.displayname from game_role left join email on email.player = game_role.faction_player left join player on player.username = game_role.faction_player where game = ? and email.is_primary",
77 | { Slice => {} },
78 | $id);
79 |
80 | my $game_options = $dbh->selectrow_array(
81 | "select game_options from game where id=?", {}, $id);
82 | for my $option (@{$game_options}) {
83 | if ($option eq 'email-notify') {
84 | notify_new_chat $dbh, {
85 | name => $id,
86 | factions => { map { ($_->{name}, $_) } @{$factions} }
87 | }, $faction_name, $add_message;
88 | }
89 | }
90 | }
91 |
92 | my $rows = $dbh->selectall_arrayref(
93 | "select faction, message, extract(epoch from now() - posted_at) as message_age, posted_on_turn from chat_message where game = ? order by posted_at asc",
94 | { Slice => {} },
95 | $id);
96 |
97 | if ($username) {
98 | $dbh->do("begin");
99 | my $count =
100 | $dbh->do("update chat_read set last_read = now() where game=? and player=?",
101 | {},
102 | $id,
103 | $username);
104 | if ($count == 0) {
105 | $dbh->do("insert into chat_read (last_read, game, player) values (now(), ?, ?)",
106 | {},
107 | $id,
108 | $username);
109 | }
110 | $dbh->do("commit");
111 | }
112 |
113 | $res{messages} = $rows;
114 | }; if ($@) {
115 | $res{error} = ["$@"];
116 | }
117 |
118 | $self->output_json(\%res);
119 | }
120 |
--------------------------------------------------------------------------------
/src/drop-idle-players.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -w
2 |
3 | use strict;
4 | no indirect;
5 |
6 | use File::Basename;
7 | use JSON;
8 |
9 | BEGIN { push @INC, dirname $0 }
10 |
11 | use DB::Connection;
12 | use DB::Game;
13 | use DB::SaveGame;
14 | use Email::Notify;
15 | use JSON;
16 | use tracker;
17 |
18 | my $dbh = get_db_connection;
19 |
20 | my $id_pattern = '%';
21 |
22 | # Old-style games with static move deadline
23 | my $idle_players = $dbh->selectall_arrayref("select game, array_agg(faction) as factions from game_role where game in (select id from game left join game_options on game_options.game=game.id where not finished and not aborted and game_options.chess_clock_hours_initial is null and last_update < now() - coalesce(game_options.deadline_hours, 24*7) * interval '1 hour') and (action_required or leech_required) and game like ? group by game",
24 | { Slice => {} },
25 | $id_pattern);
26 |
27 | # New-style games with chess clock
28 | for my $x (qw(8 12 24)) {
29 | my $players = $dbh->selectall_arrayref("select game.id as game, array_agg(game_role.faction) as factions from game_role left join game on game.id=game_role.game left join game_active_time on game_active_time.game=game.id left join game_options on game.id=game_options.game and game_active_time.player=game_role.faction_player where not game.finished and not game_role.dropped and game.current_chess_clock_hours is not null and (game_active_time.active_seconds_${x}h >= game.current_chess_clock_hours * 3600) and game_options.chess_clock_grace_period=? and game.id like ? group by game.id",
30 | { Slice => {} },
31 | $x,
32 | $id_pattern);
33 | push @{$idle_players}, @{$players};
34 | }
35 |
36 | sub drop_factions_from_game {
37 | my ($read_id, $factions) = @_;
38 | my @factions = @{$factions};
39 |
40 | if (-t STDOUT) {
41 | print "Dropping @factions from $read_id\n";
42 | }
43 |
44 | my ($write_id) = $dbh->selectrow_array("select write_id from game where id=?",
45 | {},
46 | $read_id);
47 |
48 | begin_game_transaction $dbh, $read_id;
49 |
50 | my $players = get_game_players($dbh, $read_id);
51 | my $metadata = get_game_metadata($dbh, $read_id);
52 |
53 | my ($prefix_content, $new_content) = get_game_content $dbh, $read_id, $write_id;
54 | my $append = '';
55 | for my $faction (@factions) {
56 | $append .= "\ndrop-faction $faction"
57 | }
58 | $new_content .= $append;
59 |
60 | my $res = terra_mystica::evaluate_game {
61 | rows => [ split /\n/, "$prefix_content\n$new_content" ],
62 | faction_info => get_game_factions($dbh, $read_id),
63 | players => $players,
64 | metadata => $metadata,
65 | delete_email => 0
66 | };
67 |
68 | if (@{$res->{error}}) {
69 | die join "\n", @{$res->{error}};
70 | }
71 |
72 | save $dbh, $write_id, $new_content, $res;
73 |
74 | finish_game_transaction $dbh;
75 |
76 | if ($res->{options}{'email-notify'}) {
77 | my $factions = $dbh->selectall_arrayref(
78 | "select game_role.faction as name, email.address as email, player.displayname from game_role left join email on email.player = game_role.faction_player left join player on player.username = game_role.faction_player where game = ? and email.is_primary",
79 | { Slice => {} },
80 | $read_id);
81 | for my $faction (@{$factions}) {
82 | my $eval_faction = $res->{factions}{$faction->{name}};
83 | if ($eval_faction) {
84 | $faction->{recent_moves} = $eval_faction->{recent_moves};
85 | $faction->{VP} = $eval_faction->{VP};
86 | }
87 | }
88 | my $game = {
89 | name => $read_id,
90 | factions => { map { ($_->{name}, $_) } @{$factions} },
91 | finished => $res->{finished},
92 | options => $res->{options},
93 | action_required => $res->{action_required},
94 | };
95 | notify_after_move $dbh, $write_id, $game, $factions[0], $append;
96 | }
97 | };
98 |
99 | for (@{$idle_players}) {
100 | eval {
101 | drop_factions_from_game $_->{game}, $_->{factions};
102 | }; if ($@) {
103 | print "Error in game $_->{game}: $@"
104 | }
105 | }
106 |
107 |
--------------------------------------------------------------------------------
/src/income.pm:
--------------------------------------------------------------------------------
1 | package terra_mystica;
2 |
3 | use strict;
4 |
5 | use Game::Constants;
6 |
7 | use resources;
8 | use scoring;
9 |
10 | use vars qw(%game);
11 |
12 | sub faction_income {
13 | my $faction = shift;
14 |
15 | my %total_income = map { $_, 0 } qw(C W P PW);
16 |
17 | my %total_building_income = %total_income;
18 | my %total_favor_income = %total_income;
19 | my %total_bonus_income = %total_income;
20 | my %total_scoring_income = %total_income;
21 |
22 | return if $faction->{dummy};
23 |
24 | my %buildings = %{$faction->{buildings}};
25 |
26 | for my $building (values %buildings) {
27 | if (exists $building->{income}) {
28 | my %building_income = %{$building->{income}};
29 | for my $type (keys %building_income) {
30 | my $delta = $building_income{$type}[$building->{level}];
31 | if ($delta) {
32 | $total_building_income{$type} += $delta;
33 | }
34 | }
35 | }
36 | }
37 |
38 | for my $tile (keys %{$faction}) {
39 | if (!$faction->{$tile}) {
40 | next;
41 | }
42 |
43 | if ($tile =~ /^(BON|FAV)/) {
44 | my $tile_income = $tiles{$tile}{income};
45 | for my $type (keys %{$tile_income}) {
46 | if ($tile =~ /^BON/ and $faction->{passed}) {
47 | $total_bonus_income{$type} += $tile_income->{$type};
48 | } elsif ($tile =~ /^FAV/) {
49 | $total_favor_income{$type} += $tile_income->{$type};
50 | }
51 | }
52 | }
53 | }
54 |
55 | my $scoring = current_score_tile;
56 | if ($scoring and $game{round} != 6) {
57 | my %scoring_income = %{$scoring->{income}};
58 |
59 | my $mul = int($faction->{$scoring->{cult}} / $scoring->{req});
60 | for my $type (keys %scoring_income) {
61 | $total_scoring_income{$type} += $scoring_income{$type} * $mul;
62 | }
63 | }
64 |
65 | # XXX: Nasty. Mutate the faction every time this function gets called,
66 | # rather than return the breakdown.
67 | $faction->{income_breakdown} = {};
68 |
69 | $faction->{income_breakdown}{bonus} = \%total_bonus_income;
70 | $faction->{income_breakdown}{scoring} = \%total_scoring_income;
71 | $faction->{income_breakdown}{favors} = \%total_favor_income;
72 | $faction->{income_breakdown}{buildings} = \%total_building_income;
73 |
74 | for my $subincome (values %{$faction->{income_breakdown}}) {
75 | my $total = 0;
76 | for my $type (keys %{$subincome}) {
77 | $total_income{$type} += $subincome->{$type};
78 | if (grep { $type eq $_} qw(C W P PW)) {
79 | $total += $subincome->{$type};
80 | }
81 | }
82 | if (!$total) {
83 | $subincome = undef;
84 | }
85 | }
86 |
87 | return {
88 | total => \%total_income,
89 | ordered => [ \%total_scoring_income,
90 | \%total_bonus_income,
91 | \%total_building_income,
92 | \%total_favor_income ]
93 | };
94 | }
95 |
96 | sub take_income_for_faction {
97 | my ($faction, $type) = @_;
98 | $type //= 15;
99 | die "Taking income twice for $faction->{name}\n" if
100 | $faction->{income_taken} & $type;
101 |
102 | if (!$game{planning}) {
103 | for my $f ($game{acting}->factions_in_turn_order()) {
104 | die "Can't take income for $faction->{name} ($f->{name} still active)\n" if
105 | !($f->{passed} or $f->{dropped} or $f->{dummy});
106 | }
107 | }
108 |
109 | if ($game{round} == 0) {
110 | $faction->{passed} = 1;
111 | }
112 |
113 | my $income = faction_income $faction;
114 | my $mask = 1;
115 | for my $subincome (@{$income->{ordered}}) {
116 | if ($type & $mask) {
117 | gain $faction, $subincome;
118 | }
119 | $mask <<= 1;
120 | }
121 |
122 | $faction->{income_taken} |= $type;
123 |
124 | if ($faction->{SPADE}) {
125 | $game{acting}->require_action($faction,
126 | { type => 'transform',
127 | amount => $faction->{SPADE} });
128 | }
129 |
130 | if ($faction->{CULT}) {
131 | $game{acting}->require_action($faction,
132 | { type => 'cult',
133 | amount => $faction->{CULT} });
134 | }
135 | }
136 |
137 | 1;
138 |
--------------------------------------------------------------------------------
/stc/player.js:
--------------------------------------------------------------------------------
1 | function fetchStats(table, type, callback, user) {
2 | var target = "/app/user/" + type + "/" + user;
3 |
4 | var form_params = {
5 | "cache-token": new Date() - Math.random(),
6 | "csrf-token": getCSRFToken(),
7 | };
8 |
9 | new Ajax.Request(target, {
10 | method: "post",
11 | parameters: form_params,
12 | onSuccess: function(transport) {
13 | var response = transport.responseText.evalJSON();
14 | if (response.error.length) {
15 | $("error").innerHTML = response.error.join("Account already exists ");
122 | } else {
123 | $self->output_html( "Account created ");
124 | }
125 | }; if ($@) {
126 | print STDERR "token: $token\n";
127 | print STDERR $@;
128 | $self->output_html( "Validation failed ");
129 | }
130 | }
131 |
132 | method register($dbh, $user, $email, $hashed_password) {
133 | my ($already_done) = $dbh->selectrow_array("select count(*) from email where lower(address) = lower(?) and player = ?", {}, $email, $user);
134 |
135 | if (!$already_done) {
136 | $dbh->do('begin');
137 | $dbh->do('insert into player (username, displayname, password) values (?, ?, ?)', {},
138 | $user, $user, $hashed_password);
139 | $dbh->do('insert into email (address, player, validated, is_primary) values (lower(?), ?, ?, true)',
140 | {}, $email, $user, 1);
141 | $dbh->do('commit');
142 | }
143 |
144 | return $already_done;
145 | }
146 |
147 | 1;
148 |
--------------------------------------------------------------------------------
/src/DB/AddGames.pm:
--------------------------------------------------------------------------------
1 | #!perl
2 |
3 | package DB::AddGames;
4 |
5 | use Exporter::Easy (
6 | EXPORT => [qw(validate make_games)]
7 | );
8 |
9 | use strict;
10 | no indirect;
11 |
12 | use DBI;
13 | use JSON;
14 |
15 | use DB::Connection;
16 | use DB::Game;
17 | use DB::SaveGame;
18 | use DB::UserValidate;
19 | use Email::Notify;
20 |
21 | sub validate {
22 | my ($dbh, $desc) = @_;
23 | my $games = $desc->{games};
24 | my $options = $desc->{options};
25 |
26 | my %order = ();
27 | my %count = ();
28 |
29 | for my $game_desc (@{$games}) {
30 | my $id = $game_desc->{name};
31 | my @players = @{$game_desc->{players}};
32 | for (my $i = 0; $i < @players; ++$i) {
33 | my $player = $players[$i];
34 | if ($order{$player}{$i}) {
35 | die "$player on position $i in multiple games ($order{$player}{$i}, $id)\n"
36 | }
37 | $order{$player}{$i} = $id;
38 | $count{$player}++;
39 | die "Someone trying to add a test account\n" if $player eq 'test' or $player eq 'test2' or $player eq 'TestCapital';
40 | }
41 | }
42 |
43 | for my $player (keys %count) {
44 | if ($count{$player} != $desc->{'games-per-player'}) {
45 | die "$player playing in $count{$player} matches (wanted $desc->{'games-per-player'})\n"
46 | }
47 | check_username_is_registered $dbh, $player;
48 | }
49 |
50 | my $chess_clock_settings = scalar grep { defined $_ } map { $desc->{$_} } qw(chess-clock-hours-initial chess-clock-hours-per-round chess-clock-grace-period);
51 | if (($chess_clock_settings != 0 and $chess_clock_settings != 3) or
52 | ($chess_clock_settings == 0 and !defined $desc->{'deadline-hours'}) or
53 | ($chess_clock_settings == 3 and defined $desc->{'deadline-hours'})) {
54 | die "Inconsistent chess clock / deadline settings\n";
55 | }
56 |
57 | check_username_is_registered $dbh, $desc->{admin};
58 |
59 | my %valid_options = map { ($_, 1) } qw(
60 | errata-cultist-power
61 | mini-expansion-1
62 | shipping-bonus
63 | temple-scoring-tile
64 | email-notify
65 | maintain-player-order
66 | strict-leech
67 | strict-chaosmagician-sh
68 | strict-darkling-sh
69 | variable-turn-order);
70 | for my $opt (@{$options}) {
71 | if (!$valid_options{$opt}) {
72 | die "Unknown option $opt\n";
73 | }
74 | }
75 | }
76 |
77 | sub make_games {
78 | my ($dbh, $desc) = @_;
79 | my $games = $desc->{games};
80 | my $options = $desc->{options};
81 | my $player_count = undef;
82 | my $admin = $desc->{admin};
83 |
84 | my @to_create = ();
85 |
86 | for my $game_desc (@{$games}) {
87 | my $id = $game_desc->{name};
88 | if (game_exists $dbh, $id) {
89 | print "Game $id already exists, skipping\n";
90 | } else {
91 | push @to_create, $game_desc;
92 | }
93 | }
94 |
95 | my $map_variant = undef;
96 |
97 | for my $game_desc (@to_create) {
98 | $dbh->do("begin");
99 | my $id = $game_desc->{name};
100 | my @players = map {
101 | my $player = $_;
102 | my ($username, $email) =
103 | check_username_is_registered $dbh, $player;
104 | { email => $email, username => $username }
105 | } @{$game_desc->{players}};
106 |
107 | print "Creating $id with @{$game_desc->{players}}\n";
108 |
109 | create_game($dbh,
110 | $id,
111 | $admin,
112 | [ @players ],
113 | $player_count,
114 | $map_variant,
115 | @{$options});
116 |
117 |
118 |
119 | $dbh->do("update game set description=?, current_chess_clock_hours=? where id=?",
120 | {},
121 | $game_desc->{'description'},
122 | $desc->{'chess-clock-hours-initial'},
123 | $id);
124 |
125 | $dbh->do("insert into game_options (game, description, minimum_rating, maximum_rating, deadline_hours, chess_clock_hours_initial, chess_clock_hours_per_round, chess_clock_grace_period) values (?, ?, ?, ?, ?, ?, ?, ?)",
126 | {},
127 | $id,
128 | $game_desc->{'description'},
129 | $desc->{'minimum-rating'},
130 | $desc->{'maximum-rating'},
131 | $desc->{'deadline-hours'},
132 | $desc->{'chess-clock-hours-initial'},
133 | $desc->{'chess-clock-hours-per-round'},
134 | $desc->{'chess-clock-grace-period'});
135 |
136 | notify_game_started $dbh, {
137 | name => $id,
138 | options => { map { ($_ => 1) } @{$options} },
139 | players => [ values %{get_game_factions($dbh, $id)} ],
140 | };
141 |
142 | $dbh->do("commit");
143 |
144 | sleep 1;
145 | }
146 | }
147 |
148 | 1;
149 |
--------------------------------------------------------------------------------
/src/Server/Map.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 |
3 | package Server::Map;
4 |
5 | use Digest::SHA qw(sha1_hex);
6 | use Moose;
7 | use Method::Signatures::Simple;
8 |
9 | extends 'Server::Server';
10 |
11 | use Analyze::EloVpPredictor;
12 | use DB::Connection qw(get_db_connection);
13 | use DB::Game;
14 | use Game::Constants;
15 | use map;
16 | use Server::Security;
17 | use Server::Session;
18 | use tracker;
19 | use Util::SiteConfig;
20 |
21 | has 'mode' => (is => 'ro', required => 1);
22 |
23 | method handle($q, $id) {
24 | $self->no_cache();
25 |
26 | my $dbh = get_db_connection;
27 |
28 | my $base_map = $q->param('base_map');
29 |
30 | my $res = {
31 | error => [],
32 | bridges => [],
33 | };
34 |
35 | if ($self->mode() eq 'view') {
36 | view($dbh, $id, $res, $q->param('map-only') // 1);
37 | } else {
38 | my $username = username_from_session_token(
39 | $dbh,
40 | $q->cookie('session-token') // '');
41 |
42 | if (!defined $username) {
43 | $self->output_json({
44 | error => [ "Not logged in\n" ]
45 | });
46 | return;
47 | }
48 |
49 | if ($self->mode() eq 'preview') {
50 | preview($dbh, $q->param('map-data'), $res);
51 | } elsif ($self->mode() eq 'save') {
52 | save($dbh, $q->param('map-data'), $res, $username);
53 | }
54 | }
55 |
56 | $self->output_json($res);
57 | };
58 |
59 | func convert_to_lodev($base_map) {
60 | $base_map =~ s/\s+/ /g;
61 | $base_map =~ s/\s*E\s*/;\n/g;
62 | $base_map =~ s/black/K/g;
63 | $base_map =~ s/blue/B/g;
64 | $base_map =~ s/brown/U/g;
65 | $base_map =~ s/green/G/g;
66 | $base_map =~ s/gray/S/g;
67 | $base_map =~ s/red/R/g;
68 | $base_map =~ s/yellow/Y/g;
69 | $base_map =~ s/x/I/g;
70 | $base_map =~ s/ /,/g;
71 | $base_map;
72 | }
73 |
74 | func convert_from_lodev($base_map) {
75 | if ($base_map =~ /^N/) {
76 | $base_map = ";$base_map";
77 | }
78 | $base_map =~ s/N,?//g;
79 |
80 | $base_map =~ s/K/black/g;
81 | $base_map =~ s/B/blue/g;
82 | $base_map =~ s/U/brown/g;
83 | $base_map =~ s/G/green/g;
84 | $base_map =~ s/S/gray/g;
85 | $base_map =~ s/R/red/g;
86 | $base_map =~ s/Y/yellow/g;
87 | $base_map =~ s/I/x/g;
88 | $base_map =~ s/;\s*/ E /g;
89 | $base_map =~ s/^ +//g;
90 | $base_map =~ s/ +$//g;
91 | $base_map =~ s/,/ /g;
92 | $base_map =~ s/ +/ /g;
93 | $base_map;
94 | }
95 |
96 | func preview($dbh, $mapdata, $res) {
97 | my $map_str = convert_from_lodev($mapdata);
98 | my $base_map = [ split /\s+/, $map_str ];
99 | my $map = terra_mystica::setup_map $base_map;
100 |
101 | my $id = sha1_hex $map_str;
102 |
103 | $res->{'map'} = $map;
104 | $res->{'mapdata'} = $mapdata;
105 | $res->{'mapid'} = $id;
106 | $res->{'saved'} = map_exists($dbh, $id);
107 | }
108 |
109 | func map_exists($dbh, $id) {
110 | my ($count) = $dbh->selectrow_array("select count(*) from map_variant where id=?",
111 | {},
112 | $id);
113 | $count ? 1 : 0;
114 | }
115 |
116 | func save($dbh, $mapdata, $res, $username) {
117 | if ($username ne $config{site_admin_username} and $username ne 'nan') {
118 | die "Sorry, creating new maps isn't allowed\n"
119 | }
120 |
121 | my $map_str = convert_from_lodev($mapdata);
122 | my $id = sha1_hex $map_str;
123 |
124 | if (!map_exists($dbh, $id)) {
125 | $dbh->do("insert into map_variant (id, terrain) values (?, ?)",
126 | {},
127 | $id, $map_str);
128 | }
129 |
130 | $res->{'mapid'} = sha1_hex $map_str;
131 | }
132 |
133 | func view($dbh, $id, $res, $map_only) {
134 | my ($map_str, $vp_variant) = $dbh->selectrow_array("select terrain, vp_variant from map_variant where id=?", {}, $id);
135 | my $base_map = [ split /\s+/, $map_str ];
136 | my $map = terra_mystica::setup_map $base_map;
137 |
138 | $res->{'map'} = $map;
139 | $res->{'mapdata'} = convert_to_lodev($map_str);
140 | $res->{'mapid'} = $id;
141 |
142 | if ($id ne '224736500d20520f195970eb0fd4c41df040c08c' and
143 | $id ne '54919e13090127079e7cc3540ad0065311f2ecd7' and
144 | $id ne '2afadc63f4d81e850b7c16fb21a1dcd29658c392') {
145 | $map_only = 1;
146 | }
147 |
148 | if (!$map_only) {
149 | my $game_ids = $dbh->selectall_arrayref("select id, round, finished, array (select faction || ' ' || vp from game_role where game=game.id order by vp desc) as factions from game where base_map=? and player_count > 2 and not aborted order by finished, round, id",
150 | { Slice => {} },
151 | $id);
152 |
153 | $res->{'games'} = $game_ids;
154 |
155 | $res->{'vpstats'} = faction_vp_error_by_map $dbh, $id;
156 | }
157 |
158 | if ($vp_variant) {
159 | $res->{vp_setup} = $Game::Constants::vp_setups{$vp_variant};
160 | }
161 | }
162 |
163 | 1;
164 |
--------------------------------------------------------------------------------