yarrg/commod-email-processor

   1 #!/usr/bin/perl -w
   2 #
   3 # This script is invoked to process an email sent by the
   4 # commod-update-receiver Perl script.
   5
   6 # This is part of ypp-sc-tools, a set of third-party tools for assisting
   7 # players of Yohoho Puzzle Pirates.
   8 #
   9 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
  10 #
  11 # This program is free software: you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation, either version 3 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public License
  22 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23 #
  24 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  25 # are used without permission.  This program is not endorsed or
  26 # sponsored by Three Rings.
  27
  28 # Emails are:
  29 #  multipart/mixed, containing
  30 #   text/plain; name="metadata"; charset="utf-8"
  31 #   Content-Disposition: inline; filename="metadata"
  32 #     ocean\t<ocean>            canonical mixed case
  33 #     island\t<island>          canonical mixed case
  34 #     timestamp\t<digits>       time_t (non-leap secs since start of 1970 UTC)
  35 #     clientname\t<cname>       may contain spaces
  36 #     clientversion\t<cversion> may contain spaces
  37 #     clientfixes\t<cfixes>     space-delimited list
  38 #     clientspec\t<cspec>       <cname>\t<cversion>\t<cfixes>
  39 #     servername\t<sname>       may contain spaces
  40 #     serverversion\t<sversion> may contain spaces
  41 #     serverfixes\t<sfixes>     space-delimited list
  42 #     serverspec\t<sspec>       <sname>\t<serverversion>\t<serverfixes>
  43 #   application/octet-stream; name="deduped.tsv.gz"
  44 #   Content-Disposition: attachment; filename="deduped.tsv.gz"
  45 #     <base64>
  46
  47 use strict (qw(vars));
  48
  49 use POSIX;
  50 use MIME::Parser;
  51
  52 BEGIN {
  53     my $selfdir= $0;
  54     $selfdir =~ s,/+[^/]*$,,;
  55     chdir("$selfdir") or die "$selfdir $!";
  56 }
  57
  58 use Commods;
  59 use CommodsDatabase;
  60
  61 setlocale(LC_CTYPE, "en_GB.UTF-8");
  62 my $parser= new MIME::Parser;
  63 our $entity;
  64
  65 $|=1;
  66
  67 sub find_part ($$$) {
  68     my ($filename, $type, $accepter) = @_;
  69     foreach my $part ($entity->parts()) {
  70         my $h= $part->head();
  71         next unless $h->recommended_filename() eq $filename;
  72         next unless $h->mime_type()            eq $type;
  73         next unless $part->effective_type()    eq $type;
  74         next if defined $accepter and !&$accepter($h);
  75         return $part;
  76     }
  77     die "no appropriate part with name $filename and type $type";
  78 }
  79
  80 sub bad_data_fail ($) { die $_[0]; }
  81
  82 sub main () {
  83     $parser->extract_nested_messages(0);
  84     $parser->ignore_errors(0);
  85
  86     $entity= $parser->parse(\*STDIN);
  87     my $eff_type= $entity->effective_type();
  88     die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
  89
  90     my $mdpart= find_part('metadata', 'text/plain', sub {
  91         my $charset= $_[0]->mime_attr('content-type.charset');
  92         return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
  93     });
  94
  95     my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
  96     my %md;
  97     while (defined($_= $mdh->getline())) {
  98         m/^([a-z]+)\t(.*)$/ or next;
  99         $md{$1}= $2;
 100     }
 101
 102     foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
 103         defined $md{$needed} or die "missing metadata $needed\n";
 104     }
 105
 106     my $mid= $entity->head()->get('message-id');
 107     defined $mid or die "missing Message-ID\n";
 108     chomp($mid);
 109     $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
 110
 111     my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
 112                            undef);
 113     my $tsv= pipethrough_prep();
 114     $tsvpart->bodyhandle()->print($tsv);
 115     my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
 116
 117     db_setocean($md{'ocean'});
 118     my $dbfn= db_filename();
 119     (stat $dbfn) or die "stat database $dbfn failed $!\n";
 120     db_connect();
 121
 122     my ($islandid) = $dbh->selectrow_array(
 123               "SELECT islands.islandid
 124                       FROM islands
 125                       WHERE islandname == ?;
 126               ", {}, $md{'island'});
 127
 128     die "unknown island\n" unless defined $islandid;
 129
 130     db_doall("DELETE FROM uploads WHERE islandid == $islandid;
 131               DELETE FROM buy     WHERE islandid == $islandid;
 132               DELETE FROM sell    WHERE islandid == $islandid;
 133              ");
 134
 135     $dbh->do("INSERT INTO uploads
 136                      (islandid, message,
 137                       timestamp, clientspec, serverspec)
 138                      VALUES (?,?,?,?,?);
 139              ", {},
 140              $islandid, $mid,
 141              map { $md{$_} } (qw(timestamp clientspec serverspec)));
 142
 143     my (%sth, %sub_cs, %cache_cs, %sth_insert);
 144
 145     $sth_insert{'stall'}= $dbh->prepare(
 146                 "INSERT OR IGNORE
 147                         INTO stalls
 148                         (islandid, stallname) VALUES ($islandid, ?)
 149                 ");
 150     $sth_insert{'commods'}= $dbh->prepare(
 151                 "INSERT OR IGNORE
 152                         INTO commods
 153                         (commodname) VALUES (?)
 154                 ");
 155
 156     foreach my $cs (qw(stall commod)) {
 157         my $sth_lookup= $dbh->prepare(
 158                 "SELECT ${cs}id FROM ${cs}s WHERE ${cs}name == ?;
 159                 ");
 160         $sub_cs{$cs}= sub {
 161             my ($name)= @_;
 162             my $r= $cache_cs{$cs}{$name};
 163             return $r if defined $r;
 164             $sth_lookup->execute($name) or die;
 165             ($r)= $sth_lookup->fetchrow_array();
 166             if (!defined $r) {
 167                 $sth_insert{$cs}->execute($name);
 168                 $sth_lookup->execute($name) or die;
 169                 ($r)= $sth_lookup->fetchrow_array();
 170                 die unless defined $r;
 171             }
 172             $cache_cs{$cs}{$name}= $r;
 173             return $r;
 174         };
 175     }
 176     my @v;
 177
 178     my %sub_bs;
 179     foreach my $bs (qw(buy sell)) {
 180         my $sth= $dbh->prepare(
 181                "INSERT INTO $bs
 182                        (commodid, stallid, islandid, price, qty)
 183                        VALUES (?,?,?,?,?);
 184                ");
 185         $sub_bs{$bs}= sub {
 186             my ($priceix) = @_;
 187             my $price= $v[$priceix];  return if !length $price;
 188             my $qty= $v[$priceix+1];
 189             $qty++ if $qty =~ s/^\>//;
 190             $sth->execute($sub_cs{'commod'}($v[0]),
 191                           $sub_cs{'stall'}($v[1]),
 192                           $islandid,$price,$qty);
 193         };
 194     }
 195
 196     while (<$pt>) {
 197         @v= check_tsv_line($_, \&bad_data_fail);
 198 #       chomp;
 199 #       @v= split /\t/, $_, -1;
 200
 201         &{$sub_bs{'buy'}}(2);
 202         &{$sub_bs{'sell'}}(4);
 203
 204 #       print ".";
 205     }
 206
 207     pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
 208
 209     print "\n";
 210     $dbh->commit();
 211
 212     # select * from ((buy natural join commods) natural join stalls) natural join islands;
 213     # select * from ((sell natural join commods) natural join stalls) natural join islands;
 214
 215 }
 216
 217 my $ok= eval {
 218     main();
 219     1;
 220 };
 221 my $err= $@;
 222
 223 $parser->filer->purge();
 224
 225 if (!$ok) {
 226     print STDERR "PROCESSING FAILED\n $@\n";
 227     exit 1;
 228 }