From: Ian Jackson <ian@liberator.relativity.greenend.org.uk>
Date: Sat, 25 Jul 2009 14:55:36 +0000 (+0100)
Subject: wip commod-email-processor; tab-delimit metadata in emails
X-Git-Tag: 3.0~39
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=commitdiff_plain;h=dd3abc97940e71298a764e8c5c0d0ce94e052ca6

wip commod-email-processor; tab-delimit metadata in emails
---

diff --git a/pctb/commod-email-processor b/pctb/commod-email-processor
new file mode 100644
index 0000000..2f2231b
--- /dev/null
+++ b/pctb/commod-email-processor
@@ -0,0 +1,90 @@
+#!/usr/bin/perl -
+#
+# This script is invoked to process an email sent by the
+# commod-update-receiver Perl script.
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+#
+# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
+# are used without permission.  This program is not endorsed or
+# sponsored by Three Rings.
+
+# Emails are:
+#  multipart/mixed, containing
+#   text/plain; name="metadata"; charset="utf-8"
+#   Content-Disposition: inline; filename="metadata"
+#     ocean\t<ocean>		canonical mixed case
+#     island\t<island>		canonical mixed case
+#     timestamp\t<digits>	time_t (non-leap secs since start of 1970 UTC)
+#     clientname\t<cname>	may contain spaces
+#     clientversion\t<cversion>	may contain spaces
+#     clientfixes\t<cfixes>	space-delimited list
+#     clientspec\t<cspec>	<cname>\t<cversion>\t<cfixes>
+#     servername\t<sname>	may contain spaces
+#     serverversion\t<sversion>	may contain spaces
+#     serverfixes\t<sfixes>	space-delimited list
+#     serverspec\t<sspec>	<sname>\t<serverversion>\t<serverfixes>
+#   application/octet-stream; name="deduped.tsv.gz"
+#   Content-Disposition: attachment; filename="deduped.tsv.gz"
+#     <base64>
+
+use strict (qw(vars));
+
+use MIME::Parser;
+
+setlocale(LC_CTYPE, "en_GB.UTF-8");
+my $mp= new MIME::Parser;
+our $entity;
+
+sub find_part ($$) {
+    my ($filename, $type, $accepter) = @_
+    foreach my $part ($entity->parts()) {
+	my $h= $part->head();
+	next unless $h->recommended_filename() eq $filename;
+	next unless $h->mime_type()            eq $type;
+	next unless $part->effective_type()    eq $type;
+	next unless &$accepter($h) if defined $accepter;
+	return $part;
+    }
+    die "no appropriate part with name $filename and type $type";
+}
+
+sub main () {
+    $parser->extract_nested_messages(0);
+    $parser->ignore_errors(0);
+
+    $entity= $mp->parse(\*STDIN);
+    my $eff_type= $entity->effective_type();
+    die "effective type $eff_type" unless $eff_type eq 'multipart/mixed';
+
+    my $mdpart= find_part('metadata', 'text/plain', sub {
+	my $charset= $_[0]->mime_attr('content-type.charset');
+	return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
+    });
+
+    my $mdh= $mdpart->open('r') or die;
+    my %md;
+    while (<$mdh>) {
+	m/^([a-z]+)\t(.*)$/ or next;
+	$md{$1}= $2;
+    }
+
+    my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream');
+    $tsvpart->binmode(1);
+    
diff --git a/pctb/commod-update-receiver b/pctb/commod-update-receiver
index 4b52251..1fe8612 100755
--- a/pctb/commod-update-receiver
+++ b/pctb/commod-update-receiver
@@ -34,6 +34,7 @@
 #  clientfixes			"lastpage"  [space separated list]
 #  data filename=deduped.tsv.gz	output of ypp-commodities --tsv
 
+
 use strict (qw(vars));
 use POSIX;
 use MIME::Entity;
@@ -113,7 +114,7 @@ my $mcontent= MIME::Entity->build(To => 'yarrg-commod-updates',
 
 get_our_version(\%o, 'server');
 foreach my $cs (qw(client server)) {
-    $o{"${cs}spec"}= join ' ', map { $o{$cs.$_} } qw(name version fixes);
+    $o{"${cs}spec"}= join "\t", map { $o{$cs.$_} } qw(name version fixes);
 }
 
 my $metadata= '';