chiark / gitweb /
Trying Hunter but it failed
[ypp-sc-tools.db-live.git] / 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
39 use Commods;
40 use CommodsDatabase;
41
42 set_ctype_utf8();
43 my $parser= new MIME::Parser;
44 our $entity;
45
46 $|=1;
47
48 sub find_part ($$$) {
49     my ($filename, $type, $accepter) = @_;
50     foreach my $part ($entity->parts()) {
51         my $h= $part->head();
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);
56         return $part;
57     }
58     die "no appropriate part with name $filename and type $type";
59 }
60
61 sub bad_data_fail ($) { die $_[0]; }
62
63 sub main () {
64     $parser->extract_nested_messages(0);
65     $parser->ignore_errors(0);
66
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';
70
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);
74     });
75
76     my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
77     my %md;
78     while (defined($_= $mdh->getline())) {
79         m/^([a-z]+)\t(.*)$/ or next;
80         $md{$1}= $2;
81     }
82
83     foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
84         defined $md{$needed} or die "missing metadata $needed\n";
85     }
86
87     my $mid= $entity->head()->get('message-id');
88     defined $mid or die "missing Message-ID\n";
89     chomp($mid);
90     $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
91
92     my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
93                            undef);
94     my $tsv= pipethrough_prep();
95     $tsvpart->bodyhandle()->print($tsv);
96     my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
97
98     db_setocean($md{'ocean'});
99     my $dbfn= db_filename();
100     (stat $dbfn) or die "stat database $dbfn failed $!\n";
101     db_writer();
102     db_connect();
103     db_onconflict(sub { print STDERR "temporary failure: @_\n"; exit 75; });
104
105     my ($islandid) = $dbh->selectrow_array(
106               "SELECT islands.islandid
107                       FROM islands
108                       WHERE islandname == ?;
109               ", {}, $md{'island'});
110
111     die "unknown island\n" unless defined $islandid;
112
113     db_doall("DELETE FROM uploads WHERE islandid == $islandid;
114               DELETE FROM buy     WHERE islandid == $islandid;
115               DELETE FROM sell    WHERE islandid == $islandid;
116              ");
117     
118     $dbh->do("INSERT INTO uploads
119                      (islandid, message,
120                       timestamp, clientspec, serverspec)
121                      VALUES (?,?,?,?,?);
122              ", {},
123              $islandid, $mid,
124              map { $md{$_} } (qw(timestamp clientspec serverspec)));
125
126     my (%sth, %sub_cs, %cache_cs, %sth_insert, %sth_lookup);
127
128     $sth_insert{'stall'}= $dbh->prepare(
129                 "INSERT OR IGNORE
130                         INTO stalls
131                         (islandid, stallname) VALUES ($islandid, ?)
132                 ");
133     $sth_lookup{'stall'}= $dbh->prepare(
134                 "SELECT stallid FROM stalls
135                         WHERE islandid == $islandid AND stallname == ?
136                 ");
137     $sth_insert{'commod'}= $dbh->prepare(
138                 "INSERT OR IGNORE
139                         INTO commods
140                         (commodname) VALUES (?)
141                 ");
142     $sth_lookup{'commod'}= $dbh->prepare(
143                 "SELECT commodid FROM commods
144                         WHERE commodname == ?
145                 ");
146
147     foreach my $cs (qw(stall commod)) {
148         $sub_cs{$cs}= sub {
149             my ($name)= @_;
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();
154             if (!defined $r) {
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;
159             }
160             $cache_cs{$cs}{$name}= $r;
161             return $r;
162         };
163     }
164     my @v;
165
166     my %sub_bs;
167     foreach my $bs (qw(buy sell)) {
168         my $sth= $dbh->prepare(
169                "INSERT INTO $bs
170                        (commodid, stallid, islandid, price, qty)
171                        VALUES (?,?,?,?,?);
172                ");
173         $sub_bs{$bs}= sub {
174             my ($priceix) = @_;
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);
181         };          
182     }
183
184     while (<$pt>) {
185         @v= check_tsv_line($_, \&bad_data_fail);
186 #       chomp;
187 #       @v= split /\t/, $_, -1;
188
189         &{$sub_bs{'buy'}}(2);
190         &{$sub_bs{'sell'}}(4);
191
192 #       print ".";
193     }
194
195     pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
196
197 #    print "\n";
198     $dbh->commit();
199
200     # select * from ((buy natural join commods) natural join stalls) natural join islands;
201     # select * from ((sell natural join commods) natural join stalls) natural join islands;
202
203 }
204
205 my $ok= eval {
206     main();
207     1;
208 };
209 my $err= $@;
210
211 $parser->filer->purge();
212
213 if (!$ok) {
214     print STDERR "PROCESSING FAILED\n $@\n";
215     exit 1;
216 }