1 package stemmaweb::Controller::Root;
3 use namespace::autoclean;
8 use XML::LibXML::XPathContext;
11 BEGIN { extends 'Catalyst::Controller' }
14 # Sets the actions in this controller to be registered with no prefix
15 # so they function identically to actions created in MyApp.pm
17 __PACKAGE__->config(namespace => '');
19 my $STEMWEB_BASE_URL = 'http://slinkola.users.cs.helsinki.fi';
23 stemmaweb::Controller::Root - Root Controller for stemmaweb
27 Serves up the main container pages.
33 The root page (/). Serves the main container page, from which the various
34 components will be loaded.
38 sub index :Path :Args(0) {
39 my ( $self, $c ) = @_;
41 # Are we being asked to load a text immediately? If so
42 if( $c->req->param('withtradition') ) {
43 $c->stash->{'withtradition'} = $c->req->param('withtradition');
45 # Get the current list of Stemweb algorithms
46 my $ua = LWP::UserAgent->new();
47 my $resp = $ua->get( $STEMWEB_BASE_URL . '/algorithms/available' );
48 if( $resp->is_success ) {
49 $c->stash->{'stemweb_algorithms'} = $resp->content;
51 $c->stash->{'stemweb_algorithms'} = '{}';
53 $c->stash->{template} = 'index.tt';
58 A general overview/documentation page for the site.
62 sub about :Local :Args(0) {
64 $c->stash->{template} = 'about.tt';
69 A dispatcher for documentation of various aspects of the application.
73 sub help :Local :Args(1) {
74 my( $self, $c, $topic ) = @_;
75 $c->stash->{template} = "$topic.tt";
78 =head1 Elements of index page
84 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.
88 sub directory :Local :Args(0) {
90 my $m = $c->model('Directory');
91 # Is someone logged in?
93 if( $c->user_exists ) {
94 my $user = $c->user->get_object;
95 my @list = $m->traditionlist( $user );
96 map { $usertexts{$_->{id}} = 1 } @list;
97 $c->stash->{usertexts} = \@list;
98 $c->stash->{is_admin} = 1 if $user->is_admin;
100 # List public (i.e. readonly) texts separately from any user (i.e.
101 # full access) texts that exist. Admin users therefore have nothing
103 my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
104 $c->stash->{publictexts} = \@plist;
105 $c->stash->{template} = 'directory.tt';
108 =head1 AJAX methods for traditions and their properties
114 language: <language>,
118 Creates a new tradition belonging to the logged-in user, with the given name
119 and the collation given in the uploaded file. The file type is indicated via
120 the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and
121 name of the new tradition.
125 sub newtradition :Local :Args(0) {
126 my( $self, $c ) = @_;
127 return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
128 unless $c->user_exists;
130 my $user = $c->user->get_object;
131 # Grab the file upload, check its name/extension, and call the
132 # appropriate parser(s).
133 my $upload = $c->request->upload('file');
134 my $name = $c->request->param('name') || 'Uploaded tradition';
135 my $lang = $c->request->param( 'language' ) || 'Default';
136 my $public = $c->request->param( 'public' ) ? 1 : undef;
137 my( $ext ) = $upload->filename =~ /\.(\w+)$/;
142 'file' => $upload->tempname
147 if( $ext eq 'xml' ) {
149 # Parse the XML to see which flavor it is.
150 my $parser = XML::LibXML->new();
153 $doc = $parser->parse_file( $newopts{'file'} );
155 $errmsg = "XML file parsing error: $err";
158 if( $doc->documentElement->nodeName eq 'GraphML' ) {
160 } elsif( $doc->documentElement->nodeName ne 'TEI' ) {
161 $errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
163 my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
164 my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' );
165 if( $venc && $venc eq 'double-end-point' ) {
172 # Try the relevant XML parsing option.
174 delete $newopts{'file'};
175 $newopts{'xmlobj'} = $doc;
177 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
178 } catch ( Text::Tradition::Error $e ) {
179 $errmsg = $e->message;
181 $errmsg = "Unexpected parsing error: $e";
184 } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
185 # If it's Excel we need to pass excel => $ext;
186 # otherwise we need to pass sep_char => [record separator].
187 if( $ext =~ /xls/ ) {
188 $newopts{'excel'} = $ext;
190 $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
193 $tradition = Text::Tradition->new(
195 'input' => 'Tabular',
197 } catch ( Text::Tradition::Error $e ) {
198 $errmsg = $e->message;
200 $errmsg = "Unexpected parsing error: $e";
203 # Error unless we have a recognized filename extension
204 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
207 # Save the tradition if we have it, and return its data or else the
208 # error that occurred trying to make it.
210 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
211 } elsif( !$tradition ) {
212 return _json_error( $c, 500, "No error caught but tradition not created" );
215 my $m = $c->model('Directory');
216 $user->add_tradition( $tradition );
217 my $id = $c->model('Directory')->store( $tradition );
218 $c->model('Directory')->store( $user );
219 $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
220 $c->forward('View::JSON');
225 GET /textinfo/$textid
226 POST /textinfo/$textid,
228 language: $new_language,
230 owner: $new_userid } # only admin users can update the owner
232 Returns information about a particular text.
236 sub textinfo :Local :Args(1) {
237 my( $self, $c, $textid ) = @_;
238 my $tradition = $c->model('Directory')->tradition( $textid );
239 ## Have to keep users in the same scope as tradition
242 unless( $tradition ) {
243 return _json_error( $c, 404, "No tradition with ID $textid" );
245 my $ok = _check_permission( $c, $tradition );
247 if( $c->req->method eq 'POST' ) {
248 return _json_error( $c, 403,
249 'You do not have permission to update this tradition' )
250 unless $ok eq 'full';
251 my $params = $c->request->parameters;
252 # Handle changes to owner-accessible parameters
253 my $m = $c->model('Directory');
255 # Handle name param - easy
256 if( exists $params->{name} ) {
257 my $newname = delete $params->{name};
258 unless( $tradition->name eq $newname ) {
260 $tradition->name( $newname );
263 return _json_error( $c, 500, "Error setting name to $newname" );
267 # Handle language param, making Default => null
268 my $langval = delete $params->{language} || 'Default';
270 unless( $tradition->language eq $langval || !$tradition->can('language') ) {
272 $tradition->language( $langval );
275 return _json_error( $c, 500, "Error setting language to $langval" );
280 my $ispublic = $tradition->public;
281 if( delete $params->{'public'} ) { # if it's any true value...
282 $tradition->public( 1 );
283 $changed = 1 unless $ispublic;
284 } else { # the checkbox was unchecked, ergo it should not be public
285 $tradition->public( 0 );
286 $changed = 1 if $ispublic;
289 # Handle ownership change
290 if( exists $params->{'owner'} ) {
291 # Only admins can update user / owner
292 my $newownerid = delete $params->{'owner'};
293 if( $tradition->has_user && !$tradition->user ) {
294 $tradition->clear_user;
296 unless( !$newownerid ||
297 ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) {
298 unless( $c->user->get_object->is_admin ) {
299 return _json_error( $c, 403,
300 "Only admin users can change tradition ownership" );
302 $newuser = $m->find_user({ email => $newownerid });
304 return _json_error( $c, 500, "No such user " . $newownerid );
306 if( $tradition->has_user ) {
307 $olduser = $tradition->user;
308 $olduser->remove_tradition( $tradition );
310 $newuser->add_tradition( $tradition );
314 # TODO check for rogue parameters
315 if( scalar keys %$params ) {
316 my $rogueparams = join( ', ', keys %$params );
317 return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
319 # If we safely got to the end, then write to the database.
320 $m->save( $tradition ) if $changed;
321 $m->save( $newuser ) if $newuser;
324 # Now return the current textinfo, whether GET or successful POST.
327 name => $tradition->name,
328 public => $tradition->public || 0,
329 owner => $tradition->user ? $tradition->user->email : undef,
330 witnesses => [ map { $_->sigil } $tradition->witnesses ],
332 if( $tradition->can('language') ) {
333 $textinfo->{'language'} = $tradition->language;
335 if( $tradition->can('stemweb_jobid') ) {
336 $textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
338 my @stemmasvg = map { {
339 name => $_->identifier,
340 directed => _json_bool( !$_->is_undirected ),
341 svg => $_->as_svg() } }
342 $tradition->stemmata;
343 map { $_ =~ s/\n/ /mg } @stemmasvg;
344 $textinfo->{stemmata} = \@stemmasvg;
345 $c->stash->{'result'} = $textinfo;
346 $c->forward('View::JSON');
351 GET /variantgraph/$textid
353 Returns the variant graph for the text specified at $textid, in SVG form.
357 sub variantgraph :Local :Args(1) {
358 my( $self, $c, $textid ) = @_;
359 my $tradition = $c->model('Directory')->tradition( $textid );
360 unless( $tradition ) {
361 return _json_error( $c, 404, "No tradition with ID $textid" );
363 my $ok = _check_permission( $c, $tradition );
366 my $collation = $tradition->collation;
367 $c->stash->{'result'} = $collation->as_svg;
368 $c->forward('View::SVG');
373 GET /stemma/$textid/$stemmaseq
374 POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
376 Returns an SVG representation of the given stemma hypothesis for the text.
377 If the URL is called with POST, the stemma at $stemmaseq will be altered
378 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
379 stemma will be added.
383 sub stemma :Local :Args(2) {
384 my( $self, $c, $textid, $stemmaid ) = @_;
385 my $m = $c->model('Directory');
386 my $tradition = $m->tradition( $textid );
387 unless( $tradition ) {
388 return _json_error( $c, 404, "No tradition with ID $textid" );
390 my $ok = _check_permission( $c, $tradition );
393 $c->stash->{'result'} = '';
395 if( $c->req->method eq 'POST' ) {
396 if( $ok eq 'full' ) {
397 my $dot = $c->request->body_params->{'dot'};
398 # Graph::Reader::Dot does not handle bare unicode. We get around this
399 # by wrapping all words in double quotes, as long as they aren't already
400 # wrapped, and as long as they aren't the initial '(di)?graph .*'.
402 my @dlines = split( "\n", $dot );
405 unless( /^(di)?graph/ ) { # Skip the first line
406 s/(?<!")\b(\w+)\b(?!")/"$1"/g;
410 # $dot =~ s/(?<!")\b(?!(?:digraph|stemma)\b)(\w+)\b(?!")/"$1"/g;
412 print STDERR "$dot\n";
414 if( $stemmaid eq 'n' ) {
415 # We are adding a new stemma.
416 $stemmaid = $tradition->stemma_count;
417 $stemma = $tradition->add_stemma( 'dot' => $dot );
418 } elsif( $stemmaid !~ /^\d+$/ ) {
419 return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
420 } elsif( $stemmaid < $tradition->stemma_count ) {
421 # We are updating an existing stemma.
422 $stemma = $tradition->stemma( $stemmaid );
423 $stemma->alter_graph( $dot );
425 # Unrecognized stemma ID
426 return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
428 } catch ( Text::Tradition::Error $e ) {
429 return _json_error( $c, 500, $e->message );
431 $m->store( $tradition );
433 # No permissions to update the stemma
434 return _json_error( $c, 403,
435 'You do not have permission to update stemmata for this tradition' );
439 # For a GET or a successful POST request, return the SVG representation
440 # of the stemma in question, if any.
441 if( !$stemma && $tradition->stemma_count > $stemmaid ) {
442 $stemma = $tradition->stemma( $stemmaid );
444 my $stemma_xml = $stemma ? $stemma->as_svg() : '';
445 # What was requested, XML or JSON?
446 my $return_view = 'SVG';
447 if( my $accept_header = $c->req->header('Accept') ) {
448 $c->log->debug( "Received Accept header: $accept_header" );
449 foreach my $type ( split( /,\s*/, $accept_header ) ) {
450 # If we were first asked for XML, return SVG
451 last if $type =~ /^(application|text)\/xml$/;
452 # If we were first asked for JSON, return JSON
453 if( $type eq 'application/json' ) {
454 $return_view = 'JSON';
459 if( $return_view eq 'SVG' ) {
460 $c->stash->{'result'} = $stemma_xml;
461 $c->forward('View::SVG');
463 $stemma_xml =~ s/\n/ /mg;
464 $c->stash->{'result'} = {
465 'stemmaid' => $stemmaid,
466 'name' => $stemma->identifier,
467 'directed' => _json_bool( !$stemma->is_undirected ),
468 'svg' => $stemma_xml };
469 $c->forward('View::JSON');
475 GET /stemmadot/$textid/$stemmaseq
477 Returns the 'dot' format representation of the current stemma hypothesis.
481 sub stemmadot :Local :Args(2) {
482 my( $self, $c, $textid, $stemmaid ) = @_;
483 my $m = $c->model('Directory');
484 my $tradition = $m->tradition( $textid );
485 unless( $tradition ) {
486 return _json_error( $c, 404, "No tradition with ID $textid" );
488 my $ok = _check_permission( $c, $tradition );
490 my $stemma = $tradition->stemma( $stemmaid );
492 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
494 # Get the dot and transmute its line breaks to literal '|n'
495 $c->stash->{'result'} = { 'dot' => $stemma->editable( { linesep => '|n' } ) };
496 $c->forward('View::JSON');
501 GET /download/$textid
503 Returns the full XML definition of the tradition and its stemmata, if any.
507 sub download :Local :Args(1) {
508 my( $self, $c, $textid ) = @_;
509 my $tradition = $c->model('Directory')->tradition( $textid );
510 unless( $tradition ) {
511 return _json_error( $c, 404, "No tradition with ID $textid" );
513 my $ok = _check_permission( $c, $tradition );
516 $c->stash->{'result'} = $tradition->collation->as_graphml();
517 } catch( Text::Tradition::Error $e ) {
518 return _json_error( $c, 500, $e->message );
520 $c->forward('View::GraphML');
527 # Helper to check what permission, if any, the active user has for
528 # the given tradition
529 sub _check_permission {
530 my( $c, $tradition ) = @_;
531 my $user = $c->user_exists ? $c->user->get_object : undef;
533 return 'full' if ( $user->is_admin ||
534 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
536 # Text doesn't belong to us, so maybe it's public?
537 return 'readonly' if $tradition->public;
539 # ...nope. Forbidden!
540 return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
543 # Helper to throw a JSON exception
545 my( $c, $code, $errmsg ) = @_;
546 $c->response->status( $code );
547 $c->stash->{'result'} = { 'error' => $errmsg };
548 $c->forward('View::JSON');
553 return $_[0] ? JSON::true : JSON::false;
558 Standard 404 error page
563 my ( $self, $c ) = @_;
564 $c->response->body( 'Page not found' );
565 $c->response->status(404);
570 Attempt to render a view, if needed.
574 sub end : ActionClass('RenderView') {}
582 This library is free software. You can redistribute it and/or modify
583 it under the same terms as Perl itself.
587 __PACKAGE__->meta->make_immutable;