chiark / gitweb /
b7883fc69e574e9331c30c80ff76cf810bb68f77
[ypp-sc-tools.main.git] / pctb / 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 # Emails are:
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"
45 #     <base64>
46
47 use strict (qw(vars));
48
49 use POSIX;
50 use MIME::Parser;
51
52 use Commods;
53 use CommodsDatabase;
54
55 setlocale(LC_CTYPE, "en_GB.UTF-8");
56 my $parser= new MIME::Parser;
57 our $entity;
58
59 sub find_part ($$$) {
60     my ($filename, $type, $accepter) = @_;
61     foreach my $part ($entity->parts()) {
62         my $h= $part->head();
63         next unless $h->recommended_filename() eq $filename;
64         next unless $h->mime_type()            eq $type;
65         next unless $part->effective_type()    eq $type;
66         next if defined $accepter and !&$accepter($h);
67         return $part;
68     }
69     die "no appropriate part with name $filename and type $type";
70 }
71
72 sub bad_data_fail ($) { die $_[0]; }
73
74 sub main () {
75     $parser->extract_nested_messages(0);
76     $parser->ignore_errors(0);
77
78     $entity= $parser->parse(\*STDIN);
79     my $eff_type= $entity->effective_type();
80     die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
81
82     my $mdpart= find_part('metadata', 'text/plain', sub {
83         my $charset= $_[0]->mime_attr('content-type.charset');
84         return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
85     });
86
87     my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
88     my %md;
89     while (defined($_= $mdh->getline())) {
90         m/^([a-z]+)\t(.*)$/ or next;
91         $md{$1}= $2;
92     }
93
94     foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
95         defined $md{$needed} or die "missing metadata $needed\n";
96     }
97
98     my $mid= $entity->head()->get('message-id');
99     defined $mid or die "missing Message-ID\n";
100     chomp($mid);
101     $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
102
103     my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
104                            undef);
105     my $tsv= pipethrough_prep();
106     $tsvpart->bodyhandle()->print($tsv);
107     my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
108
109     db_setocean($md{'ocean'});
110     my $dbfn= db_filename();
111     (stat $dbfn) or die "stat database $dbfn failed $!\n";
112     db_connect();
113
114     my ($islandid) = $dbh->selectrow_array(
115               "SELECT islands.islandid
116                       FROM islands
117                       WHERE islandname == ?;
118               ", {}, $md{'island'});
119
120     die "unknown island\n" unless defined $islandid;
121
122     db_doall("DELETE FROM uploads WHERE islandid == $islandid;
123               DELETE FROM buy     WHERE islandid == $islandid;
124               DELETE FROM sell    WHERE islandid == $islandid;
125              ");
126     
127     $dbh->do("INSERT INTO uploads
128                      (islandid, message,
129                       timestamp, clientspec, serverspec)
130                      VALUES (?,?,?,?,?);
131              ", {},
132              $islandid, $mid,
133              map { $md{$_} } (qw(timestamp clientspec serverspec)));
134
135     my %sth_cs;
136     foreach my $cs (qw(commod stall)) {
137         $sth_cs{$cs}= $dbh->prepare(
138                 "INSERT OR IGNORE
139                         INTO ${cs}s
140                         (${cs}id) VALUES (?)
141                 ");
142     }
143
144     my %sth_bs;
145     foreach my $bs (qw(buy sell)) {
146         $sth_bs{$bs}= $dbh->prepare(
147                "INSERT INTO $bs
148                        (commodid, islandid, stallid, price, qty)
149                        VALUES (
150                          (SELECT commodid FROM commods WHERE commodname = ?),
151                          $islandid,
152                          (SELECT stallid  FROM stalls  WHERE stallname = ?),
153                          ?, ?
154                        )
155                ");
156     }
157
158     while (<$pt>) {
159         my @v= check_tsv_line($_, \&bad_data_fail);
160
161         
162     }
163
164     pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
165
166 }
167
168 my $ok= eval {
169     main();
170     1;
171 };
172 my $err= $@;
173
174 $parser->filer->purge();
175
176 if (!$ok) {
177     print STDERR "PROCESSING FAILED\n $@\n";
178     exit 1;
179 }