base/idp_server/graphcalc.cgi

   1 #!/usr/bin/perl -T
   2
   3 use strict;
   4 use warnings;
   5 use lib '/home/tla/stemmatology/lib';
   6 use CGI;
   7 use Encode qw/ decode /;
   8 use Gearman::Client;
   9 use JSON;
  10 use Text::Tradition::Directory;
  11 use Text::Tradition::Analysis::Result;
  12 use TryCatch;
  13
  14 my %status = (
  15     '400' => '400 Bad Request',
  16     '500' => '500 Internal Server Error',
  17 );
  18
  19 my $q = CGI->new(\*STDIN);
  20 # check that Content-Type is application/json
  21 my $ctype = $q->content_type;
  22 my $encoding = 'UTF-8'; # default
  23 if( $ctype =~ m!^(\w+/[\w+]+);\s*charset=(.*)$! ) {
  24     ( $ctype, $encoding ) = ( $1, $2 );
  25 }
  26 error( 400, 'Content type must be application/json' )
  27         unless $ctype eq 'application/json';
  28
  29 # Get the post data, and decode it according to the given character set
  30 my $jsonstr = decode( $encoding, $q->param('POSTDATA') );
  31 $jsonstr =~ s/\&/\n/g;
  32 # TODO eval this; if it breaks return an error.
  33 my $request;
  34 try {
  35     $request = from_json( $jsonstr );
  36 } catch( $err ) {
  37     error( 400, "JSON parsing error: $err" );
  38 }
  39 # Request should be a hash that can be used to instantiate an Analysis::Result,
  40 # or else an array of such hashes.
  41 my @problems;
  42 my $first = ref( $request ) eq 'ARRAY' ? shift @$request : $request;
  43 try {
  44         my $result = Text::Tradition::Analysis::Result->new( $first );
  45         push( @problems, $result );
  46 } catch( $err ) {
  47         error( 400, "Argument $first is neither a Result serialization nor an array: $err" );
  48 }
  49 # Now parse the rest of the result objects
  50 unless( $first eq $request ) {
  51         foreach my $rj ( @$request ) {
  52                 try {
  53                         my $result = Text::Tradition::Analysis::Result->new( $rj );
  54                         push( @problems, $result );
  55                 } catch( $err ) {
  56                         error( 400, "Argument $rj is not a Result serialization: $err" );
  57                 }
  58         }
  59 }
  60
  61 # For each of the result objects, see if its key exists in the DB. Kick off the
  62 # calculation of any that need to be calculated, but don't wait more than two
  63 # seconds for a result. Return the DB version of each of the objects.
  64 my $dir = Text::Tradition::Directory->new(
  65     'dsn' => 'dbi:mysql:dbname=idpresult',
  66     'extra_args' => { 'user' => 'stemmaweb', 'password' => 'l@chmann' } );
  67 my $scope = $dir->new_scope;
  68 my %results;
  69 my @resultorder;  # Keep track of the order in which we should return the results
  70 my @needcalc;
  71 foreach my $p ( @problems ) {
  72         my $key = $p->object_key;
  73         push( @resultorder, $key );
  74         my $result = $dir->lookup( $key );
  75         if( $result ) {
  76                 $results{$key} = $result;
  77         } else {
  78                 push( @needcalc, $p );
  79                 $dir->store( $key => $p );
  80         }
  81 }
  82
  83 # Now if any of the results need calculation, dispatch them for the purpose.
  84 if( @needcalc ) {
  85         my $arg = join( ',', map { $_->object_key } @needcalc );
  86         my $client = Gearman::Client->new;
  87         $client->job_servers( '127.0.0.1' );
  88         my $task = $client->dispatch_background( run_idp => $arg );
  89         # See if it finishes quickly
  90         my $wait = 3;
  91     sleep( $wait );
  92         # Now replace the problems in the results hash with the DB results,
  93         # whether finished or still calculating.
  94         foreach my $p ( @needcalc ) {
  95                 # this should NOT fail as we stored it above
  96                 $results{$p->object_key} = $dir->lookup( $p->object_key );
  97         }
  98 }
  99
 100 # Finally, assemble our answer.
 101 my $answer;
 102 if( $first eq $request ) {
 103         $answer = $results{$resultorder[0]};
 104 } else {
 105         foreach my $key ( @resultorder ) {
 106                 push( @$answer, $results{$key} );
 107         }
 108 }
 109
 110
 111 # Now return the response as UTF-8 encoded JSON.
 112 print $q->header(-type => 'application/json', -charset => 'UTF-8' );
 113 print JSON->new->allow_blessed->convert_blessed->utf8->encode( $answer );
 114 exit 0;
 115
 116 sub error {
 117         my( $code, $msg ) = @_;
 118         print $q->header( -type => 'text/plain', -charset => 'UTF-8', -status => $status{$code} );
 119         print "$msg\n";
 120         exit 0;
 121 }