#!/usr/bin/perl

# Display all players rated or interested in a game.
# Bruno Wolff III
# Last revised July 12, 2014

# While areaid and gameid can't currently contain any uri specials, I want
# assume they can here, so I if tweak the database schema, things don't
# break here. The problem characters that might eventually be allowed
# are '#', '/' and '?'. Also note that '/'s don't really work at all
# since the server has a special check for / (encoded as %2F) in a component.

# Use unbuffered output as there are some long delays while doing queries
#use CGI::Carp qw(carpout);
#open (TLOG, ">>/var/log/trace.log") or die("Bad log: $!\n");
#carpout(TLOG);
#carp("Hello log");

#foreach my $key (sort(keys(%ENV))) {
#    carp("$key = $ENV{$key}<br>\n");
#}


use utf8;
no utf8;
use warnings;
binmode STDOUT, ":encoding(UTF-8)";
select(STDOUT);
$| = 1;

$" = '';

use Pg;

$time = time;

# Use this to clean stuff extracted from the database for html output
sub clean(@) {
  local $str = "@_";
  $str =~ s/&/&amp;/g;
  $str =~ s/</&lt;/g;
  $str =~ s/>/&gt;/g;
  $str =~ s/"/&quot;/g;
  return $str;
}

# Use this to convert REQUEST_URI to unescaped string
sub urldecode(@) {
  local $str = "@_";
  $str =~ s/\%[0-9a-fA-F]{2}/$urldhash{$&}/eg;
  return $str;
}

# Use this to make sure urls don't contain url specials
sub urlencode(@) {
  local $str = "@_";
  $str =~ s/[^-_A-Za-z0-9.$+!*'(),]/$urlehash{$&}/eg;
  return $str;
}

# One time build of data used by url decode
sub urlinit() {
  my $c;
  my $f;
  my $i;
  for ($i=0; $i<=255; $i++) {
    $c = chr($i);
    $f = sprintf('%%%.2X', $i);
    $urldhash{$f} = $c;
    $urldhash{lc($f)} = $c;
    $urlehash{$c} = $f;
  }
}
urlinit;

# +s in the query part are really spaces
$uri = $ENV{REQUEST_URI};
#carp($uri);
if ($uri =~ m/^([^?]*\?)(.*)$/) {
  $uri = $1;
  $temp = $2;
  $temp =~ s/\+/ /g;
  $uri .= $temp;
}
$uri = urldecode($uri);
#carp($uri);
if ($ENV{REQUEST_METHOD} ne '' && $ENV{REQUEST_METHOD} ne 'GET' &&
  $ENV{REQUEST_METHOD} ne 'HEAD') {
  $meth = clean($ENV{REQUEST_METHOD});
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 501 Method not implemented

<html><head>
<title>501 Method Not Implemented</title>
</head><body>
<h1>Method Not Implemented</h1>
Method '$meth' not implented for '$uri'.
</body></html>
EOF
  exit;
}

$ENV{SCRIPT_NAME} =~ s%\?.*$%%;
$ENV{SCRIPT_NAME} =~ s%[^/]*$%%;
$script = $ENV{SCRIPT_NAME};
$script = urldecode($script);
print "----- $script -----\n";
$tstr = "z ABC\xC4\x85def  Ghi\xC4\x99jkl z";
utf8::decode($tstr);
print "$tstr\n";

#carp($script);
# The length check is to protect against buffer overrun attacks.
if (length($uri) > 1000 || $uri !~ m/^\Q$script\E(G|T|W|A)_([\040-\176]*)\.html$/) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
</body></html>
EOF
  exit;
}

$type = $1;
$index = $2;
if ($type eq 'T') {
  $index =~ s/[^-_A-Za-z0-9.]+/_/g;
  $index =~ s/^_+//;
  $index =~ s/_+$//;
}
elsif ($type eq 'A' || $type eq 'G') {
  $index = uc($index);
}

# Check if encoding is safe, otherwise browsers might mess up relative links
$check = $ENV{REQUEST_URI};
#carp($check);
for ($i=0; $i<length($script); $i++) {
  if ($check !~ s/^%[0-9A-Za-z]{2}//) {
    $check =~ s/^.//;
  }
}
$check =~ s/\%[0-9A-Za-z]{2}//g;
#carp($check);
if ($check =~ m/[^-_A-Za-z0-9.+!*'()\$,]/) {
  $loc = 'http://' . $ENV{SERVER_NAME} . $ENV{SCRIPT_NAME} . $type . '_' . urlencode($index) . '.html';
  $cloc = clean($loc);
#carp($cloc);
  print <<"EOF";
content-type: text/html; charset=UTF-8
Status: 301
Location: $loc

<html><head>
<title>301 moved permanently</title>
</head><body>
<h1>301 moved permanently</h1>
Improperly escaped URL. Use <a href="$cloc">$cloc</a> instead.
</body></html>
EOF
  exit;
}

# Quotes and backslashes need to be quoted before using in a pg string constant
$qindex = $index;
$qindex =~ s/\\|'/\\$&/g;

# First try to connect
$conn = Pg::connectdb('dbname=area user=areauser password=areapass host=localhost');
if ($conn->status != PGRES_CONNECTION_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to connect to the database.
</body></html>
EOF
  exit;
}

$result = $conn->exec("begin");
if ($result->resultStatus != PGRES_COMMAND_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to start a transaction.
</body></html>
EOF
  exit;
}

$result = $conn->exec("set transaction isolation level serializable");
if ($result->resultStatus != PGRES_COMMAND_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to serialize transaction.
</body></html>
EOF
  exit;
}

#carp($qindex);
#carp($type);
if ($type eq 'G' || $type eq 'A') {
  $result = $conn->exec("select gameid, title, to_char(touched, 'YYYY-MM-DD'), sol from games where gameid = '$qindex'");
}
elsif ($type eq 'T') {
  $qindex = $index;
  $qindex =~ s/_/[^A-Za-z0-9]+/g;
  $qindex =~ s/\\|'/\\$&/g;
  $result = $conn->exec("select gameid, title, to_char(touched, 'YYYY-MM-DD'), sol from games where title ~* '^[^A-Za-z0-9]*${qindex}[^A-Za-z0-9]*\$'");
}
elsif ($type eq 'W') {
  $result = $conn->exec("select games.gameid, games.title, to_char(games.touched, 'YYYY-MM-DD'), sol from games, wbcgames where wbcgames.gameid = games.gameid and lower(wbcgames.code) = lower('$qindex')");
}
else {
  $uri = clean($ENV{REQUEST_URI});
  $type = clean($type);
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unknown index type '$type'.
</body></html>
EOF
  exit;
}

if ($result->resultStatus != PGRES_TUPLES_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to access the game table.
</body></html>
EOF
  exit;
}
if ($result->ntuples <= 0) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
No such game.
</body></html>
EOF
  exit;
}
elsif ($result->ntuples > 1) {
  print << "EOF";
content-type: text/html; charset=UTF-8

<html>
<head>
<title>Select a Specific Game</title>
</head>
<body>
EOF
{
    local *INPUT;
    if (open(INPUT, "links.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
  print << "EOF";
<h1><a name="_">Select a Specific Game</a></h1>
The following games matched your initial selection criteria.
<ul>
EOF
  while (@row = $result->fetchrow) {
    $gameid = clean(urlencode($row[0]));
    $title = clean($row[1]);
    print "<li><a href=\"G_$gameid.html#_\">$title</a>\n";
  }
  print << "EOF";
</ul>
EOF
{
    local *INPUT;
    if (open(INPUT, "links.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
{
    local *INPUT;
    if (open(INPUT, "sig.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
print << "EOF";
</body>
</html>
EOF
  exit;
}
if (!(@row = $result->fetchrow)) {
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
No such game.
</body></html>
EOF
  exit;
}

$gameid = $row[0];
$gameid = clean($row[0]);
$lgameid = clean(urlencode($row[0]));
$qgameid = $row[0];
$qgameid =~ s/\\|'/\\$&/g;
$title = clean($row[1]);
$gdate = clean($row[2]);
$sol = clean($row[3]);

print << "EOF";
Content-Type: text/html; charset=UTF-8

<html>
<head>
<title>AREA Ratings for $title</title>
</head>
<body>
EOF
{
    local *INPUT;
    if (open(INPUT, "links.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
print << "EOF";
<h1><a name="_">AREA Ratings for $title</a></h1>
EOF

if ($type eq 'A') {
  print "<a href=\"G_$gameid.html#_\">Switch to rank ordering.</a>\n";
}
else {
  print "<a href=\"A_$gameid.html#_\">Switch to alphabetical ordering.</a>\n";
}

$result = $conn->exec("select rtypes.rtype, descr from rtypes, games where gameid = '$qgameid' and rtypes.rtype = games.rtype");
# Only try to print one row as that is all there should be.
if ($result->resultStatus == PGRES_TUPLES_OK && $result->ntuples > 0) {
  @row = $result->fetchrow;
  if ($row[0] !~ m/^\s*$/ && $row[1] !~ m/^\s*$/) {
    $rtype = clean(urlencode($row[0]));
    $descr = clean($row[1]);
    print "<p>\nThis game is rated as a <a href=\"calcexp.html#$rtype\">$descr</a>.\n";
  }
}

if ($sol eq 't') {
  print "<p>It is possible for the game itself to win.\n";
}

$email = 'area-game-' . lc($gameid) . '-' . $time . '@kww.us';
print "<p>\nTo report results for this game you can send email to \n";
print "<a href=\"mailto:$email\">$email</a>.\n";
print "(Note as a measure to reduce spam, this address will only work for 8 hours.)\n";

print "<p>Last updated $gdate.\n";

$result = $conn->exec("select pubname, puburl from gamepubs, publishers where gameid = '$qgameid' and publishers.pubid = gamepubs.pubid");
if ($result->resultStatus == PGRES_TUPLES_OK && $result->ntuples > 0) {
  $s = '';
  $s = 's' if $result->ntuples > 1;
  print << "EOF";
<h2>Publisher$s</h2>
<ul>
EOF
  while (@row = $result->fetchrow) {
    $pub = clean($row[0]);
    $url = clean($row[1]);
    if (defined($row[1])) {
      print "<li><a href=\"$url\">$pub</a>\n";
    }
    else {
      print "<li>$pub\n";
    }
  }
  print "</ul>\n";
}

$result = $conn->exec("select url, comment from gameurls where gameid = '$qgameid' and expires >= 'now' union select url, 'WBC Event: (' || wbc.code || ') ' || coalesce(event, '') from wbc, wbcgames where wbc.code = wbcgames.code and gameid = '$qgameid' and url is not null");
if ($result->resultStatus == PGRES_TUPLES_OK && $result->ntuples > 0) {
  $s = '';
  $s = 's' if $result->ntuples > 1;
  print << "EOF";
<h2>Related Web Page$s</h2>
<ul>
EOF
  while (@row = $result->fetchrow) {
    $url = clean($row[0]);
    $comment = clean($row[1]);
    print "<li><a href=\"$url\">$comment</a>\n";
  }
  print "</ul>\n";
}

$result = $conn->exec("select avg(rate)::bigint, case when count(rate) > 1 then stddev(rate)::bigint end, count(rate), case when count(case when frq >= 10 then rate end) > 1 then stddev(case when frq >= 10 then rate end)::bigint end, count(case when frq >= 10 then rate end) from crate where gameid = '$qgameid' and frq > 0");
undef $row[0];
undef $row[1];
$row[2] = 0;
undef $row[3];
$row[4] = 0;
if ($result->resultStatus == PGRES_TUPLES_OK && $result->ntuples > 0) {
  @row = $result->fetchrow;
}
$row[0] = 'Undefined' unless defined $row[0];
$row[1] = 'Undefined' unless defined $row[1];
$row[3] = 'Undefined' unless defined $row[3];
$mean = clean($row[0]);
$stddev = clean($row[1]);
$count = clean($row[2]);
$stddev10 = clean($row[3]);
$count10 = clean($row[4]);
print << "EOF";
<h2>Game skill information</h2>
<table><col><col align="right" span="2">
<thead><tr><th>Skill Metric<th>Value<th>Population count<tbody>
<tr><td><a href="stddev10.html#$lgameid">Standard Deviation for 10+ rated games</a><td>$stddev10<td>$count10
<tr><td><a href="stddev.html#$lgameid">Standard Deviation for any rated games</a><td>$stddev<td>$count
<tr><td><a href="mean.html#$lgameid">Mean for any rated games</a><td>$mean<td>$count
</table>
EOF

if ($type ne 'A') {
  
  print "<h2>Active Player List</h2>\n";
  $result = $conn->exec("select cname_web.areaid, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), rate, frq, opp, rmp, trn, rmc, to_char(crate.touched,'YYYY-MM-DD'), displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and frq > 0 and crate.touched > ((timestamp 'epoch' + '$time second') + '4 year ago') order by rate desc, lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve active player information from database.\n";
  }
  elsif ($result->ntuples <= 0) {
    print "There are no active players for this game.\n";
  }
  else {
    print << "EOF";
<table><col align="left" span="2"><col align="right" span="7"><col align="left">
<thead><tr><th>AREA ID<th>Name<th>Rank<th>Rating<th>Frequency<th>Opponents<th>Remote play<th>Tournaments<th>Remote Competitions<th>Active date<tbody>
EOF
    $rank = 0;
    $oldrate = -1;
    $oldrank = 0;
    while (@row = $result->fetchrow) {
      $rank++;
      $id = clean(urlencode($row[0]));
      $areaid = clean($row[0]);
      if (!defined($row[1])) {
        $name = '* Name Withheld *';
      }
      else {
        $name = $row[1];
        if (defined($row[4])) {
          $name .= ' ' . $row[4];
        }
        if (defined($row[2])) {
          if (defined($row[3])) {
            $name .= ', ' . $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $name .= ', ' . $row[2];
          }
        }
        elsif (defined($row[3])) {
          $name .= ', ' . $row[3];
        }
      }
      #$name = clean($name);

      $name = eval qq{"$name"};
      utf8::decode($name);
      print "$name";
      $flag = utf8::is_utf8($name);
      $f2 = utf8::valid($name);
      print " - $flag - $f2\n";


      $oldrank = $rank if $row[5] != $oldrate;
      $oldrate = $row[5];
      print "<tr><td><a name=\"$areaid\" href=\"P_$id.html#$gameid\">$row[12]</a><td>$name<td>$oldrank<td>$row[5]<td>$row[6]<td>$row[7]<td>$row[8]<td>$row[9]<td>$row[10]<td>$row[11]\n";
    }
    print "</table>\n";
  }
  
  print "<h2>Inactive Player List</h2>\n";
  $result = $conn->exec("select cname_web.areaid, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), rate, frq, opp, rmp, trn, rmc, to_char(crate.touched,'YYYY-MM-DD'), displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and frq > 0 and crate.touched <= ((timestamp 'epoch' + '$time second') + '4 year ago') and crate.touched > ((timestamp 'epoch' + '$time second') + '12 year ago') order by rate desc, lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve inactive player information from database.\n";
  }
  elsif ($result->ntuples <= 0) {
    print "There are no inactive players for this game.\n";
  }
  else {
    print << "EOF";
<table><col align="left" span="2"><col align="right" span="6"><col align="left">
<thead><tr><th>AREA ID<th>Name<th>Rating<th>Frequency<th>Opponents<th>Remote play<th>Tournaments<th>Remote Competitions<th>Active date<tbody>
EOF
    while (@row = $result->fetchrow) {
      $id = clean(urlencode($row[0]));
      $areaid = clean($row[0]);
      if (!defined($row[1])) {
        $name = '* Name Withheld *';
      }
      else {
        $name = $row[1];
        utf8::decode($name);
        if (defined($row[4])) {
          $name .= ' ' . $row[4];
        }
        if (defined($row[2])) {
          if (defined($row[3])) {
            $name .= ', ' . $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $name .= ', ' . $row[2];
          }
        }
        elsif (defined($row[3])) {
          $name .= ', ' . $row[3];
        }
      }
      $name = clean($name);
      print "<tr><td><a name=\"$areaid\" href=\"P_$id.html#$gameid\">$row[12]</a><td>$name<td>$row[5]<td>$row[6]<td>$row[7]<td>$row[8]<td>$row[9]<td>$row[10]<td>$row[11]\n";
    }
    print "</table>\n";
  }
  
  print "<h2>Other Interested Player List</h2>\n";
  $result = $conn->exec("select cname_web.areaid, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), to_char(crate.touched,'YYYY-MM-DD'), displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and frq <= 0 and crate.touched > ((timestamp 'epoch' + '$time second') + '4 year ago') order by lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve other interested player information from database.\n";
  }
  elsif ($result->ntuples <= 0) {
    print "There are no other interested players for this game.\n";
  }
  else {
    print << "EOF";
<table><col span="3">
<thead><tr><th>AREA ID<th>Name<th>Date<tbody>
EOF
    while (@row = $result->fetchrow) {
      $id = clean(urlencode($row[0]));
      $areaid = clean($row[0]);
      if (!defined($row[1])) {
        $name = '* Name Withheld *';
      }
      else {
        $name = $row[1];
        utf8::decode($name);
        if (defined($row[4])) {
          $name .= ' ' . $row[4];
        }
        if (defined($row[2])) {
          if (defined($row[3])) {
            $name .= ', ' . $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $name .= ', ' . $row[2];
          }
        }
        elsif (defined($row[3])) {
          $name .= ', ' . $row[3];
        }
      }
      $name = clean($name);
      print "<tr><td><a name=\"$areaid\" href=\"P_$id.html#$gameid\">$row[6]</a><td>$name<td>$row[5]\n";
    }
    print "</table>\n";
  }
}
else {
  
  print "<h2>Player List</h2>\n";
  $result = $conn->exec("select cname_web.areaid, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), rate, frq, opp, rmp, trn, rmc, to_char(crate.touched,'YYYY-MM-DD'), displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and crate.touched > ((timestamp 'epoch' + '$time second') + '12 year ago') order by lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve player information from database.\n";
  }
  elsif ($result->ntuples <= 0) {
    print "There are no players for this game.\n";
  }
  else {
    print << "EOF";
<table><col align="left" span="2"><col align="right" span="6"><col align="left">
<thead><tr><th>AREA ID<th>Name<th>Rating<th>Frequency<th>Opponents<th>Remote play<th>Tournaments<th>Remote Competitions<th>Active date<tbody>
EOF
    while (@row = $result->fetchrow) {
      $id = clean(urlencode($row[0]));
      $areaid = clean($row[0]);
      if (!defined($row[1])) {
        $name = '* Name Withheld *';
      }
      else {
        $name = $row[1];
        utf8::decode($name);
        if (defined($row[4])) {
          $name .= ' ' . $row[4];
        }
        if (defined($row[2])) {
          if (defined($row[3])) {
            $name .= ', ' . $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $name .= ', ' . $row[2];
          }
        }
        elsif (defined($row[3])) {
          $name .= ', ' . $row[3];
        }
      }
      $name = clean($name);
      if ($row[6] > 0) {
        print "<tr><td><a name=\"$areaid\" href=\"P_$id.html#$gameid\">$row[12]</a><td>$name<td>$row[5]<td>$row[6]<td>$row[7]<td>$row[8]<td>$row[9]<td>$row[10]<td>$row[11]\n";
      }
      else {
        print "<tr><td><a name=\"$areaid\" href=\"P_$id.html#$gameid\">$row[12]</a><td>$name<td>Interested<td><td><td><td><td><td>$row[11]\n";
      }
    }
    print "</table>\n";
  }
}
{
    local *INPUT;
    if (open(INPUT, "links.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
{
    local *INPUT;
    if (open(INPUT, "sig.html")) {
        print while (<INPUT>);
        close INPUT;
    }
} 
print << "EOF";
</body>
</html>
EOF
