pctb/commod-email-processor

   1 #!/usr/bin/perl -
   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 MIME::Parser;
  50
  51 setlocale(LC_CTYPE, "en_GB.UTF-8");
  52 my $mp= new MIME::Parser;
  53 our $entity;
  54
  55 sub find_part ($$) {
  56     my ($filename, $type, $accepter) = @_
  57     foreach my $part ($entity->parts()) {
  58         my $h= $part->head();
  59         next unless $h->recommended_filename() eq $filename;
  60         next unless $h->mime_type()            eq $type;
  61         next unless $part->effective_type()    eq $type;
  62         next unless &$accepter($h) if defined $accepter;
  63         return $part;
  64     }
  65     die "no appropriate part with name $filename and type $type";
  66 }
  67
  68 sub main () {
  69     $parser->extract_nested_messages(0);
  70     $parser->ignore_errors(0);
  71
  72     $entity= $mp->parse(\*STDIN);
  73     my $eff_type= $entity->effective_type();
  74     die "effective type $eff_type" unless $eff_type eq 'multipart/mixed';
  75
  76     my $mdpart= find_part('metadata', 'text/plain', sub {
  77         my $charset= $_[0]->mime_attr('content-type.charset');
  78         return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
  79     });
  80
  81     my $mdh= $mdpart->open('r') or die;
  82     my %md;
  83     while (<$mdh>) {
  84         m/^([a-z]+)\t(.*)$/ or next;
  85         $md{$1}= $2;
  86     }
  87
  88     my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream');
  89     $tsvpart->binmode(1);
  90