yarrg/Commods.pm

   1 # This is part of ypp-sc-tools, a set of third-party tools for assisting
   2 # players of Yohoho Puzzle Pirates.
   3 #
   4 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   5 #
   6 # This program is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18 #
  19 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  20 # are used without permission.  This program is not endorsed or
  21 # sponsored by Three Rings.
  22
  23 package Commods;
  24 use IO::File;
  25 use HTTP::Request::Common ();
  26 use POSIX;
  27
  28 use strict;
  29 use warnings;
  30
  31 BEGIN {
  32     use Exporter ();
  33     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  34     $VERSION     = 1.00;
  35     @ISA         = qw(Exporter);
  36     @EXPORT      = qw(&parse_info_clientside &fetch_with_rsync
  37                       &parse_info_serverside &parse_info_serverside_ocean
  38                       %oceans %commods %clients %routes %route_mysteries
  39                       &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap
  40                       &get_our_version &check_tsv_line
  41                       &pipethrough_prep &pipethrough_run
  42                       &pipethrough_run_along &pipethrough_run_finish
  43                       &pipethrough_run_gzip
  44                       &cgipostform &yarrgpostform &cgi_get_caller
  45                       &set_ctype_utf8);
  46     %EXPORT_TAGS = ( );
  47
  48     @EXPORT_OK   = qw();
  49 }
  50
  51 our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources;
  52 our %commods; # eg $commods{'Fine black cloth'}= $sources;
  53 our %clients; # eg $clients{'ypp-sc-tools'}= [ qw(last-page) ];
  54 our %routes; # eg $routes{'Midnight'}{'Orca'}{'Tinga'}= $sources  NB abbrevs!
  55 our %route_mysteries; # eg $route_mysteries{'Midnight'}{'Norse'}= 3
  56 # $sources = 's[l]b';
  57 #       's' = Special Circumstances; 'l' = local ; B = with Bleach
  58
  59 our (%pctb_commodmap,@pctb_commodmap);
  60
  61 my %colours; # eg $colours{'c'}{'black'}= $sources
  62 my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
  63
  64 sub parse_info1 ($$) {
  65     my ($mmfn,$src)= @_;
  66     my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
  67     my @ctx= ();
  68     while (<$mm>) {
  69         next if m/^\s*\#/;
  70         next unless m/\S/;
  71         s/\s+$//;
  72         if (m/^\%(\w+)$/) {
  73             my $colourkind= $1;
  74             @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
  75         } elsif (m/^commods$/) {
  76             @ctx= (sub { push @rawcm, lc $_; });
  77         } elsif (m/^ocean (\w+)$/) {
  78             my $ocean= $1;
  79             @ctx= (sub {
  80                 $ocean or die; # ref to $ocean needed to work
  81                                # around a perl bug
  82                 my $arch= $_;
  83                 $ctx[1]= sub {
  84                     $oceans{$ocean}{$arch}{$_} .= $src;
  85                 };
  86             });
  87         } elsif (m/^routes (\w+)$/) {
  88             my $ocean= $1;
  89             @ctx= (sub {
  90                 m/^(\S[^\t]*\S),\s*(\S[^\t]*\S),\s*([1-9][0-9]{0,2})$/ or die;
  91                 $routes{$ocean}{$1}{$2}= $3;
  92             });
  93         } elsif (m/^client (\S+.*\S)$/) {
  94             my $client= $1;
  95             $clients{$client}= [ ];
  96             @ctx= (sub {
  97                 my $bug= $_;
  98                 push @{ $clients{$client} }, $bug;
  99             });
 100         } elsif (s/^ +//) {
 101             my $indent= length $&;
 102             die "wrong indent $indent" unless defined $ctx[$indent-1];
 103             &{ $ctx[$indent-1] }();
 104         } else {
 105             die "bad syntax";
 106         }
 107     }
 108     $mm->error and die $!;
 109     close $mm or die $!;
 110
 111 #print Dumper(\%oceans);
 112 #print Dumper(\@rawcm);
 113
 114     %commods= ();
 115     my $ca;
 116     $ca= sub {
 117         my ($s,$ss) = @_;
 118 #print "ca($s)\n";
 119         if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
 120         die "unknown $&" unless defined $colours{$1};
 121         foreach my $c (keys %{ $colours{$1} }) {
 122             &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
 123         }
 124     };
 125     foreach (@rawcm) { &$ca($_,$src); }
 126
 127     foreach my $on (keys %routes) {
 128         my $routes= $routes{$on};
 129         my $ocean= $oceans{$on};
 130         die unless defined $ocean;
 131
 132         my @allislands;
 133         foreach my $an (sort keys %$ocean) {
 134             my $arch= $ocean->{$an};
 135             push @allislands, sort keys %$arch;
 136         }
 137         parse_info_maproutes($on, \@allislands, $routes);
 138         foreach my $route (values %$routes) {
 139             parse_info_maproutes($on, \@allislands, $route);
 140         }
 141     }
 142 }
 143
 144 sub parse_info_clientside () {
 145     my $yarrg= $ENV{'YPPSC_YARRG_DICT_UPDATE'};
 146     return unless $yarrg;
 147     my $master= fetch_with_rsync('info');
 148     parse_info1($master,'s');
 149     my $local= '_local-info.txt';
 150     if (stat $local) {
 151         parse_info1($local,'s');
 152     } else {
 153         die "$local $!" unless $! == &ENOENT;
 154     }
 155 }
 156
 157 sub fetch_with_rsync ($) {
 158     my ($stem) = @_;
 159
 160     my $rsync= $ENV{'YPPSC_YARRG_RSYNC'};
 161     $rsync= 'rsync' if !defined $rsync;
 162
 163     my $local= "_master-$stem.txt";
 164     my $src= $ENV{'YPPSC_YARRG_DICT_UPDATE'};
 165     if ($src) {
 166         my $remote= "$src/master-$stem.txt";
 167         $!=0; system 'rsync','-Lt','--',$remote,$local;
 168         die "$? $!" if $! or $?;
 169     }
 170     return $local;
 171 }
 172
 173 sub parse_info_maproutes ($$$) {
 174     my ($on, $allislands, $routemap) = @_;;
 175     foreach my $k (sort keys %$routemap) {
 176         my @ok= grep { index($_,$k) >= 0 } @$allislands;
 177         die "ambiguous $k" if @ok>1;
 178         if (!@ok) {
 179             $route_mysteries{$on}{$k}++;
 180             delete $routemap->{$k};
 181         } elsif ($ok[0] ne $k) {
 182             $routemap->{$ok[0]}= $routemap->{$k};
 183             delete $routemap->{$k};
 184         }
 185     }
 186 }
 187
 188 sub parse_info_serverside () {
 189     parse_info1('master-info.txt','s');
 190 }
 191 sub parse_info_serverside_ocean ($) {
 192     my ($oceanname) = @_;
 193     die "unknown ocean $oceanname ?" unless exists $oceans{$oceanname};
 194     parse_info1("ocean-".(lc $oceanname).".txt",'s');
 195 }
 196
 197 sub parse_pctb_commodmap () {
 198     undef %pctb_commodmap;
 199     foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; }
 200
 201     my $c= new IO::File '_commodmap.tsv';
 202     if (!$c) { $!==&ENOENT or die $!; return 0; }
 203
 204     while (<$c>) {
 205         m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
 206         die if defined $pctb_commodmap{$1};  $pctb_commodmap{$1}= $2;
 207         die if defined $pctb_commodmap[$2];  $pctb_commodmap[$2]= $1;
 208         $commods{$1} .= 'b';
 209     }
 210     $c->error and die $!;
 211     close $c or die $!;
 212     return 1;
 213 }
 214
 215 sub get_our_version ($$) {
 216     my ($aref,$prefix) = @_;
 217     $aref->{"${prefix}name"}= 'ypp-sc-tools yarrg';
 218     $aref->{"${prefix}fixes"}= 'lastpage';
 219
 220     my $version= `git-describe --tags HEAD || echo 0unknown`; $? and die $?;
 221     chomp($version);
 222     $aref->{"${prefix}version"}= $version;
 223     return $aref;
 224     # clientname        "ypp-sc-tools"
 225     # clientversion     2.1-g2e06a26  [from git-describe --tags HEAD]
 226     # clientfixes       "lastpage"  [space separated list]
 227 }
 228
 229 sub pipethrough_prep () {
 230     my $tf= IO::File::new_tmpfile() or die $!;
 231     return $tf;
 232 }
 233
 234 sub pipethrough_run_along ($$$@) {
 235     my ($tf, $childprep, $cmd, @a) = @_;
 236     $tf->flush or die $!;
 237     $tf->seek(0,0) or die $!;
 238     my $fh= new IO::File;
 239     my $child= $fh->open("-|"); defined $child or die $!;
 240     if (!$child) {
 241         open STDIN, "<&", $tf;
 242         &$childprep() if defined $childprep;
 243         exec $cmd @a; die "@a $!";
 244     }
 245     return $fh;
 246 }
 247 sub pipethrough_run_finish ($$) {
 248     my ($fh, $what)= @_;
 249     $fh->error and die $!;
 250     close $fh or die "$what $! $?";  die $? if $?;
 251 }
 252
 253 sub pipethrough_run ($$$@) {
 254     my ($tf, $childprep, $cmd, @a) = @_;
 255     my $pt= pipethrough_run_along($tf,$childprep,$cmd,@a);
 256     my $r;
 257     { undef $/; $!=0; $r= <$pt>; }
 258     defined $r or die $!;
 259     pipethrough_run_finish($pt, "@a");
 260     return $r;
 261 }
 262 sub pipethrough_run_gzip ($) {
 263     pipethrough_run($_[0],undef,'gzip','gzip');
 264 }
 265
 266 sub yarrgpostform ($$) {
 267     my ($ua, $form) = @_;
 268     my $dest= $ENV{'YPPSC_YARRG_YARRG'};
 269     get_our_version($form, 'client');
 270     die unless $dest =~ m,/$,;
 271     return cgipostform($ua, "${dest}commod-update-receiver", $form);
 272 }
 273
 274 sub cgipostform ($$$) {
 275     my ($ua, $url, $form) = @_;
 276     my $req= HTTP::Request::Common::POST($url,
 277                                          Content => $form,
 278                                          Content_Type => 'form-data');
 279     if ($url =~ m,^\.?/,) {
 280         my $tf= pipethrough_prep();
 281         print $tf $req->content() or die $!;
 282 #print STDERR "[[[",$req->content(),"]]]";
 283         my $out= pipethrough_run($tf, sub {
 284             $ENV{'REQUEST_METHOD'}= 'POST';
 285             $ENV{'QUERY_STRING'}= '';
 286             $ENV{'PATH_TRANSLATED'}= $url;
 287             $ENV{'PATH_INFO'}= '';
 288             $ENV{'HTTP_HOST'}= 'localhost';
 289             $ENV{'REMOTE_ADDR'}= '127.0.0.1';
 290             $ENV{'GATEWAY_INTERFACE'}= 'CGI/1.1';
 291             $ENV{'DOCUMENT_ROOT'}= '.';
 292             $ENV{'SCRIPT_FILENAME'}= $url;
 293             $ENV{'SCRIPT_NAME'}= $url;
 294             $ENV{'HTTP_USER_AGENT'}= 'Commods.pm local test';
 295
 296             foreach my $f (qw(Content_Length Content_Type)) {
 297                 $ENV{uc $f}= $req->header($f);
 298             }
 299 #system 'printenv >&2';
 300         }, "$url", "$url");
 301         $out =~ s/\r\n/\n/g;
 302         $out =~ m,^Content-Type: text/plain.*\n\n, or die "$out ?";
 303         return $';
 304     } else {
 305         my $resp= $ua->request($req);
 306         die $resp->status_line."\n".$resp->content."\n "
 307             unless $resp->is_success;
 308         return $resp->content();
 309     }
 310 }
 311
 312 our %check_tsv_done;
 313
 314 sub check_tsv_line ($$) {
 315     my ($l, $bad_data_callback) = @_;
 316     my $bad_data= sub { &$bad_data_callback("bad data: line $.: $_[0]"); };
 317
 318     chomp($l) or &$bad_data('missing end-of-line');
 319
 320     $l !~ m/\P{IsPrint}/ or &$bad_data('nonprinting char(s)');
 321     my @v= split /\t/, $l, -1;
 322     @v==6 or &$bad_data('wrong number of fields');
 323     my ($commod,$stall) = @v;
 324
 325     !keys %commods or
 326         defined $commods{$commod} or
 327         &$bad_data("unknown commodity \`$commod'");
 328
 329     $stall =~ m/^\p{IsUpper}|^[0-9]/ or &$bad_data("stall not capitalised");
 330     !exists $check_tsv_done{$commod,$stall} or &$bad_data("repeated data");
 331     $check_tsv_done{$commod,$stall}= 1;
 332     foreach my $i (2..5) {
 333         my $f= $v[$i];
 334         $f =~ m/^(|0|[1-9][0-9]{0,5}|\>1000)$/ or &$bad_data("bad field $i");
 335         ($i % 2) or ($f !~ m/\>/) or &$bad_data("> in field $i price");
 336     }
 337
 338     foreach my $i (2,4) {
 339         &$bad_data("price with no qty or vice versa (field $i)")
 340             if length($v[$i]) xor length($v[$i+1]);
 341     }
 342     length($v[2]) or length($v[4]) or
 343         &$bad_data("commodity entry with no buy or sell offer");
 344
 345     return @v;
 346 }
 347
 348 sub cgi_get_caller () {
 349     my $caller= $ENV{'REMOTE_ADDR'};
 350     $caller= 'LOCAL' unless defined $caller;
 351
 352     my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'};
 353     if (defined $fwdf) {
 354         $fwdf =~ s/\s//g;
 355         $fwdf =~ s/[^0-9.,]/?/g;
 356         $caller= "$fwdf";
 357     }
 358     return $caller;
 359 }
 360
 361 sub set_ctype_utf8 () {
 362     setlocale(LC_CTYPE, "en.UTF-8");
 363 }
 364
 365 1;