3 # This script is invoked to process an email sent by the
4 # commod-update-receiver Perl script.
6 # This is part of ypp-sc-tools, a set of third-party tools for assisting
7 # players of Yohoho Puzzle Pirates.
9 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
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.
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.
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/>.
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.
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"
47 use strict (qw(vars));
55 setlocale(LC_CTYPE, "en_GB.UTF-8");
56 my $parser= new MIME::Parser;
62 my ($filename, $type, $accepter) = @_;
63 foreach my $part ($entity->parts()) {
65 next unless $h->recommended_filename() eq $filename;
66 next unless $h->mime_type() eq $type;
67 next unless $part->effective_type() eq $type;
68 next if defined $accepter and !&$accepter($h);
71 die "no appropriate part with name $filename and type $type";
74 sub bad_data_fail ($) { die $_[0]; }
77 $parser->extract_nested_messages(0);
78 $parser->ignore_errors(0);
80 $entity= $parser->parse(\*STDIN);
81 my $eff_type= $entity->effective_type();
82 die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
84 my $mdpart= find_part('metadata', 'text/plain', sub {
85 my $charset= $_[0]->mime_attr('content-type.charset');
86 return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
89 my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
91 while (defined($_= $mdh->getline())) {
92 m/^([a-z]+)\t(.*)$/ or next;
96 foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
97 defined $md{$needed} or die "missing metadata $needed\n";
100 my $mid= $entity->head()->get('message-id');
101 defined $mid or die "missing Message-ID\n";
103 $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
105 my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
107 my $tsv= pipethrough_prep();
108 $tsvpart->bodyhandle()->print($tsv);
109 my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
111 db_setocean($md{'ocean'});
112 my $dbfn= db_filename();
113 (stat $dbfn) or die "stat database $dbfn failed $!\n";
116 my ($islandid) = $dbh->selectrow_array(
117 "SELECT islands.islandid
119 WHERE islandname == ?;
120 ", {}, $md{'island'});
122 die "unknown island\n" unless defined $islandid;
124 db_doall("DELETE FROM uploads WHERE islandid == $islandid;
125 DELETE FROM buy WHERE islandid == $islandid;
126 DELETE FROM sell WHERE islandid == $islandid;
129 $dbh->do("INSERT INTO uploads
131 timestamp, clientspec, serverspec)
135 map { $md{$_} } (qw(timestamp clientspec serverspec)));
137 my (%sth, %sub_cs, %cache_cs, %sth_insert);
139 $sth_insert{'stall'}= $dbh->prepare(
142 (islandid, stallname) VALUES ($islandid, ?)
144 $sth_insert{'commods'}= $dbh->prepare(
147 (commodname) VALUES (?)
150 foreach my $cs (qw(stall commod)) {
151 my $sth_lookup= $dbh->prepare(
152 "SELECT ${cs}id FROM ${cs}s WHERE ${cs}name == ?;
156 my $r= $cache_cs{$cs}{$name};
157 return $r if defined $r;
158 $sth_lookup->execute($name) or die;
159 ($r)= $sth_lookup->fetchrow_array();
161 $sth_insert{$cs}->execute($name);
162 $sth_lookup->execute($name) or die;
163 ($r)= $sth_lookup->fetchrow_array();
164 die unless defined $r;
166 $cache_cs{$cs}{$name}= $r;
173 foreach my $bs (qw(buy sell)) {
174 my $sth= $dbh->prepare(
176 (commodid, stallid, islandid, price, qty)
181 my $price= $v[$priceix]; return if !length $price;
182 my $qty= $v[$priceix+1];
183 $qty++ if $qty =~ s/^\>//;
184 $sth->execute($sub_cs{'commod'}($v[0]),
185 $sub_cs{'stall'}($v[1]),
186 $islandid,$price,$qty);
191 @v= check_tsv_line($_, \&bad_data_fail);
193 # @v= split /\t/, $_, -1;
195 &{$sub_bs{'buy'}}(2);
196 &{$sub_bs{'sell'}}(4);
201 pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
206 # select * from ((buy natural join commods) natural join stalls) natural join islands;
207 # select * from ((sell natural join commods) natural join stalls) natural join islands;
217 $parser->filer->purge();
220 print STDERR "PROCESSING FAILED\n $@\n";