--- /dev/null
+#!/usr/bin/perl -w
+#
+# This script is invoked to process an email sent by the
+# commod-update-receiver Perl script.
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#
+# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
+# are used without permission. This program is not endorsed or
+# sponsored by Three Rings.
+
+# Emails are:
+# multipart/mixed, containing
+# text/plain; name="metadata"; charset="utf-8"
+# Content-Disposition: inline; filename="metadata"
+# ocean\t<ocean> canonical mixed case
+# island\t<island> canonical mixed case
+# timestamp\t<digits> time_t (non-leap secs since start of 1970 UTC)
+# clientname\t<cname> may contain spaces
+# clientversion\t<cversion> may contain spaces
+# clientfixes\t<cfixes> space-delimited list
+# clientspec\t<cspec> <cname>\t<cversion>\t<cfixes>
+# servername\t<sname> may contain spaces
+# serverversion\t<sversion> may contain spaces
+# serverfixes\t<sfixes> space-delimited list
+# serverspec\t<sspec> <sname>\t<serverversion>\t<serverfixes>
+# application/octet-stream; name="deduped.tsv.gz"
+# Content-Disposition: attachment; filename="deduped.tsv.gz"
+# <base64>
+
+use strict (qw(vars));
+
+use POSIX;
+use MIME::Parser;
+
+use Commods;
+use CommodsDatabase;
+
+setlocale(LC_CTYPE, "en_GB.UTF-8");
+my $parser= new MIME::Parser;
+our $entity;
+
+$|=1;
+
+sub find_part ($$$) {
+ my ($filename, $type, $accepter) = @_;
+ foreach my $part ($entity->parts()) {
+ my $h= $part->head();
+ next unless $h->recommended_filename() eq $filename;
+ next unless $h->mime_type() eq $type;
+ next unless $part->effective_type() eq $type;
+ next if defined $accepter and !&$accepter($h);
+ return $part;
+ }
+ die "no appropriate part with name $filename and type $type";
+}
+
+sub bad_data_fail ($) { die $_[0]; }
+
+sub main () {
+ $parser->extract_nested_messages(0);
+ $parser->ignore_errors(0);
+
+ $entity= $parser->parse(\*STDIN);
+ my $eff_type= $entity->effective_type();
+ die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
+
+ my $mdpart= find_part('metadata', 'text/plain', sub {
+ my $charset= $_[0]->mime_attr('content-type.charset');
+ return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
+ });
+
+ my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
+ my %md;
+ while (defined($_= $mdh->getline())) {
+ m/^([a-z]+)\t(.*)$/ or next;
+ $md{$1}= $2;
+ }
+
+ foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
+ defined $md{$needed} or die "missing metadata $needed\n";
+ }
+
+ my $mid= $entity->head()->get('message-id');
+ defined $mid or die "missing Message-ID\n";
+ chomp($mid);
+ $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
+
+ my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
+ undef);
+ my $tsv= pipethrough_prep();
+ $tsvpart->bodyhandle()->print($tsv);
+ my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
+
+ db_setocean($md{'ocean'});
+ my $dbfn= db_filename();
+ (stat $dbfn) or die "stat database $dbfn failed $!\n";
+ db_connect();
+
+ my ($islandid) = $dbh->selectrow_array(
+ "SELECT islands.islandid
+ FROM islands
+ WHERE islandname == ?;
+ ", {}, $md{'island'});
+
+ die "unknown island\n" unless defined $islandid;
+
+ db_doall("DELETE FROM uploads WHERE islandid == $islandid;
+ DELETE FROM buy WHERE islandid == $islandid;
+ DELETE FROM sell WHERE islandid == $islandid;
+ ");
+
+ $dbh->do("INSERT INTO uploads
+ (islandid, message,
+ timestamp, clientspec, serverspec)
+ VALUES (?,?,?,?,?);
+ ", {},
+ $islandid, $mid,
+ map { $md{$_} } (qw(timestamp clientspec serverspec)));
+
+ my (%sth, %sub_cs, %cache_cs, %sth_insert);
+
+ $sth_insert{'stall'}= $dbh->prepare(
+ "INSERT OR IGNORE
+ INTO stalls
+ (islandid, stallname) VALUES ($islandid, ?)
+ ");
+ $sth_insert{'commods'}= $dbh->prepare(
+ "INSERT OR IGNORE
+ INTO commods
+ (commodname) VALUES (?)
+ ");
+
+ foreach my $cs (qw(stall commod)) {
+ my $sth_lookup= $dbh->prepare(
+ "SELECT ${cs}id FROM ${cs}s WHERE ${cs}name == ?;
+ ");
+ $sub_cs{$cs}= sub {
+ my ($name)= @_;
+ my $r= $cache_cs{$cs}{$name};
+ return $r if defined $r;
+ $sth_lookup->execute($name) or die;
+ ($r)= $sth_lookup->fetchrow_array();
+ if (!defined $r) {
+ $sth_insert{$cs}->execute($name);
+ $sth_lookup->execute($name) or die;
+ ($r)= $sth_lookup->fetchrow_array();
+ die unless defined $r;
+ }
+ $cache_cs{$cs}{$name}= $r;
+ return $r;
+ };
+ }
+ my @v;
+
+ my %sub_bs;
+ foreach my $bs (qw(buy sell)) {
+ my $sth= $dbh->prepare(
+ "INSERT INTO $bs
+ (commodid, stallid, islandid, price, qty)
+ VALUES (?,?,?,?,?);
+ ");
+ $sub_bs{$bs}= sub {
+ my ($priceix) = @_;
+ my $price= $v[$priceix]; return if !length $price;
+ my $qty= $v[$priceix+1];
+ $qty++ if $qty =~ s/^\>//;
+ $sth->execute($sub_cs{'commod'}($v[0]),
+ $sub_cs{'stall'}($v[1]),
+ $islandid,$price,$qty);
+ };
+ }
+
+ while (<$pt>) {
+ @v= check_tsv_line($_, \&bad_data_fail);
+# chomp;
+# @v= split /\t/, $_, -1;
+
+ &{$sub_bs{'buy'}}(2);
+ &{$sub_bs{'sell'}}(4);
+
+# print ".";
+ }
+
+ pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
+
+ print "\n";
+ $dbh->commit();
+
+ # select * from ((buy natural join commods) natural join stalls) natural join islands;
+ # select * from ((sell natural join commods) natural join stalls) natural join islands;
+
+}
+
+my $ok= eval {
+ main();
+ 1;
+};
+my $err= $@;
+
+$parser->filer->purge();
+
+if (!$ok) {
+ print STDERR "PROCESSING FAILED\n $@\n";
+ exit 1;
+}
~yarrgweb / ypp-sc-tools.main.git / blobdiff