1 package stemmaweb::Controller::Root;
3 use namespace::autoclean;
7 use XML::LibXML::XPathContext;
10 BEGIN { extends 'Catalyst::Controller' }
13 # Sets the actions in this controller to be registered with no prefix
14 # so they function identically to actions created in MyApp.pm
16 __PACKAGE__->config(namespace => '');
20 stemmaweb::Controller::Root - Root Controller for stemmaweb
24 Serves up the main container pages.
30 The root page (/). Serves the main container page, from which the various
31 components will be loaded.
35 sub index :Path :Args(0) {
36 my ( $self, $c ) = @_;
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');
42 $c->stash->{template} = 'index.tt';
47 A general overview/documentation page for the site.
51 sub about :Local :Args(0) {
53 $c->stash->{template} = 'about.tt';
58 A dispatcher for documentation of various aspects of the application.
62 sub help :Local :Args(1) {
63 my( $self, $c, $topic ) = @_;
64 $c->stash->{template} = "$topic.tt";
67 =head1 Elements of index page
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.
77 sub directory :Local :Args(0) {
79 my $m = $c->model('Directory');
80 # Is someone logged in?
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;
89 # List public (i.e. readonly) texts separately from any user (i.e.
90 # full access) texts that exist. Admin users therefore have nothing
92 my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
93 $c->stash->{publictexts} = \@plist;
94 $c->stash->{template} = 'directory.tt';
97 =head1 AJAX methods for traditions and their properties
103 language: <language>,
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.
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;
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 $direction = $c->request->param('direction') || 'LR';
128 my( $ext ) = $upload->filename =~ /\.(\w+)$/;
133 'file' => $upload->tempname,
134 'direction' => $direction,
139 if( $ext eq 'xml' ) {
141 # Parse the XML to see which flavor it is.
142 my $parser = XML::LibXML->new();
145 $doc = $parser->parse_file( $newopts{'file'} );
147 $errmsg = "XML file parsing error: $err";
150 if( $doc->documentElement->nodeName eq 'graphml' ) {
152 } elsif( $doc->documentElement->nodeName ne 'TEI' ) {
153 $errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
155 my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
156 my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' );
157 if( $venc && $venc eq 'double-end-point' ) {
164 # Try the relevant XML parsing option.
166 delete $newopts{'file'};
167 $newopts{'xmlobj'} = $doc;
169 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
170 } catch ( Text::Tradition::Error $e ) {
171 $errmsg = $e->message;
173 $errmsg = "Unexpected parsing error: $e";
176 } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
177 # If it's Excel we need to pass excel => $ext;
178 # otherwise we need to pass sep_char => [record separator].
179 if( $ext =~ /xls/ ) {
180 $newopts{'excel'} = $ext;
182 $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
185 $tradition = Text::Tradition->new(
187 'input' => 'Tabular',
189 } catch ( Text::Tradition::Error $e ) {
190 $errmsg = $e->message;
192 $errmsg = "Unexpected parsing error: $e";
195 # Error unless we have a recognized filename extension
196 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
199 # Save the tradition if we have it, and return its data or else the
200 # error that occurred trying to make it.
202 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
203 } elsif( !$tradition ) {
204 return _json_error( $c, 500, "No error caught but tradition not created" );
207 my $m = $c->model('Directory');
208 $user->add_tradition( $tradition );
209 my $id = $c->model('Directory')->store( $tradition );
210 $c->model('Directory')->store( $user );
211 $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
212 $c->forward('View::JSON');
217 GET /textinfo/$textid
218 POST /textinfo/$textid,
220 language: $new_language,
222 owner: $new_userid } # only admin users can update the owner
224 Returns information about a particular text.
228 sub textinfo :Local :Args(1) {
229 my( $self, $c, $textid ) = @_;
230 my $tradition = $c->model('Directory')->tradition( $textid );
231 ## Have to keep users in the same scope as tradition
234 unless( $tradition ) {
235 return _json_error( $c, 404, "No tradition with ID $textid" );
237 my $ok = _check_permission( $c, $tradition );
239 if( $c->req->method eq 'POST' ) {
240 return _json_error( $c, 403,
241 'You do not have permission to update this tradition' )
242 unless $ok eq 'full';
243 my $params = $c->request->parameters;
244 # Handle changes to owner-accessible parameters
245 my $m = $c->model('Directory');
247 # Handle name param - easy
248 if( exists $params->{name} ) {
249 my $newname = delete $params->{name};
250 unless( $tradition->name eq $newname ) {
252 $tradition->name( $newname );
255 return _json_error( $c, 500, "Error setting name to $newname: $@" );
259 # Handle language param, making Default => null
260 my $langval = delete $params->{language} || 'Default';
262 unless( $tradition->language eq $langval || !$tradition->can('language') ) {
264 $tradition->language( $langval );
267 return _json_error( $c, 500, "Error setting language to $langval: $@" );
272 my $ispublic = $tradition->public;
273 if( delete $params->{'public'} ) { # if it's any true value...
274 $tradition->public( 1 );
275 $changed = 1 unless $ispublic;
276 } else { # the checkbox was unchecked, ergo it should not be public
277 $tradition->public( 0 );
278 $changed = 1 if $ispublic;
281 # Handle text direction
282 my $tdval = delete $params->{direction} || 'LR';
284 unless( $tradition->collation->direction
285 && $tradition->collation->direction eq $tdval ) {
287 $tradition->collation->change_direction( $tdval );
290 return _json_error( $c, 500, "Error setting direction to $tdval: $@" );
295 # Handle ownership change
296 if( exists $params->{'owner'} ) {
297 # Only admins can update user / owner
298 my $newownerid = delete $params->{'owner'};
299 if( $tradition->has_user && !$tradition->user ) {
300 $tradition->clear_user;
302 unless( !$newownerid ||
303 ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) {
304 unless( $c->user->get_object->is_admin ) {
305 return _json_error( $c, 403,
306 "Only admin users can change tradition ownership" );
308 $newuser = $m->find_user({ email => $newownerid });
310 return _json_error( $c, 500, "No such user " . $newownerid );
312 if( $tradition->has_user ) {
313 $olduser = $tradition->user;
314 $olduser->remove_tradition( $tradition );
316 $newuser->add_tradition( $tradition );
320 # TODO check for rogue parameters
321 if( scalar keys %$params ) {
322 my $rogueparams = join( ', ', keys %$params );
323 return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
325 # If we safely got to the end, then write to the database.
326 $m->save( $tradition ) if $changed;
327 $m->save( $newuser ) if $newuser;
330 # Now return the current textinfo, whether GET or successful POST.
333 name => $tradition->name,
334 direction => $tradition->collation->direction || 'LR',
335 public => $tradition->public || 0,
336 owner => $tradition->user ? $tradition->user->email : undef,
337 witnesses => [ map { $_->sigil } $tradition->witnesses ],
338 # TODO Send them all with appropriate parameters so that the
339 # client side can choose what to display.
340 reltypes => [ map { $_->name } grep { !$_->is_weak && $_->is_colocation }
341 $tradition->collation->relationship_types ]
343 ## TODO Make these into callbacks in the other controllers maybe?
344 if( $tradition->can('language') ) {
345 $textinfo->{'language'} = $tradition->language;
347 if( $tradition->can('stemweb_jobid') ) {
348 $textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
350 my @stemmasvg = map { _stemma_info( $_ ) } $tradition->stemmata;
351 $textinfo->{stemmata} = \@stemmasvg;
352 $c->stash->{'result'} = $textinfo;
353 $c->forward('View::JSON');
358 GET /variantgraph/$textid
360 Returns the variant graph for the text specified at $textid, in SVG form.
364 sub variantgraph :Local :Args(1) {
365 my( $self, $c, $textid ) = @_;
366 my $tradition = $c->model('Directory')->tradition( $textid );
367 unless( $tradition ) {
368 return _json_error( $c, 404, "No tradition with ID $textid" );
370 my $ok = _check_permission( $c, $tradition );
373 my $collation = $tradition->collation;
374 $c->stash->{'result'} = $collation->as_svg;
375 $c->forward('View::SVG');
379 my( $stemma, $sid ) = @_;
380 my $ssvg = $stemma->as_svg();
383 name => $stemma->identifier,
384 directed => _json_bool( !$stemma->is_undirected ),
387 $sinfo->{stemmaid} = $sid;
392 ## TODO Separate stemma manipulation functionality into its own controller.
396 GET /stemma/$textid/$stemmaseq
397 POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
399 Returns an SVG representation of the given stemma hypothesis for the text.
400 If the URL is called with POST, the stemma at $stemmaseq will be altered
401 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
402 stemma will be added.
406 sub stemma :Local :Args(2) {
407 my( $self, $c, $textid, $stemmaid ) = @_;
408 my $m = $c->model('Directory');
409 my $tradition = $m->tradition( $textid );
410 unless( $tradition ) {
411 return _json_error( $c, 404, "No tradition with ID $textid" );
413 my $ok = _check_permission( $c, $tradition );
416 $c->stash->{'result'} = '';
418 if( $c->req->method eq 'POST' ) {
419 if( $ok eq 'full' ) {
420 my $dot = $c->request->body_params->{'dot'};
422 if( $stemmaid eq 'n' ) {
423 # We are adding a new stemma.
424 $stemmaid = $tradition->stemma_count;
425 $stemma = $tradition->add_stemma( 'dot' => $dot );
426 } elsif( $stemmaid !~ /^\d+$/ ) {
427 return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
428 } elsif( $stemmaid < $tradition->stemma_count ) {
429 # We are updating an existing stemma.
430 $stemma = $tradition->stemma( $stemmaid );
431 $stemma->alter_graph( $dot );
433 # Unrecognized stemma ID
434 return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
436 } catch ( Text::Tradition::Error $e ) {
437 return _json_error( $c, 500, $e->message );
439 $m->store( $tradition );
441 # No permissions to update the stemma
442 return _json_error( $c, 403,
443 'You do not have permission to update stemmata for this tradition' );
447 # For a GET or a successful POST request, return the SVG representation
448 # of the stemma in question, if any.
449 if( !$stemma && $tradition->stemma_count > $stemmaid ) {
450 $stemma = $tradition->stemma( $stemmaid );
452 # What was requested, XML or JSON?
453 my $return_view = 'SVG';
454 if( my $accept_header = $c->req->header('Accept') ) {
455 $c->log->debug( "Received Accept header: $accept_header" );
456 foreach my $type ( split( /,\s*/, $accept_header ) ) {
457 # If we were first asked for XML, return SVG
458 last if $type =~ /^(application|text)\/xml$/;
459 # If we were first asked for JSON, return JSON
460 if( $type eq 'application/json' ) {
461 $return_view = 'JSON';
466 if( $return_view eq 'SVG' ) {
467 $c->stash->{'result'} = $stemma->as_svg();
468 $c->forward('View::SVG');
470 $c->stash->{'result'} = _stemma_info( $stemma, $stemmaid );
471 $c->forward('View::JSON');
477 GET /stemmadot/$textid/$stemmaseq
479 Returns the 'dot' format representation of the current stemma hypothesis.
483 sub stemmadot :Local :Args(2) {
484 my( $self, $c, $textid, $stemmaid ) = @_;
485 my $m = $c->model('Directory');
486 my $tradition = $m->tradition( $textid );
487 unless( $tradition ) {
488 return _json_error( $c, 404, "No tradition with ID $textid" );
490 my $ok = _check_permission( $c, $tradition );
492 my $stemma = $tradition->stemma( $stemmaid );
494 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
496 # Get the dot and transmute its line breaks to literal '|n'
497 $c->stash->{'result'} = { 'dot' => $stemma->editable( { linesep => '|n' } ) };
498 $c->forward('View::JSON');
503 POST /stemmaroot/$textid/$stemmaseq, { root: <root node ID> }
505 Orients the given stemma so that the given node is the root (archetype). Returns the
506 information structure for the new stemma.
510 sub stemmaroot :Local :Args(2) {
511 my( $self, $c, $textid, $stemmaid ) = @_;
512 my $m = $c->model('Directory');
513 my $tradition = $m->tradition( $textid );
514 unless( $tradition ) {
515 return _json_error( $c, 404, "No tradition with ID $textid" );
517 my $ok = _check_permission( $c, $tradition );
518 if( $ok eq 'full' ) {
519 my $stemma = $tradition->stemma( $stemmaid );
521 $stemma->root_graph( $c->req->param('root') );
522 $m->save( $tradition );
523 } catch( Text::Tradition::Error $e ) {
524 return _json_error( $c, 400, $e->message );
526 return _json_error( $c, 500, "Error re-rooting stemma: $@" );
528 $c->stash->{'result'} = _stemma_info( $stemma );
529 $c->forward('View::JSON');
531 return _json_error( $c, 403,
532 'You do not have permission to update stemmata for this tradition' );
538 GET /download/$textid/$format
540 Returns a file for download of the tradition in the requested format.
544 sub download :Local :Args(2) {
545 my( $self, $c, $textid, $format ) = @_;
546 my $tradition = $c->model('Directory')->tradition( $textid );
547 unless( $tradition ) {
548 return _json_error( $c, 404, "No tradition with ID $textid" );
550 my $ok = _check_permission( $c, $tradition );
553 my $outmethod = "as_" . lc( $format );
554 my $view = "View::$format";
555 $c->stash->{'name'} = $tradition->name();
556 $c->stash->{'download'} = 1;
558 if( $format eq 'SVG' ) {
559 # Send the list of colors through to the backend.
560 # TODO Think of some way not to hard-code this.
561 push( @outputargs, { 'show_relations' => 'all',
562 'graphcolors' => [ "#5CCCCC", "#67E667", "#F9FE72", "#6B90D4",
563 "#FF7673", "#E467B3", "#AA67D5", "#8370D8", "#FFC173" ] } );
566 $c->stash->{'result'} = $tradition->collation->$outmethod( @outputargs );
567 } catch( Text::Tradition::Error $e ) {
568 return _json_error( $c, 500, $e->message );
570 $c->forward( $view );
577 # Helper to check what permission, if any, the active user has for
578 # the given tradition
579 sub _check_permission {
580 my( $c, $tradition ) = @_;
581 my $user = $c->user_exists ? $c->user->get_object : undef;
583 return 'full' if ( $user->is_admin ||
584 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
586 # Text doesn't belong to us, so maybe it's public?
587 return 'readonly' if $tradition->public;
589 # ...nope. Forbidden!
590 return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
593 # Helper to throw a JSON exception
595 my( $c, $code, $errmsg ) = @_;
596 $c->response->status( $code );
597 $c->stash->{'result'} = { 'error' => $errmsg };
598 $c->forward('View::JSON');
603 return $_[0] ? JSON::true : JSON::false;
608 Standard 404 error page
613 my ( $self, $c ) = @_;
614 $c->response->body( 'Page not found' );
615 $c->response->status(404);
620 Attempt to render a view, if needed.
624 sub end : ActionClass('RenderView') {}
632 This library is free software. You can redistribute it and/or modify
633 it under the same terms as Perl itself.
637 __PACKAGE__->meta->make_immutable;