analysis/idp_server/graphcalc.cgi

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