chiark / gitweb /
WIP commod-update-receiver testing
authorIan Jackson <ian@liberator.(none)>
Fri, 24 Jul 2009 19:15:46 +0000 (20:15 +0100)
committerIan Jackson <ian@liberator.(none)>
Fri, 24 Jul 2009 19:15:46 +0000 (20:15 +0100)
pctb/Commods.pm
pctb/commod-results-processor
pctb/commod-update-receiver
pctb/master-master.txt

index e695f15..073906f 100644 (file)
@@ -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= <GZ>; }
+    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();
     }
 }
 
index cba01d9..0286ab3 100755 (executable)
@@ -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= <GZ>; }
-    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 () {
index b7bf4cb..ac52fec 100755 (executable)
 
 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 (<GZ>) {
     !m/\P{IsPrint}/ or die bad_data('nonprinting char(s)');
     !m/\\/ or bad_data('data contains backslashes');
@@ -143,13 +144,13 @@ while (<GZ>) {
     @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 $!;
index 3753a43..eb8d666 100644 (file)
@@ -164,5 +164,5 @@ ocean Midnight
   Remora Island
   Vernal Equinox
 
-client ypp-sc-tools yarr
+client ypp-sc-tools yarrg
  lastpage