chiark / gitweb /
add robots.txt to stop crawlers delving into lookup/ and doing searches etc.
[ypp-sc-tools.db-live.git] / yarrg / commod-update-receiver
index 2c02c11..2059ad7 100755 (executable)
@@ -1,40 +1,30 @@
 #!/usr/bin/perl -w
 #
-# This script is invoked when the YPP SC PCTB client uploads to
+# This script is invoked when the yarrg client uploads to
 # the chiark database.
 
-# This is part of ypp-sc-tools, a set of third-party tools for assisting
-# players of Yohoho Puzzle Pirates.
+# This is part of the YARRG website.  YARRG is a tool and website
+# 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.
+# it under the terms of the GNU Affero 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.
+# GNU Affero General Public License for more details.
 #
-# You should have received a copy of the GNU General Public License
+# You should have received a copy of the GNU Affero 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.
 
-
-# Uploads contain:
-#  ocean                       canonical mixed case
-#  island                      canonical mixed case
-#  clientname                  "ypp-sc-tools"
-#  clientversion               2.1-g2e06a26  [from git-describe --tags HEAD]
-#  clientfixes                 "lastpage"  [space separated list]
-#  data filename=deduped.tsv.gz        output of ypp-commodities --tsv
-
-
 use strict (qw(vars));
 use POSIX;
 use MIME::Entity;
@@ -45,18 +35,19 @@ $CGI::POST_MAX= 3*1024*1024;
 
 use CGI qw/:standard -private_tempfiles/;
 
-setlocale(LC_CTYPE, "en_GB.UTF-8");
+set_ctype_utf8();
 
-my $re_any= "^(.*)\$";
+our $now= time;  defined $now or die $!;
 
-parse_masters();
+my $re_any= "^(.*)\$";
 
 sub fail ($) {
     my ($msg) = @_;
+    addlog("failing $msg");
     print header(-status=>'400 Bad commodity update',
                 -type=>'text/plain',
                 -charset=>'us-ascii');
-    print "Error: $msg\n";
+    print "\nError: $msg\n";
     exit 0;
 }
 
@@ -70,9 +61,39 @@ sub must_param ($$) {
 
 my %o;
 
+if (param('get_source')) {
+    # There's another copy of this in dictionary-update-receiver.  Sorry.
+    print header('application/octet-stream') or die $!;
+    source_tarball('..', sub { print $_[0] or die $!; });
+    exit 0;
+}
+
+parse_info_serverside();
+
+my $midtmp= "_mid-pid$$.hold";
+open MIDTMP, ">$midtmp" or die "$midtmp $!";
+stat MIDTMP or die $!;
+my $ino= (stat _)[1];
+my $midino= "_mid-ino$$.hold";
+rename $midtmp, $midino or die "$midtmp $midino $!";
+close MIDTMP or die $!;
+
+our $hostname= `hostname -f`; $? and die $?;  chomp $hostname or die;
+our $mid= "<$now.$$.$ino\@$hostname>";
+our $pwd= `pwd`; $? and die $?; chomp($pwd);
+our $caller= cgi_get_caller;
+
+sub addlog ($) {
+    print LOG "$mid $caller $_[0]\n" or die $!;
+    flush LOG or die $!;
+}
+
+open LOG, ">>_upload.log" or die $!;
+addlog("receiving");
+
 $o{'clientname'}= must_param('clientname',$re_any);
 my $clientinfo= $clients{$o{'clientname'}};
-fail('unknown client') unless defined $clientinfo;
+fail('unknown client '.errsan($o{'clientname'})) unless defined $clientinfo;
 
 my $clientfixes= must_param('clientfixes', "^([-0-9a-z ]*)\$");
 my @clientfixes= sort grep { m/./ } split /\s+/, $clientfixes;
@@ -84,11 +105,19 @@ foreach my $bug (@$clientinfo) {
 
 $o{'clientversion'}= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$");
 
+if (param('requesttimestamp')) {
+    my $now= time; defined $now or die;
+    print header(-type=>'text/plain', -charset=>'us-ascii'), "OK $now.\n";
+    exit(0);
+}
+
 $o{'ocean'}= must_param('ocean', $re_any);
 $o{'island'}= must_param('island', $re_any);
 
 my $arches= $oceans{$o{'ocean'}};
-fail("unknown ocean") unless $arches;
+fail("unknown ocean ".errsan($o{'ocean'})) unless $arches;
+
+parse_info_serverside_ocean($o{'ocean'});
 
 my $island_found= 0;
 foreach my $islands (values %$arches) {
@@ -97,19 +126,29 @@ foreach my $islands (values %$arches) {
     die if $island_found;
     $island_found= $sources;
 }
-fail("unknown island") unless $island_found;
+fail("unknown island ".errsan($o{'island'})) unless $island_found;
 
 $o{'timestamp'}= must_param('timestamp', "^([1-9]\\d{1,20})\$");
-my $now= time;  defined $now or die $!;
-fail("clock skew") if $o{'timestamp'} >= $now;
+fail("clock skew") if $o{'timestamp'} > $now;
 
 my $indatafh= upload('data');
 defined $indatafh or fail("data is not a file");
 my $datafile= must_param('data',"^(deduped\\.tsv\\.gz)\$");
 
+foreach my $mid (<_mid-*.hold>) {
+    if (!stat $mid) { $!==&ENOENT or die "$mid $!"; next; }
+    my $age= (stat _)[9];
+    next if $age < 60;
+    unlink $mid or $!==&ENOENT or die "$mid $!";
+}
+
+$o{'instance'}= $ENV{'YARRG_INSTANCE'};
+
 my $mcontent= MIME::Entity->build(To => 'yarrg-commod-updates',
+                                 Subject => $ENV{'YARRG_INSTANCE'},
                                  Type => 'multipart/mixed',
                                  Boundary => '=',
+                                 'Message-ID' => $mid,
                                  Charset => 'utf-8');
 
 get_our_version(\%o, 'server');
@@ -150,7 +189,7 @@ my $dedupedtsv= pipethrough_prep();
 
 while (<GZ>) {
     my @v= check_tsv_line($_,\&fail);
-    print $dedupedtsv join('\t',@v),"\n" or die $!;
+    print $dedupedtsv join("\t",@v),"\n" or die $!;
 }
 
 GZ->error and die $!;
@@ -174,5 +213,8 @@ M->error and fail("write sendmail failed! ($!)");
 $?=0; close M; $? and fail("sendmail failed code $?");
 
 print header(-type=>'text/plain', -charset=>'us-ascii'),
-      "OK\n"
+      "OK\nThank you for your submission to YARRG.\n"
     or die $!;
+
+addlog("accepted $o{'clientspec'}");
+close LOG or die $!;