X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fcommod-update-receiver;h=2059ad792416710584c279eb1d2de63032220339;hp=1fe408f9d93c2603525405925c8646deaba8c038;hb=024f4a767b43a66e6ff004532f039b874e401b80;hpb=93732484adcab512e594a928af2536955e8d6cab diff --git a/yarrg/commod-update-receiver b/yarrg/commod-update-receiver index 1fe408f..2059ad7 100755 --- a/yarrg/commod-update-receiver +++ b/yarrg/commod-update-receiver @@ -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 # # 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 . # # 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 yarrg --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 () { 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 $!;