Isolate Stemweb calls into own controller; guard against server being down. #29
[scpubgit/stemmaweb.git] / lib / stemmaweb / Controller / Root.pm
1 package stemmaweb::Controller::Root;
2 use Moose;
3 use namespace::autoclean;
4 use JSON qw ();
5 use TryCatch;
6 use XML::LibXML;
7 use XML::LibXML::XPathContext;
8
9
10 BEGIN { extends 'Catalyst::Controller' }
11
12 #
13 # Sets the actions in this controller to be registered with no prefix
14 # so they function identically to actions created in MyApp.pm
15 #
16 __PACKAGE__->config(namespace => '');
17
18 =head1 NAME
19
20 stemmaweb::Controller::Root - Root Controller for stemmaweb
21
22 =head1 DESCRIPTION
23
24 Serves up the main container pages.
25
26 =head1 URLs
27
28 =head2 index
29
30 The root page (/).  Serves the main container page, from which the various
31 components will be loaded.
32
33 =cut
34
35 sub index :Path :Args(0) {
36     my ( $self, $c ) = @_;
37
38         # Are we being asked to load a text immediately? If so 
39         if( $c->req->param('withtradition') ) {
40                 $c->stash->{'withtradition'} = $c->req->param('withtradition');
41         }
42     $c->stash->{template} = 'index.tt';
43 }
44
45 =head2 about
46
47 A general overview/documentation page for the site.
48
49 =cut
50
51 sub about :Local :Args(0) {
52         my( $self, $c ) = @_;
53         $c->stash->{template} = 'about.tt';
54 }
55
56 =head2 help/*
57
58 A dispatcher for documentation of various aspects of the application.
59
60 =cut
61
62 sub help :Local :Args(1) {
63         my( $self, $c, $topic ) = @_;
64         $c->stash->{template} = "$topic.tt";
65 }
66
67 =head1 Elements of index page
68
69 =head2 directory
70
71  GET /directory
72
73 Serves a snippet of HTML that lists the available texts.  This returns texts belonging to the logged-in user if any, otherwise it returns all public texts.
74
75 =cut
76
77 sub directory :Local :Args(0) {
78         my( $self, $c ) = @_;
79     my $m = $c->model('Directory');
80     # Is someone logged in?
81     my %usertexts;
82     if( $c->user_exists ) {
83         my $user = $c->user->get_object;
84         my @list = $m->traditionlist( $user );
85         map { $usertexts{$_->{id}} = 1 } @list;
86                 $c->stash->{usertexts} = \@list;
87                 $c->stash->{is_admin} = 1 if $user->is_admin;
88         }
89         # List public (i.e. readonly) texts separately from any user (i.e.
90         # full access) texts that exist. Admin users therefore have nothing
91         # in this list.
92         my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
93         $c->stash->{publictexts} = \@plist;
94         $c->stash->{template} = 'directory.tt';
95 }
96
97 =head1 AJAX methods for traditions and their properties
98
99 =head2 newtradition
100
101  POST /newtradition,
102         { name: <name>,
103           language: <language>,
104           public: <is_public>,
105           file: <fileupload> }
106  
107 Creates a new tradition belonging to the logged-in user, with the given name
108 and the collation given in the uploaded file. The file type is indicated via
109 the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and 
110 name of the new tradition.
111  
112 =cut
113
114 sub newtradition :Local :Args(0) {
115         my( $self, $c ) = @_;
116         return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
117                 unless $c->user_exists;
118
119         my $user = $c->user->get_object;
120         # Grab the file upload, check its name/extension, and call the
121         # appropriate parser(s).
122         my $upload = $c->request->upload('file');
123         my $name = $c->request->param('name') || 'Uploaded tradition';
124         my $lang = $c->request->param( 'language' ) || 'Default';
125         my $public = $c->request->param( 'public' ) ? 1 : undef;
126         my( $ext ) = $upload->filename =~ /\.(\w+)$/;
127         my %newopts = (
128                 'name' => $name,
129                 'language' => $lang,
130                 'public' => $public,
131                 'file' => $upload->tempname
132                 );
133
134         my $tradition;
135         my $errmsg;
136         if( $ext eq 'xml' ) {
137                 my $type;
138                 # Parse the XML to see which flavor it is.
139                 my $parser = XML::LibXML->new();
140                 my $doc;
141                 try {
142                         $doc = $parser->parse_file( $newopts{'file'} );
143                 } catch( $err ) {
144                         $errmsg = "XML file parsing error: $err";
145                 }
146                 if( $doc ) {
147                         if( $doc->documentElement->nodeName eq 'GraphML' ) {
148                                 $type = 'CollateX';
149                         } elsif( $doc->documentElement->nodeName ne 'TEI' ) {
150                                 $errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
151                         } else {
152                                 my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
153                                 my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' );
154                                 if( $venc && $venc eq 'double-end-point' ) {
155                                         $type = 'CTE';
156                                 } else {
157                                         $type = 'TEI';
158                                 }
159                         }
160                 }
161                 # Try the relevant XML parsing option.
162                 if( $type ) {
163                         delete $newopts{'file'};
164                         $newopts{'xmlobj'} = $doc;
165                         try {
166                                 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
167                         } catch ( Text::Tradition::Error $e ) {
168                                 $errmsg = $e->message;
169                         } catch ( $e ) {
170                                 $errmsg = "Unexpected parsing error: $e";
171                         }
172                 }
173         } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
174                 # If it's Excel we need to pass excel => $ext;
175                 # otherwise we need to pass sep_char => [record separator].
176                 if( $ext =~ /xls/ ) {
177                         $newopts{'excel'} = $ext;
178                 } else {
179                         $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
180                 }
181                 try {
182                         $tradition = Text::Tradition->new( 
183                                 %newopts,
184                                 'input' => 'Tabular',
185                                 );
186                 } catch ( Text::Tradition::Error $e ) {
187                         $errmsg = $e->message;
188                 } catch ( $e ) {
189                         $errmsg = "Unexpected parsing error: $e";
190                 }
191         } else {
192                 # Error unless we have a recognized filename extension
193                 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
194         }
195         
196         # Save the tradition if we have it, and return its data or else the
197         # error that occurred trying to make it.
198         if( $errmsg ) {
199                 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
200         } elsif( !$tradition ) {
201                 return _json_error( $c, 500, "No error caught but tradition not created" );
202         }
203
204         my $m = $c->model('Directory');
205         $user->add_tradition( $tradition );
206         my $id = $c->model('Directory')->store( $tradition );
207         $c->model('Directory')->store( $user );
208         $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
209         $c->forward('View::JSON');
210 }
211
212 =head2 textinfo
213
214  GET /textinfo/$textid
215  POST /textinfo/$textid, 
216         { name: $new_name, 
217           language: $new_language,
218           public: $is_public, 
219           owner: $new_userid } # only admin users can update the owner
220  
221 Returns information about a particular text.
222
223 =cut
224
225 sub textinfo :Local :Args(1) {
226         my( $self, $c, $textid ) = @_;
227         my $tradition = $c->model('Directory')->tradition( $textid );
228         ## Have to keep users in the same scope as tradition
229         my $newuser;
230         my $olduser;
231         unless( $tradition ) {
232                 return _json_error( $c, 404, "No tradition with ID $textid" );
233         }       
234         my $ok = _check_permission( $c, $tradition );
235         return unless $ok;
236         if( $c->req->method eq 'POST' ) {
237                 return _json_error( $c, 403, 
238                         'You do not have permission to update this tradition' ) 
239                         unless $ok eq 'full';
240                 my $params = $c->request->parameters;
241                 # Handle changes to owner-accessible parameters
242                 my $m = $c->model('Directory');
243                 my $changed;
244                 # Handle name param - easy
245                 if( exists $params->{name} ) {
246                         my $newname = delete $params->{name};
247                         unless( $tradition->name eq $newname ) {
248                                 try {
249                                         $tradition->name( $newname );
250                                         $changed = 1;
251                                 } catch {
252                                         return _json_error( $c, 500, "Error setting name to $newname" );
253                                 }
254                         }
255                 }
256                 # Handle language param, making Default => null
257                 my $langval = delete $params->{language} || 'Default';
258                 
259                 unless( $tradition->language eq $langval || !$tradition->can('language') ) {
260                         try {
261                                 $tradition->language( $langval );
262                                 $changed = 1;
263                         } catch {
264                                 return _json_error( $c, 500, "Error setting language to $langval" );
265                         }
266                 }
267
268                 # Handle our boolean
269                 my $ispublic = $tradition->public;
270                 if( delete $params->{'public'} ) {  # if it's any true value...
271                         $tradition->public( 1 );
272                         $changed = 1 unless $ispublic;
273                 } else {  # the checkbox was unchecked, ergo it should not be public
274                         $tradition->public( 0 );
275                         $changed = 1 if $ispublic;
276                 }
277                 
278                 # Handle ownership change
279                 if( exists $params->{'owner'} ) {
280                         # Only admins can update user / owner
281                         my $newownerid = delete $params->{'owner'};
282                         if( $tradition->has_user && !$tradition->user ) {
283                                 $tradition->clear_user;
284                         }
285                         unless( !$newownerid || 
286                                 ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) {
287                                 unless( $c->user->get_object->is_admin ) {
288                                         return _json_error( $c, 403, 
289                                                 "Only admin users can change tradition ownership" );
290                                 }
291                                 $newuser = $m->find_user({ email => $newownerid });
292                                 unless( $newuser ) {
293                                         return _json_error( $c, 500, "No such user " . $newownerid );
294                                 }
295                                 if( $tradition->has_user ) {
296                                         $olduser = $tradition->user;
297                                         $olduser->remove_tradition( $tradition );
298                                 }
299                                 $newuser->add_tradition( $tradition );
300                                 $changed = 1;
301                         }
302                 }
303                 # TODO check for rogue parameters
304                 if( scalar keys %$params ) {
305                         my $rogueparams = join( ', ', keys %$params );
306                         return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
307                 }
308                 # If we safely got to the end, then write to the database.
309                 $m->save( $tradition ) if $changed;
310                 $m->save( $newuser ) if $newuser;               
311         }
312
313         # Now return the current textinfo, whether GET or successful POST.
314         my $textinfo = {
315                 textid => $textid,
316                 name => $tradition->name,
317                 public => $tradition->public || 0,
318                 owner => $tradition->user ? $tradition->user->email : undef,
319                 witnesses => [ map { $_->sigil } $tradition->witnesses ],
320         };
321         if( $tradition->can('language') ) {
322                 $textinfo->{'language'} = $tradition->language;
323         }
324         if( $tradition->can('stemweb_jobid') ) {
325                 $textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
326         }
327         my @stemmasvg = map { { 
328                         name => $_->identifier, 
329                         directed => _json_bool( !$_->is_undirected ),
330                         svg => $_->as_svg() } } 
331                 $tradition->stemmata;
332         map { $_ =~ s/\n/ /mg } @stemmasvg;
333         $textinfo->{stemmata} = \@stemmasvg;
334         $c->stash->{'result'} = $textinfo;
335         $c->forward('View::JSON');
336 }
337
338 =head2 variantgraph
339
340  GET /variantgraph/$textid
341  
342 Returns the variant graph for the text specified at $textid, in SVG form.
343
344 =cut
345
346 sub variantgraph :Local :Args(1) {
347         my( $self, $c, $textid ) = @_;
348         my $tradition = $c->model('Directory')->tradition( $textid );
349         unless( $tradition ) {
350                 return _json_error( $c, 404, "No tradition with ID $textid" );
351         }       
352         my $ok = _check_permission( $c, $tradition );
353         return unless $ok;
354
355         my $collation = $tradition->collation;
356         $c->stash->{'result'} = $collation->as_svg;
357         $c->forward('View::SVG');
358 }
359         
360 =head2 stemma
361
362  GET /stemma/$textid/$stemmaseq
363  POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
364
365 Returns an SVG representation of the given stemma hypothesis for the text.  
366 If the URL is called with POST, the stemma at $stemmaseq will be altered
367 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
368 stemma will be added.
369
370 =cut
371
372 sub stemma :Local :Args(2) {
373         my( $self, $c, $textid, $stemmaid ) = @_;
374         my $m = $c->model('Directory');
375         my $tradition = $m->tradition( $textid );
376         unless( $tradition ) {
377                 return _json_error( $c, 404, "No tradition with ID $textid" );
378         }       
379         my $ok = _check_permission( $c, $tradition );
380         return unless $ok;
381
382         $c->stash->{'result'} = '';
383         my $stemma;
384         if( $c->req->method eq 'POST' ) {
385                 if( $ok eq 'full' ) {
386                         my $dot = $c->request->body_params->{'dot'};
387                         # Graph::Reader::Dot does not handle bare unicode. We get around this
388                         # by wrapping all words in double quotes, as long as they aren't already
389                         # wrapped, and as long as they aren't the initial '(di)?graph .*'.
390                         # Horrible HACK.
391                         my @dlines = split( "\n", $dot );
392                         my $wdot = '';
393                         foreach( @dlines ) {
394                                 unless( /^(di)?graph/ ) { # Skip the first line
395                                         s/(?<!")\b(\w+)\b(?!")/"$1"/g;
396                                 }
397                                 $wdot .= "$_\n";
398                         }
399                         # $dot =~ s/(?<!")\b(?!(?:digraph|stemma)\b)(\w+)\b(?!")/"$1"/g;
400                         $dot = $wdot;
401                         print STDERR "$dot\n";
402                         try {
403                                 if( $stemmaid eq 'n' ) {
404                                         # We are adding a new stemma.
405                                         $stemmaid = $tradition->stemma_count;
406                                         $stemma = $tradition->add_stemma( 'dot' => $dot );
407                                 } elsif( $stemmaid !~ /^\d+$/ ) {
408                                         return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
409                                 } elsif( $stemmaid < $tradition->stemma_count ) {
410                                         # We are updating an existing stemma.
411                                         $stemma = $tradition->stemma( $stemmaid );
412                                         $stemma->alter_graph( $dot );
413                                 } else {
414                                         # Unrecognized stemma ID
415                                         return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
416                                 }
417                         } catch ( Text::Tradition::Error $e ) {
418                                 return _json_error( $c, 500, $e->message );
419                         }
420                         $m->store( $tradition );
421                 } else {
422                         # No permissions to update the stemma
423                         return _json_error( $c, 403, 
424                                 'You do not have permission to update stemmata for this tradition' );
425                 }
426         }
427         
428         # For a GET or a successful POST request, return the SVG representation
429         # of the stemma in question, if any.
430         if( !$stemma && $tradition->stemma_count > $stemmaid ) {
431                 $stemma = $tradition->stemma( $stemmaid );
432         }
433         my $stemma_xml = $stemma ? $stemma->as_svg() : '';
434         # What was requested, XML or JSON?
435         my $return_view = 'SVG';
436         if( my $accept_header = $c->req->header('Accept') ) {
437                 $c->log->debug( "Received Accept header: $accept_header" );
438                 foreach my $type ( split( /,\s*/, $accept_header ) ) {
439                         # If we were first asked for XML, return SVG
440                         last if $type =~ /^(application|text)\/xml$/;
441                         # If we were first asked for JSON, return JSON
442                         if( $type eq 'application/json' ) {
443                                 $return_view = 'JSON';
444                                 last;
445                         }
446                 }
447         }
448         if( $return_view eq 'SVG' ) {
449                 $c->stash->{'result'} = $stemma_xml;
450                 $c->forward('View::SVG');
451         } else { # JSON
452                 $stemma_xml =~ s/\n/ /mg;
453                 $c->stash->{'result'} = { 
454                         'stemmaid' => $stemmaid, 
455                         'name' => $stemma->identifier,
456                         'directed' => _json_bool( !$stemma->is_undirected ),
457                         'svg' => $stemma_xml };
458                 $c->forward('View::JSON');
459         }
460 }
461
462 =head2 stemmadot
463
464  GET /stemmadot/$textid/$stemmaseq
465  
466 Returns the 'dot' format representation of the current stemma hypothesis.
467
468 =cut
469
470 sub stemmadot :Local :Args(2) {
471         my( $self, $c, $textid, $stemmaid ) = @_;
472         my $m = $c->model('Directory');
473         my $tradition = $m->tradition( $textid );
474         unless( $tradition ) {
475                 return _json_error( $c, 404, "No tradition with ID $textid" );
476         }       
477         my $ok = _check_permission( $c, $tradition );
478         return unless $ok;
479         my $stemma = $tradition->stemma( $stemmaid );
480         unless( $stemma ) {
481                 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
482         }
483         # Get the dot and transmute its line breaks to literal '|n'
484         $c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
485         $c->forward('View::JSON');
486 }
487
488 =head2 download
489
490  GET /download/$textid
491  
492 Returns the full XML definition of the tradition and its stemmata, if any.
493  
494 =cut
495
496 sub download :Local :Args(1) {
497         my( $self, $c, $textid ) = @_;
498         my $tradition = $c->model('Directory')->tradition( $textid );
499         unless( $tradition ) {
500                 return _json_error( $c, 404, "No tradition with ID $textid" );
501         }
502         my $ok = _check_permission( $c, $tradition );
503         return unless $ok;
504         try {
505                 $c->stash->{'result'} = $tradition->collation->as_graphml();
506         } catch( Text::Tradition::Error $e ) {
507                 return _json_error( $c, 500, $e->message );
508         }
509         $c->forward('View::GraphML');
510 }
511
512 ####################
513 ### Helper functions
514 ####################
515
516 # Helper to check what permission, if any, the active user has for
517 # the given tradition
518 sub _check_permission {
519         my( $c, $tradition ) = @_;
520     my $user = $c->user_exists ? $c->user->get_object : undef;
521     if( $user ) {
522         return 'full' if ( $user->is_admin || 
523                 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
524     }
525         # Text doesn't belong to us, so maybe it's public?
526         return 'readonly' if $tradition->public;
527
528         # ...nope. Forbidden!
529         return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
530 }
531
532 # Helper to throw a JSON exception
533 sub _json_error {
534         my( $c, $code, $errmsg ) = @_;
535         $c->response->status( $code );
536         $c->stash->{'result'} = { 'error' => $errmsg };
537         $c->forward('View::JSON');
538         return 0;
539 }
540
541 sub _json_bool {
542         return $_[0] ? JSON::true : JSON::false;
543 }
544
545 =head2 default
546
547 Standard 404 error page
548
549 =cut
550
551 sub default :Path {
552     my ( $self, $c ) = @_;
553     $c->response->body( 'Page not found' );
554     $c->response->status(404);
555 }
556
557 =head2 end
558
559 Attempt to render a view, if needed.
560
561 =cut
562
563 sub end : ActionClass('RenderView') {}
564
565 =head1 AUTHOR
566
567 Tara L Andrews
568
569 =head1 LICENSE
570
571 This library is free software. You can redistribute it and/or modify
572 it under the same terms as Perl itself.
573
574 =cut
575
576 __PACKAGE__->meta->make_immutable;
577
578 1;