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 use strict (qw(vars));
  29
  30 use POSIX;
  31 use MIME::Parser;
  32
  33 BEGIN {
  34     my $selfdir= $0;
  35     $selfdir =~ s,/+[^/]*$,,;
  36     chdir("$selfdir") or die "$selfdir $!";
  37
  38     unshift @INC, qw(.);
  39 }
  40
  41 use Commods;
  42 use CommodsDatabase;
  43
  44 set_ctype_utf8();
  45 my $parser= new MIME::Parser;
  46 our $entity;
  47
  48 $|=1;
  49
  50 sub find_part ($$$) {
  51     my ($filename, $type, $accepter) = @_;
  52     foreach my $part ($entity->parts()) {
  53         my $h= $part->head();
  54         next unless $h->recommended_filename() eq $filename;
  55         next unless $h->mime_type()            eq $type;
  56         next unless $part->effective_type()    eq $type;
  57         next if defined $accepter and !&$accepter($h);
  58         return $part;
  59     }
  60     die "no appropriate part with name $filename and type $type";
  61 }
  62
  63 sub bad_data_fail ($) { die $_[0]; }
  64
  65 sub main () {
  66     $parser->extract_nested_messages(0);
  67     $parser->ignore_errors(0);
  68
  69     $entity= $parser->parse(\*STDIN);
  70     my $eff_type= $entity->effective_type();
  71     die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
  72
  73     my $mdpart= find_part('metadata', 'text/plain', sub {
  74         my $charset= $_[0]->mime_attr('content-type.charset');
  75         return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
  76     });
  77
  78     my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
  79     my %md;
  80     while (defined($_= $mdh->getline())) {
  81         m/^([a-z]+)\t(.*)$/ or next;
  82         $md{$1}= $2;
  83     }
  84
  85     foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
  86         defined $md{$needed} or die "missing metadata $needed\n";
  87     }
  88
  89     my $mid= $entity->head()->get('message-id');
  90     defined $mid or die "missing Message-ID\n";
  91     chomp($mid);
  92     $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
  93
  94     my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
  95                            undef);
  96     my $tsv= pipethrough_prep();
  97     $tsvpart->bodyhandle()->print($tsv);
  98     my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
  99
 100     db_setocean($md{'ocean'});
 101     my $dbfn= db_filename();
 102     (stat $dbfn) or die "stat database $dbfn failed $!\n";
 103     db_writer();
 104     db_connect();
 105     db_onconflict(sub { print STDERR "temporary failure: @_\n"; exit 75; });
 106
 107     my ($islandid) = $dbh->selectrow_array(
 108               "SELECT islands.islandid
 109                       FROM islands
 110                       WHERE islandname == ?;
 111               ", {}, $md{'island'});
 112
 113     die "unknown island\n" unless defined $islandid;
 114
 115     db_doall("DELETE FROM uploads WHERE islandid == $islandid;
 116               DELETE FROM buy     WHERE islandid == $islandid;
 117               DELETE FROM sell    WHERE islandid == $islandid;
 118              ");
 119
 120     $dbh->do("INSERT INTO uploads
 121                      (islandid, message,
 122                       timestamp, clientspec, serverspec)
 123                      VALUES (?,?,?,?,?);
 124              ", {},
 125              $islandid, $mid,
 126              map { $md{$_} } (qw(timestamp clientspec serverspec)));
 127
 128     my (%sth, %sub_cs, %cache_cs, %sth_insert, %sth_lookup);
 129
 130     $sth_insert{'stall'}= $dbh->prepare(
 131                 "INSERT OR IGNORE
 132                         INTO stalls
 133                         (islandid, stallname) VALUES ($islandid, ?)
 134                 ");
 135     $sth_lookup{'stall'}= $dbh->prepare(
 136                 "SELECT stallid FROM stalls
 137                         WHERE islandid == $islandid AND stallname == ?
 138                 ");
 139     $sth_insert{'commod'}= $dbh->prepare(
 140                 "INSERT OR IGNORE
 141                         INTO commods
 142                         (commodname) VALUES (?)
 143                 ");
 144     $sth_lookup{'commod'}= $dbh->prepare(
 145                 "SELECT commodid FROM commods
 146                         WHERE commodname == ?
 147                 ");
 148
 149     foreach my $cs (qw(stall commod)) {
 150         $sub_cs{$cs}= sub {
 151             my ($name)= @_;
 152             my $r= $cache_cs{$cs}{$name};
 153             return $r if defined $r;
 154             $sth_lookup{$cs}->execute($name) or die;
 155             ($r)= $sth_lookup{$cs}->fetchrow_array();
 156             if (!defined $r) {
 157                 $sth_insert{$cs}->execute($name);
 158                 $sth_lookup{$cs}->execute($name) or die;
 159                 ($r)= $sth_lookup{$cs}->fetchrow_array();
 160                 die unless defined $r;
 161             }
 162             $cache_cs{$cs}{$name}= $r;
 163             return $r;
 164         };
 165     }
 166     my @v;
 167
 168     my %sub_bs;
 169     foreach my $bs (qw(buy sell)) {
 170         my $sth= $dbh->prepare(
 171                "INSERT INTO $bs
 172                        (commodid, stallid, islandid, price, qty)
 173                        VALUES (?,?,?,?,?);
 174                ");
 175         $sub_bs{$bs}= sub {
 176             my ($priceix) = @_;
 177             my $price= $v[$priceix];  return if !length $price;
 178             my $qty= $v[$priceix+1];
 179             $qty++ if $qty =~ s/^\>//;
 180             $sth->execute($sub_cs{'commod'}($v[0]),
 181                           $sub_cs{'stall'}($v[1]),
 182                           $islandid,$price,$qty);
 183         };
 184     }
 185
 186     while (<$pt>) {
 187         @v= check_tsv_line($_, \&bad_data_fail);
 188 #       chomp;
 189 #       @v= split /\t/, $_, -1;
 190
 191         &{$sub_bs{'buy'}}(2);
 192         &{$sub_bs{'sell'}}(4);
 193
 194 #       print ".";
 195     }
 196
 197     pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
 198
 199 #    print "\n";
 200     db_chkcommit(0);
 201
 202     # Warning!  Below runes are bogus.  Do not use NATURAL JOIN!
 203     # select * from ((buy natural join commods) natural join stalls) natural join islands;
 204     # select * from ((sell natural join commods) natural join stalls) natural join islands;
 205
 206 }
 207
 208 my $ok= eval {
 209     main();
 210     1;
 211 };
 212 my $err= $@;
 213
 214 $parser->filer->purge();
 215
 216 if (!$ok) {
 217     print STDERR "PROCESSING FAILED\n $@\n";
 218     exit 1;
 219 }