Commit | Line | Data |
0f093b35 |
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 | } |