From b958771fa67513ba09630953ec91b9d21b3f42f9 Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Fri, 24 Jul 2009 20:15:46 +0100 Subject: [PATCH] WIP commod-update-receiver testing --- pctb/Commods.pm | 80 +++++++++++++++++++++++++++++++---- pctb/commod-results-processor | 63 +++++++++++++++------------ pctb/commod-update-receiver | 59 +++++++++++++------------- pctb/master-master.txt | 2 +- 4 files changed, 137 insertions(+), 67 deletions(-) diff --git a/pctb/Commods.pm b/pctb/Commods.pm index e695f15..073906f 100644 --- a/pctb/Commods.pm +++ b/pctb/Commods.pm @@ -1,6 +1,7 @@ package Commods; use IO::File; +use HTTP::Request::Common (); use strict; use warnings; @@ -12,7 +13,10 @@ BEGIN { @ISA = qw(Exporter); @EXPORT = qw(&parse_masters %oceans %commods %clients &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap - &get_our_version); + &get_our_version + &pipethrough_prep &pipethrough_run + &pipethrough_run_gzip + &cgipostform); %EXPORT_TAGS = ( ); @EXPORT_OK = qw(); @@ -109,14 +113,72 @@ sub parse_pctb_commodmap () { return 1; } -sub get_our_version ($) { - my ($prefix); - { - no strict (qw(refs)); - ${ "${prefix}name" }= 'ypp-sc-tools yarrg'; - ${ "${prefix}fixes" }= 'lastpage'; - ${ "${prefix}version" }= `git-describe --tags HEAD`; - $? and die $?; +sub get_our_version ($$) { + my ($aref,$prefix) = @_; + $aref->{"${prefix}name"}= 'ypp-sc-tools yarrg'; + $aref->{"${prefix}fixes"}= 'lastpage'; + $aref->{"${prefix}version"}= `git-describe --tags HEAD`; $? and die $?; + return $aref; +} + +sub pipethrough_prep () { + my $tf= IO::File::new_tmpfile() or die $!; + return $tf; +} + +sub pipethrough_run ($$$@) { + my ($tf, $childprep, $cmd, @a) = @_; + $tf->flush or die $!; + $tf->seek(0,0) or die $!; + my $child= open GZ, "-|"; defined $child or die $!; + if (!$child) { + open STDIN, "<&", $tf; + &$childprep() if defined $childprep; + exec $cmd @a; die $!; + } + my $r; + { undef $/; $!=0; $r= ; } + defined $r or die $!; + close GZ or die "$! $?"; die $? if $?; + return $r; +} +sub pipethrough_run_gzip ($) { + pipethrough_run($_[0],undef,'gzip','gzip'); +} + +sub cgipostform ($$$) { + my ($ua, $url, $form) = @_; + my $req= HTTP::Request::Common::POST($url, + Content => $form, + Content_Type => 'form-data'); + if ($url =~ m,^\.?/,) { + my $tf= pipethrough_prep(); + print $tf $req->content() or die $!; +#print STDERR "[[[",$req->content(),"]]]"; + my $out= pipethrough_run($tf, sub { + $ENV{'REQUEST_METHOD'}= 'POST'; + $ENV{'QUERY_STRING'}= ''; + $ENV{'PATH_TRANSLATED'}= $url; + $ENV{'PATH_INFO'}= ''; + $ENV{'HTTP_HOST'}= 'localhost'; + $ENV{'REMOTE_ADDR'}= '127.0.0.1'; + $ENV{'GATEWAY_INTERFACE'}= 'CGI/1.1'; + $ENV{'DOCUMENT_ROOT'}= '.'; + $ENV{'SCRIPT_FILENAME'}= $url; + $ENV{'SCRIPT_NAME'}= $url; + $ENV{'HTTP_USER_AGENT'}= 'Commods.pm local test'; + + foreach my $f (qw(Content_Length Content_Type)) { + $ENV{uc $f}= $req->header($f); + } +#system 'printenv >&2'; + }, "$url", "$url"); + $out =~ m,^Content-Type: text/plain.*\n\n, or die "$out ?"; + return $'; + } else { + my $resp= $ua->request($url,$req); + die $resp->status_line unless $resp->is_success; + return $resp->content(); } } diff --git a/pctb/commod-results-processor b/pctb/commod-results-processor index cba01d9..0286ab3 100755 --- a/pctb/commod-results-processor +++ b/pctb/commod-results-processor @@ -193,29 +193,36 @@ sub main__bestprices () { } } -sub bs_p_tsv ($) { - my ($bs) = @_; +sub bs_p_tsv ($$) { + my ($f, $bs) = @_; if (exists $current->{$bs}{$stall}) { my $si= $current->{$bs}{$stall}; - printf("\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!; + printf($f "\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!; } else { - printf("\t\t") or die $!; + printf($f "\t\t") or die $!; } } -sub main__tsv () { +sub write_tsv ($) { + my ($f) = @_; foreach $commod (sort keys %commod) { $current= $commod{$commod}; my %stalls; map { $stalls{$_}=1; } keys %{ $current->{Buy} }; map { $stalls{$_}=1; } keys %{ $current->{Sell} }; foreach $stall (sort keys %stalls) { - printf("%s\t%s", $commod, $stall) or die $!; - bs_p_tsv(Buy); - bs_p_tsv(Sell); - print("\n") or die $!; + printf($f "%s\t%s", $commod, $stall) or die $!; + bs_p_tsv($f, Buy); + bs_p_tsv($f, Sell); + print($f "\n") or die $!; } } + $f->error and die $!; + $f->flush or die $!; +} + +sub main__tsv () { + write_tsv(\*STDOUT); } @@ -426,30 +433,30 @@ sub save_upload_html ($$) { sub gzip ($) { my ($raw) = @_; - my $tf= IO::File::new_tmpfile() or die $!; + my $tf= pipethrough_prep(); print $tf $raw or die $!; - $tf->flush or die $!; - $tf->seek(0,0) or die $!; - my $child= open GZ, "-|"; defined $child or die $!; - if (!$child) { - open STDIN, "<&", $tf; - exec 'gzip'; die $!; - } - my $r; - { undef $/; $!=0; $r= ; } - defined $r or die $!; - close GZ or die "$! $?"; die $? if $?; - return $r; + return pipethrough_run($tf,undef,'gzip','gzip'); } sub main__uploadyaarg () { - my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean; - my $island= $ENV{'YPPSC_ISLAND'}; die unless $island; - my $content= { - 'data' => [ undef, 'deduped.tsv.gz', + my %o; + $o{'ocean'}= $ENV{'YPPSC_OCEAN'} or die; + $o{'island'}= $ENV{'YPPSC_ISLAND'} or die; + $o{'timestamp'}= 10; + get_our_version(\%o, 'client'); + + my $tf= pipethrough_prep(); + write_tsv($tf); + my $oz= pipethrough_run_gzip($tf); + $o{'data'}= [ undef, 'deduped.tsv.gz', Content_Type => 'application/octet-stream', - Content => '' -]}; + Content => $oz ]; + + my $dest= $ENV{'YPPSC_YAARG_SUBMIT'}; + + my $respcontent= cgipostform($ua, "$dest/commod-update-receiver", \%o); + + print $respcontent(); } sub main__uploadpctb () { diff --git a/pctb/commod-update-receiver b/pctb/commod-update-receiver index b7bf4cb..ac52fec 100755 --- a/pctb/commod-update-receiver +++ b/pctb/commod-update-receiver @@ -36,11 +36,11 @@ use strict (qw(vars)); use POSIX; +use MIME::Entity; use Commods; $CGI::POST_MAX= 3*1024*1024; -$CGI::DISABLE_UPLOADS= 1; use CGI qw/:standard -private_tempfiles/; @@ -67,75 +67,76 @@ sub must_param ($$) { return $1; } -my $clientname= must_param('clientname',$re_any); -my $clientinfo= $clients{$clientname}; +my %o; + +$o{'clientname'}= must_param('clientname',$re_any); +my $clientinfo= $clients{$o{'clientname'}}; fail('unknown client') unless defined $clientinfo; my $clientfixes= must_param('clientfixes', "^([-0-9a-z ]*)\$"); my @clientfixes= sort grep { m/./ } split /\s+/, $clientfixes; -$clientfixes= "@clientfixes"; +$o{'clientfixes'}= "@clientfixes"; foreach my $bug (@$clientinfo) { fail("client out of date - missing bugfix \`$bug'") unless grep { $_ eq $bug } @clientfixes; } -my $clientversion= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$"); +$o{'clientversion'}= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$"); -my $ocean= must_param('ocean', $re_any); -my $island= must_param('island', $re_any); +$o{'ocean'}= must_param('ocean', $re_any); +$o{'island'}= must_param('island', $re_any); -my $arches= $oceans{$ocean}; +my $arches= $oceans{$o{'ocean'}}; fail("unknown ocean") unless $arches; my $island_found= 0; foreach my $islands (values %$arches) { - my $sources= $islands->{$island}; + my $sources= $islands->{$o{'island'}}; next unless $sources; die if $island_found; $island_found= $sources; } fail("unknown island") unless $island_found; -my $timestamp= must_param('timestamp', "^([1-9]\\d{1,20})\$"); +$o{'timestamp'}= must_param('timestamp', "^([1-9]\\d{1,20})\$"); my $now= time; defined $now or die $!; -fail("clock skew") if $timestamp >= $now; +fail("clock skew") if $o{'timestamp'} >= $now; -die if $ocean =~ m/\=/; -die if $island =~ m/\=/; +die if $o{'ocean'} =~ m/\=/; +die if $o{'island'} =~ m/\=/; my $indatafh= upload('data'); defined $indatafh or fail("data is not a file"); my $datafile= must_param('data',"^(deduped\\.tsv\\.gz)\$"); -our %done; - my $mcontent= MIME::Entity->build(To => 'yarrg-commod-updates', Type => 'multipart/mixed', Boundary => '=', Charset => 'utf-8'); -our ($servername,$serverversion,$serverfixes); -get_our_version('::server'); - -my $clientspec= "$clientname $clientversion $clientfixes"; -my $serverspec= "$servername $serverversion $serverfixes"; +get_our_version(\%o, 'server'); +foreach my $cs (qw(client server)) { + $o{"${cs}spec"}= join ' ', map { $o{$cs.$_} } qw(name version fixes); +} -foreach my $vn (qw(ocean island timestamp - clientspec clientname clientversion clientfixes - serverspec servername serverversion serverfixes)) { +foreach my $vn (sort keys %o) { my $mpart= MIME::Entity->build(Type => 'text/plain', Charset => 'utf-8', Disposition => 'inline', - Data => $$vn); + Data => $o{$vn}); $mcontent->add_part($mpart); } -my $gunzchild= open(GZ, "-|") or die $!; +my $gunzchild= open(GZ, "-|"); defined $gunzchild or die $!; if (!$gunzchild) { open STDIN, "<&=", $indatafh or die $!; - execlp 'gunzip'; die $!; + exec 'gunzip'; die $!; } +sub bad_data ($) { fail("bad data: line $.: $_[0]"); } + +our %done; + while () { !m/\P{IsPrint}/ or die bad_data('nonprinting char(s)'); !m/\\/ or bad_data('data contains backslashes'); @@ -143,13 +144,13 @@ while () { @v==6 or bad_data('wrong number of fields'); my ($commod,$stall) = @v; defined $commods{$commod} or bad_data("unknown commodity \`$commod'"); - $stall =~ m/^\p{IsUpper}/ or bad_data("stall not capitalised"); + $stall =~ m/^\p{IsUpper}|^[0-9]/ or bad_data("stall not capitalised"); !exists $done{$commod,$stall} or bad_data("repeated data"); $done{$commod,$stall}= 1; foreach my $i (2..5) { my $f= $v[$i]; - $f =~ m/^(0|[1-9][0-9]{0,5}|\>1000)$/ or bad_data("bad field"); - ($i % 1) or ($f !~ m/\>/) or bad_data("> in price"); + $f =~ m/^(|0|[1-9][0-9]{0,5}|\>1000)$/ or bad_data("bad field $i"); + ($i % 2) or ($f !~ m/\>/) or bad_data("> in field $i price"); } } GZ->error and die $!; diff --git a/pctb/master-master.txt b/pctb/master-master.txt index 3753a43..eb8d666 100644 --- a/pctb/master-master.txt +++ b/pctb/master-master.txt @@ -164,5 +164,5 @@ ocean Midnight Remora Island Vernal Equinox -client ypp-sc-tools yarr +client ypp-sc-tools yarrg lastpage -- 2.30.2