#!/usr/bin/perl

# Customized game report for Boardgamer magazine
# Bruno Wolff III
# Last revised Octorber 13, 2012

# 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

select(STDOUT);
$| = 1;

$" = '';

use Pg;

# 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};
if ($uri =~ m/^([^?]*\?)(.*)$/) {
  $uri = $1;
  $temp = $2;
  $temp =~ s/\+/ /g;
  $uri .= $temp;
}
$uri = urldecode($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);
# The length check is to protect against buffer overrun attacks.
if (length($uri) > 1000 || $uri !~ m/^\Q$script\E(B)_([\040-\176]*)\.tsv$/) {
  $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 = uc($2);

# Check if encoding is safe, otherwise browsers might mess up relative links
$check = $ENV{REQUEST_URI};
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;
if ($check =~ m/[^-_A-Za-z0-9.+!*'()$,]/) {
  $loc = 'http://' . $ENV{SERVER_NAME} . $ENV{SCRIPT_NAME} . $type . '_' . urlencode($index) . '.html';
  $cloc = clean($loc);
  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');
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;
}

$result = $conn->exec("select gameid, title, to_char(touched, 'FMMonth DD, YYYY') from games where gameid = '$qindex'");

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 != 1) {
  $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;
}

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;
}

$time = time;
$gameid = $row[0];
$cgameid = $gameid;
$cgameid =~ s/\\|"/\\$&/g;
$qgameid = $gameid;
$qgameid =~ s/\\|'/\\$&/g;
$title = $row[1];
$gdate = $row[2];

print << "EOF";
content-type: text/tab-separated-values; charset=UTF-8
content-disposition: attachment; filename="$cgameid.tsv"

$title
EOF

$result = $conn->exec("select count(*) from crate where gameid = '$qgameid' and frq > 0 and touched >= ((timestamp 'epoch' + '$time second') + '4 year ago')");
if ($result->resultStatus != PGRES_TUPLES_OK) {
  print "Unknown\t$gdate\n";
}
elsif ($result->ntuples <= 0) {
  print "Unknown\t$gdate\n";
}
elsif (!(@row = $result->fetchrow)) {
  print "Unknown\t$gdate\n";
}
else {
  print "$row[0]\t$gdate\n";
}

$result = $conn->exec("select lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), rate from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and rate > 5000 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 suitable players for this game.\n";
}
else {
  $rank = 0;
  $oldrate = -1;
  $oldrank = 0;
  while (@row = $result->fetchrow) {
    $rank++;
    if (!defined($row[0])) {
      $name = '* Name Withheld *';
    }
    else {
      $name = $row[0];
      if (defined($row[3])) {
        $name .= ' ' . $row[3];
      }
      if (defined($row[1])) {
        if (defined($row[2])) {
          $name = $row[2] . ' (' . $row[1] . ') ' . $name;
        }
        else {
          $name = $row[1] . ' ' . $name;
        }
      }
      elsif (defined($row[2])) {
        $name = $row[2] . ' ' . $name;
      }
    }
    $oldrank = $rank if $row[4] != $oldrate;
    $oldrate = $row[4];
    print "$oldrank\t$name\t$row[4]\n";
  }
}
