chiark / gitweb /
wip upload testing
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 21 Jun 2009 20:22:59 +0000 (21:22 +0100)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 21 Jun 2009 20:22:59 +0000 (21:22 +0100)
pctb/convert.c
pctb/convert.h
pctb/dictionary-manager
pctb/dictionary-update-receiver
pctb/resolve.c

index 70b4769..fa9837f 100644 (file)
@@ -57,12 +57,12 @@ static const char *o_outmode_str= 0;
 
 static enum mode o_mode= mode_all;
 static char *o_screenshot_fn;
-static int o_quiet;
 static const char *o_serv_pctb, *o_serv_dict_fetch, *o_serv_dict_submit;
 
 const char *o_resolver= "./dictionary-manager";
 FILE *screenshot_file;
 const char *o_ocean, *o_pirate;
+int o_quiet;
 
 enum flags o_flags= ff_dict_fetch|ff_dict_submit|ff_dict_pirate;
 
index 0231ca9..827c6a7 100644 (file)
@@ -102,6 +102,7 @@ enum flags {
 extern enum flags o_flags;
 
 extern const char *o_ocean, *o_pirate;
+extern int o_quiet;
 
 /*----- from pages.c -----*/
 
index c2ea2b5..b6f87a6 100755 (executable)
@@ -71,6 +71,12 @@ proc puts_counted {f dvar} {
     debug "PUTS_COUNTED $count $dvar"
 }
 
+proc bgerror {m} {
+    global errorCode errorInfo
+    puts stderr "ERROR: $m\n[list $errorCode]\n$errorInfo\n";
+    exit 16
+}
+
 #---------- display core ----------
 
 set mul 6
@@ -89,7 +95,7 @@ proc init_widgets {} {
     frame .privacy -bd 2 -relief groove
     pack .privacy -side top -padx 2 -pady 2 -fill x
 
-    upload_init_widgets
+    upload_init
     
     frame .d -bd 2 -relief groove -pady 2 -padx 2
 
@@ -159,12 +165,14 @@ proc helptext {t} {
 
 proc bind_key {k proc} {
     global keybindings
-    bind . <Key-$k> $proc
+    bind .d <Key-$k> $proc
     set keybindings($k) [expr {!![string length $proc]}]
+    .d configure -takefocus 1
 }
 proc unbind_all_keys {} {
     global keybindings
     foreach k [array names keybindings] { bind_key $k {} }
+    .d configure -takefocus 0
 }
 
 #---------- database read and write common wrapper ----------
@@ -218,6 +226,19 @@ proc write_database {} {
     file rename -force $database_fn.new $database_fn
 }
 
+proc select_database {dbname_spec} {
+    global dbname
+    set dbname $dbname_spec
+    read_database "./#local-$dbname#.txt"
+}
+
+proc do_database_update {im def} {
+    global database
+    maybe_upload_entry $im $def
+    set database($im) $def
+    write_database
+}
+    
 proc required/char {} {
     global mulrows glyphsdone unk_l unk_r unk_contexts rows
     
@@ -242,8 +263,9 @@ proc required/char {} {
     pack forget .d.pe
     pack .d.csr -side top -before .d.mi
     pack .d.got .d.ctx -side top -after .d.mi
+    focus .d
 
-    read_database "./#local-char$rows#.txt"
+    select_database char$rows
     draw_glyphsdone
     startup_cursor
 }
@@ -326,8 +348,8 @@ proc pixmap_ok {} {
        rowname rowdesc
     set result "$colname - $rowname"
     debug "UPDATE PIXMAP AS >$result<"
-    set database($ppm) $result
-    write_database
+
+    do_database_update $ppm $result
     done/$mainkind
 }
 
@@ -346,7 +368,7 @@ proc required/pixmap {} {
 
     set alloptions [exec ./dictionary-pixmap-options $unk_what]
 
-    read_database "./#local-pixmap#.txt"
+    select_database pixmap
 
     set mulcols [image width image/main]
     set mulrows [image height image/main]
@@ -356,6 +378,7 @@ proc required/pixmap {} {
 
     pack forget .d.csr .d.got
     pack .d.pe -side top -before .d.mi -pady 2
+    .d configure -takefocus 0
     #-pady 2 -fill x
 
     eval destroy [winfo children .d.pe.grid]
@@ -381,7 +404,7 @@ proc required/pixmap {} {
 
 #========== UPLOADS TO DICTIONARY SERVER ==========
 
-proc upload_init_widgets {} {
+proc upload_init {} {
     global privacy_setting
 
     set privacy_setting [upload_status]
@@ -414,6 +437,10 @@ proc upload_init_widgets {} {
            $w configure -state disabled
        }
     }
+    if {$privacy_setting} {
+       package require http
+       ::http::config -urlencoding utf-8
+    }
 }
 
 proc upload_status {} {
@@ -424,11 +451,85 @@ proc upload_status {} {
     if {![string compare 0 $env(YPPSC_PCTB_DICT_SUBMIT)]} { debug b; return 0 }
 
     if {![info exists env(YPPSC_PIRATE)]} { return 1 }
+    if {![info exists env(YPPSC_OCEAN)]} { return 1 }
     if {![string length $env(YPPSC_PIRATE)]} { return 1 }
+    if {![string length $env(YPPSC_OCEAN)]} { return 1 }
 
     return 2
 }
 
+proc maybe_upload_entry {im def} {
+    global reqkind privacy_setting env dbname quiet
+
+    debug "DB-UPDATE PRIVACY $privacy_setting"
+    if {!$privacy_setting} return
+
+    debug "DB-UPDATE UPLOADING"
+
+    set pl {}
+    lappend pl dict $dbname
+
+    if {$privacy_setting>=2} {
+       set pirate [string totitle $env(YPPSC_PIRATE)]
+       set ocean [string totitle $env(YPPSC_OCEAN)]
+       debug "DB-UPDATE NON-ANON $ocean $pirate"
+       lappend pl \
+           pirate $pirate \
+           ocean $ocean
+    }
+    lappend pl entry [format_database_entry/$reqkind $im $def]
+
+    set url $env(YPPSC_PCTB_DICT_SUBMIT)
+    append url dictionary-update-receiver
+
+    set query [eval ::http::formatQuery $pl]
+    regsub -all {%0d} $query {} query
+    debug "DB-UPDATE QUERY [string range $query 0 200]..."
+
+    if {[regexp {^\.?/} $url]} {
+       set cmd [list $url $query]
+       debug "SUBMIT CMD [string range $cmd 0 200]..."
+       set body [eval exec $cmd 2>@ stderr]
+       regsub {^Content-Type: text/plain.*\n\n} $body {} body
+    } else {
+
+       if {[catch {
+           set req [::http::geturl $url -query $query]
+       } emsg]} {
+           puts stderr \
+               "\nWARNING: Cannot do dictionary upload: $emsg\n"
+           return
+       }
+       upvar #0 $req s
+       debug "DB-UPDATE DONE $req $s(status) [array names s]"
+       set ncode [::http::ncode $req]
+
+       if {!(![string compare ok $s(status)] &&
+             ![string compare 200 $ncode])} {
+           set m "\nWARNING: Dictionary upload failed:"
+           foreach v {status http error posterror} {
+               if {[info exists s($v)]} { append m "\n $v: $s($v)" }
+           }
+           puts stderr $m
+           return
+       }
+       set body $s(body)
+       ::http::cleanup $req
+    }
+
+    if {![string match {OK *} $body]} {
+       set m "\nWARNING: Dictionary upload went wrong:\n"
+       append m "\n  " [join [split $body "\n"] "\n  "]
+       puts stderr $m
+       return
+    }
+
+    if {!$quiet} {
+       puts stderr \
+           "Uploaded $dbname dictionary entry `$def': $body"
+    }
+}
+
 #========== CHARACTER SET ==========
 
 #---------- xpm input processor ----------
@@ -622,16 +723,17 @@ proc recursor/text {} {
     .d.csr.csr.l configure -text {define:}
     pack .d.csr.csr.e -side left
     focus .d.csr.csr.e
-    bind_key Return {
+    bind .d.csr.csr.e <Key-Return> {
        set strq [.d.csr.csr.e get]
        if {[regexp -line {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
            RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
        }
     }
-    bind_key Escape {
+    bind .d.csr.csr.e <Key-Escape> {
        bind_key Escape {}
        pack forget .d.csr.csr.e
        set cur_mode 1
+       focus .d
        recursor
     }
 }
@@ -751,9 +853,8 @@ proc update_database/DEFINE {c0 c1 strq} {
     incr c1 -1
     foreach c $ncontexts {
        set bm [dbkey $c $c0 $c1]
-       set database($bm) $strq
+       do_database_update $bm $strq
     }
-    write_database
 }
 
 proc update_database/DELETE {l r ctxs} {
@@ -779,11 +880,11 @@ proc RETURN_RESULT {how what} {
 
 #========== server for approving updates ==========
 
-proc remote-serv-log {dict pirate file event} {
+proc remote-serv-log {dict pirate caller file event} {
     global remoteserv_logf
     set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}]
-    set s [format "%s %-6s %-31s %s %s\n" \
-              $t $dict $pirate [file tail $file] $event]
+    set s [format "%s %-6s %-31s %-31s %s %s\n" \
+              $t $dict $pirate $caller [file tail $file] $event]
     puts -nonewline $remoteserv_logf $s
 }
 
@@ -805,6 +906,7 @@ proc remote-serv/take {yesno file dict} {
     set rows ""
     debug "TAKE [list $yesno $file $dict]"
     read_counted stdin pirate
+    read_counted stdin caller
     read_counted stdin key
     read_counted stdin val
 
@@ -827,7 +929,7 @@ proc remote-serv/take {yesno file dict} {
     } else {
        set desc reject
     }
-    remote-serv-log $dict $pirate $file "$desc $reqkind $rows"
+    remote-serv-log $dict $pirate $caller $file "$desc $reqkind $rows"
     file delete -force $file
 
     puts done
@@ -895,6 +997,7 @@ proc approve_decompose_data {specdata} {
     
     regsub-data {^ypp-sc-tools dictionary update v1\n} {}
     uplevel 1 chop_counted pirate
+    uplevel 1 chop_counted caller
     uplevel 1 chop_counted dict
     uplevel 1 chop_counted ctx
     uplevel 1 chop_counted def
@@ -952,6 +1055,7 @@ proc approve_approve_reject_one {ix yesno} {
     approve_decompose_data $tdata
     puts_server "take $yesno $file $dict"
     puts_counted $server pirate
+    puts_counted $server caller
     puts_counted $server key
     puts_counted $server val
     puts_server confirmed
@@ -1103,9 +1207,11 @@ proc debug {m} { }
 set mainkind default
 set ai 0
 set debug 0
+set quiet 0
 foreach arg $argv {
     incr ai
     switch -exact -- $arg {
+       {--quiet}           { set quiet 1 }
        {--debug}           { set debug 1 }
        {--debug-server}    { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }}
        {--noop-arg}        { }
index 8f53438..0ce8593 100755 (executable)
@@ -3,6 +3,12 @@
 # This script is invoked when the YPP SC PCTB client talks to the
 # dictionary server.  See README.privacy.
 
+
+# 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;
 
@@ -18,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] ?";
@@ -62,7 +68,7 @@ sub parseentryin__pixmap ($) {
 
 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/, $';
@@ -156,13 +162,17 @@ 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 $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;
@@ -190,6 +200,7 @@ To: $whoami
 Subject: pctb $dict $ctx $def [ypp-sc-tools]
 
 Pirate:     $pirate
+Caller:     $caller
 Dictionary: $dict
 Context:    $ctx
 Definition: $def
@@ -237,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 $!;
 }
@@ -248,7 +259,7 @@ 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", $tm, $dict, $pirate, $fn_i;
+my $ll= sprintf "%s %-6s %-31s %-31s %s", $tm, $dict, $pirate, $caller, $fn_i;
 
 #---------- commit everything ----------
 
@@ -271,4 +282,4 @@ if (eval {
 }
 close L or die $!;
 
-print header('text/plain'), "$fn_i\n" or die $!;
+print header('text/plain'), "OK $fn_i\n" or die $!;
index 556c54b..0bd0579 100644 (file)
@@ -25,6 +25,7 @@
  *  sponsored by Three Rings.
  */
 
+#include "convert.h"
 #include "ocr.h"
 
 static FILE *resolver;
@@ -50,6 +51,7 @@ FILE *resolve_start(void) {
       sysassert( dup2(donepipe[1],4) ==4 );
       EXECLP_HELPER("dictionary-manager",
                    DEBUGP(callout) ? "--debug" : "--noop-arg",
+                   o_quiet ? "--quiet" : "--noop-arg",
                    "--automatic-1",
                    (char*)0);
       sysassert(!"execlp dictionary-manager --automatic failed");
@@ -59,6 +61,8 @@ FILE *resolve_start(void) {
     resolver= fdopen(jobpipe[1],"w"); sysassert(resolver);
     resolver_done= donepipe[0];
   }
+
+  progress("");
   return resolver;
 }