#!/usr/bin/perl

# Generate Excel sheets for admins
# Bruno Wolff III
# Last revised October 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 Spreadsheet::WriteExcel;
use Spreadsheet::WriteExcel::Utility;

# 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(S)_([\040-\176]*?)_([\040-\176]*)\.xls$/) {
  $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;
$contact = uc($2);
$rtype = uc($3);

# 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($contact) . '_' . urlencode($rtype) . '.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
$qcontact = $contact;
$qcontact =~ s/\\|'/\\$&/g;
$qrtype = $rtype;
$qrtype =~ 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;
}

if ($contact eq '') {
  $contact = 'ALL';
  if ($rtype eq '') {
    $rtype = 'ALL';
    $result = $conn->exec("select gameid, title, to_char(touched, 'FMDD-MM-YYYY') from games order by gameid");
  }
  else {
    $result = $conn->exec("select gameid, title, to_char(touched, 'FMDD-MM-YYYY') from games where rtype = '$qrtype' order by gameid");
  }
}
else {
  if ($rtype eq '') {
    $rtype = 'ALL';
    $result = $conn->exec("select gameid, title, to_char(touched, 'FMDD-MM-YYYY') from games where contact = '$qcontact' order by gameid");
  }
  else {
    $result = $conn->exec("select gameid, title, to_char(touched, 'FMDD-MM-YYYY') from games where contact = '$qcontact' and rtype = '$qrtype' order by gameid");
  }
}

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

$ccontact = $contact;
$ccontact =~ s/\\|"/\\$&/g;
$crtype = $rtype;
$crtype =~ s/\\|"/\\$&/g;
print << "EOF";
content-type: application/vnd.ms-excel
content-disposition: attachment; filename="${ccontact}_$crtype.xls"

EOF

$workbook = Spreadsheet::WriteExcel->new('-');
$formats = $workbook->addformat(num_format => '@');
$formatn = $workbook->addformat(num_format => '0');
$formatd = $workbook->addformat(num_format => 'yyyy-mm-dd');

@gameid = ();
%title = ();
%gdate = ();
while (@row = $result->fetchrow) {
  push @gameid, $row[0];
  $title{$row[0]} = $row[1];
  $gdate{$row[0]} = $row[2];
}

foreach $gameid (@gameid) {
  $title = $title{$gameid};
  $gdate = $gdate{$gameid};
  $qgameid = $gameid;
  $qgameid =~ s/\\|'/\\$&/g;
  $worksheet = $workbook->addworksheet($gameid);
  
  $result = $conn->exec("select pubname from gamepubs, publishers where gamepubs.pubid = publishers.pubid and gameid = '$qgameid' order by lower(pubname)");
  $pub = '';
  $sep = '';
  if ($result->resultStatus == PGRES_TUPLES_OK) {
    while (@row = $result->fetchrow) {
      $pub .= $sep . $row[0];
      $sep = ' / ';
    }
  }
  
  $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, 'FMDD-MM-YYYY'), gm, displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and frq > 0 order by lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus == PGRES_TUPLES_OK) {
    $row = 0;
    $worksheet->write(0, 1, $title, $formats);
    $worksheet->write(0, 3, xl_decode_date_EU($gdate), $formatd);
    $worksheet->write(++$row, 1, $pub) unless $pub eq '';
    $row++;
    $worksheet->write($row, 0, 'Rk', $formats);
    $worksheet->write($row, 1, 'ID', $formats);
    $worksheet->write($row, 2, 'FName', $formats);
    $worksheet->write($row, 3, 'LName', $formats);
    $worksheet->write($row, 4, 'Rate', $formats);
    $worksheet->write($row, 5, 'Frq', $formats);
    $worksheet->write($row, 6, 'Opp', $formats);
    $worksheet->write($row, 7, 'Rmp', $formats);
    $worksheet->write($row, 8, 'Trn', $formats);
    $worksheet->write($row, 9, 'RmC', $formats);
    $worksheet->write($row, 10, 'Active', $formats);
    $worksheet->write($row, 11, 'GM', $formats);
    while (@row = $result->fetchrow) {
      if (!defined($row[1])) {
        $lname = 'Withheld';
        $fname = '';
      }
      else {
        $lname = $row[1];
        if (defined($row[4])) {
          $lname .= ' ' . $row[4];
        }
        $fname = '';
        if (defined($row[2])) {
          if (defined($row[3])) {
            $fname = $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $fname = $row[2];
          }
        }
        elsif (defined($row[3])) {
          $fname = $row[3];
        }
      }
      $row++;
      $worksheet->write($row, 1, $row[13], $formats);
      $worksheet->write($row, 2, $fname, $formats);
      $worksheet->write($row, 3, $lname, $formats);
      $worksheet->write($row, 4, $row[5], $formatn);
      $worksheet->write($row, 5, $row[6], $formatn);
      $worksheet->write($row, 6, $row[7], $formatn);
      $worksheet->write($row, 7, $row[8], $formatn);
      $worksheet->write($row, 8, $row[9], $formatn);
      $worksheet->write($row, 9, $row[10], $formats);
      $worksheet->write($row, 10, xl_decode_date_EU($row[11]), $formatd);
      $worksheet->write($row, 11, $row[12], $formats);
    }
  }
}
$workbook->close();
