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.
28 use strict (qw(vars));
35 $selfdir =~ s,/+[^/]*$,,;
36 chdir("$selfdir") or die "$selfdir $!";
43 my $parser= new MIME::Parser;
49 my ($filename, $type, $accepter) = @_;
50 foreach my $part ($entity->parts()) {
52 next unless $h->recommended_filename() eq $filename;
53 next unless $h->mime_type() eq $type;
54 next unless $part->effective_type() eq $type;
55 next if defined $accepter and !&$accepter($h);
58 die "no appropriate part with name $filename and type $type";
61 sub bad_data_fail ($) { die $_[0]; }
64 $parser->extract_nested_messages(0);
65 $parser->ignore_errors(0);
67 $entity= $parser->parse(\*STDIN);
68 my $eff_type= $entity->effective_type();
69 die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
71 my $mdpart= find_part('metadata', 'text/plain', sub {
72 my $charset= $_[0]->mime_attr('content-type.charset');
73 return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
76 my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
78 while (defined($_= $mdh->getline())) {
79 m/^([a-z]+)\t(.*)$/ or next;
83 foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
84 defined $md{$needed} or die "missing metadata $needed\n";
87 my $mid= $entity->head()->get('message-id');
88 defined $mid or die "missing Message-ID\n";
90 $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
92 my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
94 my $tsv= pipethrough_prep();
95 $tsvpart->bodyhandle()->print($tsv);
96 my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
98 db_setocean($md{'ocean'});
99 my $dbfn= db_filename();
100 (stat $dbfn) or die "stat database $dbfn failed $!\n";
103 db_onconflict(sub { print STDERR "temporary failure: @_\n"; exit 75; });
105 my ($islandid) = $dbh->selectrow_array(
106 "SELECT islands.islandid
108 WHERE islandname == ?;
109 ", {}, $md{'island'});
111 die "unknown island\n" unless defined $islandid;
113 db_doall("DELETE FROM uploads WHERE islandid == $islandid;
114 DELETE FROM buy WHERE islandid == $islandid;
115 DELETE FROM sell WHERE islandid == $islandid;
118 $dbh->do("INSERT INTO uploads
120 timestamp, clientspec, serverspec)
124 map { $md{$_} } (qw(timestamp clientspec serverspec)));
126 my (%sth, %sub_cs, %cache_cs, %sth_insert, %sth_lookup);
128 $sth_insert{'stall'}= $dbh->prepare(
131 (islandid, stallname) VALUES ($islandid, ?)
133 $sth_lookup{'stall'}= $dbh->prepare(
134 "SELECT stallid FROM stalls
135 WHERE islandid == $islandid AND stallname == ?
137 $sth_insert{'commod'}= $dbh->prepare(
140 (commodname) VALUES (?)
142 $sth_lookup{'commod'}= $dbh->prepare(
143 "SELECT commodid FROM commods
144 WHERE commodname == ?
147 foreach my $cs (qw(stall commod)) {
150 my $r= $cache_cs{$cs}{$name};
151 return $r if defined $r;
152 $sth_lookup{$cs}->execute($name) or die;
153 ($r)= $sth_lookup{$cs}->fetchrow_array();
155 $sth_insert{$cs}->execute($name);
156 $sth_lookup{$cs}->execute($name) or die;
157 ($r)= $sth_lookup{$cs}->fetchrow_array();
158 die unless defined $r;
160 $cache_cs{$cs}{$name}= $r;
167 foreach my $bs (qw(buy sell)) {
168 my $sth= $dbh->prepare(
170 (commodid, stallid, islandid, price, qty)
175 my $price= $v[$priceix]; return if !length $price;
176 my $qty= $v[$priceix+1];
177 $qty++ if $qty =~ s/^\>//;
178 $sth->execute($sub_cs{'commod'}($v[0]),
179 $sub_cs{'stall'}($v[1]),
180 $islandid,$price,$qty);
185 @v= check_tsv_line($_, \&bad_data_fail);
187 # @v= split /\t/, $_, -1;
189 &{$sub_bs{'buy'}}(2);
190 &{$sub_bs{'sell'}}(4);
195 pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
200 # Warning! Below runes are bogus. Do not use NATURAL JOIN!
201 # select * from ((buy natural join commods) natural join stalls) natural join islands;
202 # select * from ((sell natural join commods) natural join stalls) natural join islands;
212 $parser->filer->purge();
215 print STDERR "PROCESSING FAILED\n $@\n";