X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=pctb%2Fdictionary-update-receiver;h=cd1638e22a476e905d2ebecd7975169181fb1358;hp=3e04f6c3015d5ebf65a5672d6d2e0acd24021e77;hb=3063e05a93fb97a5eca7f26c38da94fa4000406e;hpb=0c7799d7cea28bfc9d24ea4a152b5fa602118284 diff --git a/pctb/dictionary-update-receiver b/pctb/dictionary-update-receiver index 3e04f6c..cd1638e 100755 --- a/pctb/dictionary-update-receiver +++ b/pctb/dictionary-update-receiver @@ -1,25 +1,18 @@ #!/usr/bin/perl -w # -# This script is invoked when the YPP SC PCTB client phones home to -# provide updated character set OCR data or updated screenshot pixmap -# interpretation (island name) data. -# -# The client will also phone home anyway to fetch the latest parsedb -# before -# -# This allows me (the operator of the SC server) to: -# - review the choices made by the user -# - if they are correct, incorporate them in the next client version -# - if they are wrong, incorporate fixes of them, or contradictions of them, -# in +# This script is invoked when the YPP SC PCTB client talks to the +# dictionary server. See README.privacy. -# The information reported -# The SC PCTB client does this so that + +# upload testing runes: +# +# YPPSC_PCTB_DICT_UPDATE=./ YPPSC_PCTB_DICT_SUBMIT=./ ./ypp-commodities --ocean midnight --pirate aristarchus --find-island --same --raw-tsv >raw.tsv +# ./dictionary-manager --debug --approve-updates '' . . use strict (qw(vars)); use POSIX; -$CGI::POST_MAX= 65536; +$CGI::POST_MAX= 1024*1024; $CGI::DISABLE_UPLOADS= 1; use CGI qw/:standard -private_tempfiles/; @@ -31,7 +24,7 @@ use IO::Handle; sub parseentryin__pixmap ($) { my ($entry_in) = @_; $entry_in =~ - m/^(\w+ \- \w[-+\'\"\#! 0-9a-z]*)\nP3\n([1-9]\d{1,3}) ([1-9]\d{1,3})\n255\n/s or die; + m/^(\S+ \- .*)\nP3\n([1-9]\d{1,3}) ([1-9]\d{1,3})\n255\n/s or die; my ($def,$w,$h)= ($1, $2+0, $3+0); my @d= grep { m/./ } split /\s+/, $'; @d == $w*$h*3 or die "$d[0]|$d[1]|...|$d[$#d-1]|$d[$#d] ?"; @@ -51,14 +44,31 @@ sub parseentryin__pixmap ($) { $ppm .= "\n"; } - return ('',$def,$ppm,$ppm,$def); + my $icon= pipeval($ppm, + 'ppmtopgm', + 'pnmscale -xysize 156 80', + 'pnmnorm -bpercent 40 -wpercent 20', + 'pgmtopbm -threshold', + 'pnminvert', + 'pbmtoascii -2x4'); + + my $whole= pipeval($ppm, + 'ppmtopgm', + 'pnmnorm -bpercent 40 -wpercent 20', + 'pgmtopbm -threshold', + 'pnminvert', + 'pbmtoascii'); + + my $entry= "$def\n$ppm"; + + return ('',$def,$ppm,$ppm,$def, $w,$icon,$whole,$entry); } #---------- characters ---------- sub parseentryin__char ($$) { my ($ei,$h) = @_; - $ei =~ m/^(Digit|Upper|Lower)\n((?:[-&\'A-F0-9a-f ]|\x20)+)\n/s or die; + $ei =~ m/^(Digit|Upper|Lower)\n([^\n]+)\n/s or die; my ($ctx,$str)= ($1,$2); #print STDERR ">$'<\n"; my @d= grep { m/./ } split /\n/, $'; @@ -73,40 +83,97 @@ sub parseentryin__char ($$) { } @d; my $w= @d; my $ppm= "P2\n$w $h\n1\n"; + my $whole=''; for (my $y=0; $y<$h; $y++) { for (my $x=0; $x<$w; $x++) { - $ppm .= sprintf " %d", !($d[$x] & (1<<$y)); + my $pix= !($d[$x] & (1<<$y)); + $ppm .= sprintf " %d", $pix; + $whole .= $pix ? ' ' : '<>'; } $ppm .= "\n"; + $whole .= "\n"; } - my $key= join ' ', $ctx, map { sprintf "%x", $_; } @d; + map { $_= sprintf "%x", $_; } @d; + my $key= join ' ', $ctx, @d; + +# my $whole= pipeval($ppm, +# "pnmscale 2", +# 'pgmtopbm -threshold', +# 'pbmtoascii'); + + my $entry= "$ctx\n$str\n". join("\n", @d). "\n"; - return ($ctx,$str,$ppm,$key,$str); + return ($ctx,$str,$ppm,$key,$str, $w*2,'',$whole,$entry); } -#---------- main program ---------- +#---------- useful stuff ---------- + +sub pipeval ($@) { + my ($val, @cmds) = @_; + my (@pids); + + my $lastpipe; + + foreach my $cmd ('',@cmds) { + my $pipe= new IO::Pipe or die $!; + my $pid= fork(); defined $pid or die $!; + + if (!$pid) { + $pipe->writer(); + if (!$lastpipe) { + print $pipe $val or die $!; + exit 0; + } else { + open STDIN, '<&', $lastpipe or die $!; + open STDOUT, '>&', $pipe or die $!; + close $lastpipe or die $!; + close $pipe or die $!; + exec $cmd; die $!; + } + } + $pipe->reader(); + if ($lastpipe) { close $lastpipe or die $!; } + $lastpipe= $pipe; + push @pids, $pid; + } + + $!=0; { local ($/)=undef; $val= <$lastpipe>; } + defined $val or die $!; + $lastpipe->error and die $!; close $lastpipe or die $!; + + foreach my $cmd ('(paste)', @cmds) { + my $pid= shift @pids; + waitpid($pid,0) == $pid or die "$pid $? $!"; + $?==0 or $?==13 or die "$cmd $?"; + } + return $val; +} + +#========== main program ========== + +#---------- determine properties of the submission ---------- my $dict= param('dict'); my $entry_in= param('entry'); -defined $entry_in or die; +defined $entry_in or die Dump()." ?"; my $ocean= param('ocean'); my $pirate= param('pirate'); if (defined $ocean && defined $pirate) { $pirate= "$ocean - $pirate"; } else { - $pirate= $ENV{'REMOTE_ADDR'}; - my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'}; - if (defined $fwdf) { - $fwdf =~ s/\s//g; - $fwdf =~ s/[^0-9.,]/?/g; - $pirate= "$fwdf,$pirate"; - } + $pirate= ''; } -my $du=$ENV{'YPPSC_DICTUPDATES'}; -chdir $du or die "$du $!" - if defined $du; +my $caller= $ENV{'REMOTE_ADDR'}; +$caller= 'LOCAL' unless defined $caller; + +my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'}; +if (defined $fwdf) { + $fwdf =~ s/\s//g; + $fwdf =~ s/[^0-9.,]/?/g; + $caller= "$fwdf,$pirate"; +} my $kind; my @xa; @@ -120,7 +187,59 @@ if ($dict =~ m/^pixmap$/) { } $dict= $&; -my ($ctx,$def,$image,$key,$val)= &{"parseentryin__$kind"}($entry_in, @xa); +my ($ctx,$def,$image,$key,$val, $width,$icon,$whole,$entry)= + &{"parseentryin__$kind"}($entry_in, @xa); + +#---------- compute the email to send ---------- + +my $whoami= `whoami`; $? and die $?; +chomp $whoami; + +my $email= < $fn_t" or die "$fn_t $!"; @@ -129,7 +248,7 @@ my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1]; print F "ypp-sc-tools dictionary update v1\n"; -foreach my $v ($pirate,$dict,$ctx,$def,$image,$key,$val) { +foreach my $v ($pirate,$caller,$dict,$ctx,$def,$image,$key,$val) { printf F "%d\n", length($v) or die $!; print F $v,"\n" or die $!; } @@ -140,8 +259,28 @@ my @tm= localtime; my $tm= strftime "%Y-%m-%d %H:%M:%S %Z", @tm; open L, ">> _dict.log" or die $!; -my $ll= sprintf "%s %-6s %-31s %s %s\n", $tm, $dict, $pirate, $fn_i, "submit"; -print L $ll or die $!; +my $ll= sprintf "%s %-6s %-31s %-31s %s", $tm, $dict, $pirate, $caller, $fn_i; + +#---------- commit everything ---------- + +print L "$ll submit\n" or die $!; +L->flush or die $!; + +if (eval { + + open S, "|/usr/lib/sendmail -odb -oee -oi -t" or die $!; + print S $email or die $!; + $!=0; $?=0; close S or die $!; $? and die $?; + + rename $fn_t, $fn_i or die "$fn_t $fn_i $!"; + + 1; +}) { + print L "$ll stored\n" or die $!; +} else { + print L "$ll ERROR! $@\n" or die $!; + exit 1; +} close L or die $!; -rename $fn_t, $fn_i or die "$fn_t $fn_i $!"; +print header('text/plain'), "OK $fn_i\n" or die $!;