initial attempt at providing stemma title/label
[scpubgit/stemmaweb.git] / lib / stemmaweb / Controller / Root.pm
CommitLineData
b8a92065 1package stemmaweb::Controller::Root;
2use Moose;
3use namespace::autoclean;
4use Text::Tradition::Analysis qw/ run_analysis /;
41279a86 5use TryCatch;
16143416 6use XML::LibXML;
7use XML::LibXML::XPathContext;
b8a92065 8
9
10BEGIN { 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
20stemmaweb::Controller::Root - Root Controller for stemmaweb
21
22=head1 DESCRIPTION
23
24Serves up the main container pages.
25
26=head1 URLs
27
28=head2 index
29
30The root page (/). Serves the main container page, from which the various
31components will be loaded.
32
33=cut
34
35sub index :Path :Args(0) {
36 my ( $self, $c ) = @_;
37
c655153c 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 }
b8a92065 42 $c->stash->{template} = 'index.tt';
43}
44
3f9d7ae5 45=head2 about
46
47A general overview/documentation page for the site.
48
49=cut
50
51sub about :Local :Args(0) {
52 my( $self, $c ) = @_;
53 $c->stash->{template} = 'about.tt';
54}
55
4a6b658f 56=head2 help/*
57
58A dispatcher for documentation of various aspects of the application.
59
60=cut
61
62sub help :Local :Args(1) {
63 my( $self, $c, $topic ) = @_;
64 $c->stash->{template} = "$topic.tt";
65}
66
b8a92065 67=head1 Elements of index page
68
69=head2 directory
70
71 GET /directory
72
70ccaf75 73Serves 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.
b8a92065 74
75=cut
70ccaf75 76
b8a92065 77sub directory :Local :Args(0) {
78 my( $self, $c ) = @_;
79 my $m = $c->model('Directory');
69799996 80 # Is someone logged in?
98a45925 81 my %usertexts;
69799996 82 if( $c->user_exists ) {
83 my $user = $c->user->get_object;
98a45925 84 my @list = $m->traditionlist( $user );
85 map { $usertexts{$_->{id}} = 1 } @list;
86 $c->stash->{usertexts} = \@list;
69799996 87 $c->stash->{is_admin} = 1 if $user->is_admin;
88 }
98a45925 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;
b8a92065 94 $c->stash->{template} = 'directory.tt';
95}
96
75354c3a 97=head1 AJAX methods for traditions and their properties
fb6e49b3 98
75354c3a 99=head2 newtradition
100
101 POST /newtradition,
102 { name: <name>,
103 language: <language>,
104 public: <is_public>,
2ece58b3 105 file: <fileupload> }
fb6e49b3 106
75354c3a 107Creates a new tradition belonging to the logged-in user, with the given name
108and the collation given in the uploaded file. The file type is indicated via
109the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and
110name of the new tradition.
111
112=cut
113
114sub 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).
2ece58b3 122 my $upload = $c->request->upload('file');
75354c3a 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;
2ece58b3 126 my( $ext ) = $upload->filename =~ /\.(\w+)$/;
75354c3a 127 my %newopts = (
128 'name' => $name,
129 'language' => $lang,
130 'public' => $public,
2ece58b3 131 'file' => $upload->tempname
75354c3a 132 );
133
134 my $tradition;
135 my $errmsg;
136 if( $ext eq 'xml' ) {
16143416 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;
75354c3a 165 try {
166 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
167 } catch ( Text::Tradition::Error $e ) {
168 $errmsg = $e->message;
16143416 169 } catch ( $e ) {
170 $errmsg = "Unexpected parsing error: $e";
699ab7ea 171 }
75354c3a 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;
16143416 188 } catch ( $e ) {
189 $errmsg = "Unexpected parsing error: $e";
75354c3a 190 }
191 } else {
192 # Error unless we have a recognized filename extension
2bfac197 193 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
75354c3a 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
221Returns information about a particular text.
fb6e49b3 222
223=cut
224
75354c3a 225sub textinfo :Local :Args(1) {
fb6e49b3 226 my( $self, $c, $textid ) = @_;
98a45925 227 my $tradition = $c->model('Directory')->tradition( $textid );
6978962f 228 ## Have to keep users in the same scope as tradition
229 my $newuser;
230 my $olduser;
75354c3a 231 unless( $tradition ) {
2bfac197 232 return _json_error( $c, 404, "No tradition with ID $textid" );
75354c3a 233 }
41279a86 234 my $ok = _check_permission( $c, $tradition );
235 return unless $ok;
75354c3a 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;
ce1c5863 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 );
75354c3a 250 $changed = 1;
ce1c5863 251 } catch {
252 return _json_error( $c, 500, "Error setting name to $newname" );
75354c3a 253 }
254 }
255 }
ce1c5863 256 # Handle language param, making Default => null
257 my $langval = delete $params->{language} || 'Default';
ed2aaedb 258
259 unless( $tradition->language eq $langval || !$tradition->can('language') ) {
ce1c5863 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
75354c3a 268 # Handle our boolean
ce1c5863 269 my $ispublic = $tradition->public;
75354c3a 270 if( delete $params->{'public'} ) { # if it's any true value...
271 $tradition->public( 1 );
ce1c5863 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;
75354c3a 276 }
ce1c5863 277
278 # Handle ownership change
75354c3a 279 if( exists $params->{'owner'} ) {
280 # Only admins can update user / owner
281 my $newownerid = delete $params->{'owner'};
16a7dd1f 282 if( $tradition->has_user && !$tradition->user ) {
283 $tradition->clear_user;
284 }
4f849eea 285 unless( !$newownerid ||
6978962f 286 ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) {
75354c3a 287 unless( $c->user->get_object->is_admin ) {
288 return _json_error( $c, 403,
289 "Only admin users can change tradition ownership" );
290 }
6978962f 291 $newuser = $m->find_user({ email => $newownerid });
75354c3a 292 unless( $newuser ) {
ce1c5863 293 return _json_error( $c, 500, "No such user " . $newownerid );
75354c3a 294 }
6978962f 295 if( $tradition->has_user ) {
296 $olduser = $tradition->user;
297 $olduser->remove_tradition( $tradition );
298 }
75354c3a 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 }
41279a86 312
75354c3a 313 # Now return the current textinfo, whether GET or successful POST.
314 my $textinfo = {
315 textid => $textid,
316 name => $tradition->name,
ed2aaedb 317 #language => $tradition->language,
e0b90236 318 public => $tradition->public || 0,
2ece58b3 319 owner => $tradition->user ? $tradition->user->email : undef,
75354c3a 320 witnesses => [ map { $_->sigil } $tradition->witnesses ],
321 };
ed2aaedb 322 if( $tradition->can('language') ) {
323 $textinfo->{'language'} = $tradition->language;
324 }
ec2f89ff 325 my @stemmasvg = map { { name => $_->identifier, svg => $_->as_svg() } }
326 $tradition->stemmata;
75354c3a 327 map { $_ =~ s/\n/ /mg } @stemmasvg;
328 $textinfo->{stemmata} = \@stemmasvg;
329 $c->stash->{'result'} = $textinfo;
330 $c->forward('View::JSON');
fb6e49b3 331}
b8a92065 332
75354c3a 333=head2 variantgraph
b8a92065 334
75354c3a 335 GET /variantgraph/$textid
336
337Returns the variant graph for the text specified at $textid, in SVG form.
b8a92065 338
339=cut
340
75354c3a 341sub variantgraph :Local :Args(1) {
b8a92065 342 my( $self, $c, $textid ) = @_;
98a45925 343 my $tradition = $c->model('Directory')->tradition( $textid );
75354c3a 344 unless( $tradition ) {
2bfac197 345 return _json_error( $c, 404, "No tradition with ID $textid" );
75354c3a 346 }
41279a86 347 my $ok = _check_permission( $c, $tradition );
348 return unless $ok;
349
98a45925 350 my $collation = $tradition->collation;
75354c3a 351 $c->stash->{'result'} = $collation->as_svg;
352 $c->forward('View::SVG');
b8a92065 353}
75354c3a 354
b8a92065 355=head2 stemma
356
75354c3a 357 GET /stemma/$textid/$stemmaseq
358 POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
b8a92065 359
75354c3a 360Returns an SVG representation of the given stemma hypothesis for the text.
361If the URL is called with POST, the stemma at $stemmaseq will be altered
362to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
363stemma will be added.
b8a92065 364
365=cut
366
75354c3a 367sub stemma :Local :Args(2) {
41279a86 368 my( $self, $c, $textid, $stemmaid ) = @_;
b8a92065 369 my $m = $c->model('Directory');
370 my $tradition = $m->tradition( $textid );
75354c3a 371 unless( $tradition ) {
2bfac197 372 return _json_error( $c, 404, "No tradition with ID $textid" );
75354c3a 373 }
41279a86 374 my $ok = _check_permission( $c, $tradition );
375 return unless $ok;
376
41279a86 377 $c->stash->{'result'} = '';
75354c3a 378 my $stemma;
379 if( $c->req->method eq 'POST' ) {
380 if( $ok eq 'full' ) {
41279a86 381 my $dot = $c->request->body_params->{'dot'};
174e78df 382 # Graph::Reader::Dot does not handle bare unicode. We get around this
4770d077 383 # by wrapping all words in double quotes, as long as they aren't already
384 # wrapped, and as long as they aren't the initial 'digraph stemma'.
385 # Horrible HACK.
386 $dot =~ s/(?<!")\b(?!(?:digraph|stemma)\b)(\w+)\b(?!")/"$1"/g;
75354c3a 387 try {
388 if( $stemmaid eq 'n' ) {
389 # We are adding a new stemma.
3f7346b1 390 $stemmaid = $tradition->stemma_count;
75354c3a 391 $stemma = $tradition->add_stemma( 'dot' => $dot );
2bfac197 392 } elsif( $stemmaid !~ /^\d+$/ ) {
393 return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
75354c3a 394 } elsif( $stemmaid < $tradition->stemma_count ) {
395 # We are updating an existing stemma.
396 $stemma = $tradition->stemma( $stemmaid );
397 $stemma->alter_graph( $dot );
398 } else {
399 # Unrecognized stemma ID
2bfac197 400 return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
75354c3a 401 }
402 } catch ( Text::Tradition::Error $e ) {
403 return _json_error( $c, 500, $e->message );
404 }
41279a86 405 $m->store( $tradition );
75354c3a 406 } else {
407 # No permissions to update the stemma
408 return _json_error( $c, 403,
409 'You do not have permission to update stemmata for this tradition' );
41279a86 410 }
b8a92065 411 }
75354c3a 412
413 # For a GET or a successful POST request, return the SVG representation
414 # of the stemma in question, if any.
75354c3a 415 if( !$stemma && $tradition->stemma_count > $stemmaid ) {
416 $stemma = $tradition->stemma( $stemmaid );
417 }
2923ebb1 418 my $stemma_xml = $stemma ? $stemma->as_svg() : '';
ce1c5863 419 # What was requested, XML or JSON?
420 my $return_view = 'SVG';
421 if( my $accept_header = $c->req->header('Accept') ) {
422 $c->log->debug( "Received Accept header: $accept_header" );
423 foreach my $type ( split( /,\s*/, $accept_header ) ) {
424 # If we were first asked for XML, return SVG
425 last if $type =~ /^(application|text)\/xml$/;
426 # If we were first asked for JSON, return JSON
427 if( $type eq 'application/json' ) {
428 $return_view = 'JSON';
429 last;
430 }
431 }
432 }
433 if( $return_view eq 'SVG' ) {
434 $c->stash->{'result'} = $stemma_xml;
435 $c->forward('View::SVG');
436 } else { # JSON
437 $stemma_xml =~ s/\n/ /mg;
438 $c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml };
439 $c->forward('View::JSON');
440 }
b8a92065 441}
442
443=head2 stemmadot
444
75354c3a 445 GET /stemmadot/$textid/$stemmaseq
b8a92065 446
447Returns the 'dot' format representation of the current stemma hypothesis.
448
449=cut
450
75354c3a 451sub stemmadot :Local :Args(2) {
452 my( $self, $c, $textid, $stemmaid ) = @_;
b8a92065 453 my $m = $c->model('Directory');
454 my $tradition = $m->tradition( $textid );
75354c3a 455 unless( $tradition ) {
2bfac197 456 return _json_error( $c, 404, "No tradition with ID $textid" );
75354c3a 457 }
41279a86 458 my $ok = _check_permission( $c, $tradition );
459 return unless $ok;
75354c3a 460 my $stemma = $tradition->stemma( $stemmaid );
461 unless( $stemma ) {
2bfac197 462 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
75354c3a 463 }
464 # Get the dot and transmute its line breaks to literal '|n'
465 $c->stash->{'result'} = { 'dot' => $stemma->editable( { linesep => '|n' } ) };
41279a86 466 $c->forward('View::JSON');
467}
468
38627d20 469=head2 download
470
471 GET /download/$textid
472
473Returns the full XML definition of the tradition and its stemmata, if any.
474
475=cut
476
477sub download :Local :Args(1) {
478 my( $self, $c, $textid ) = @_;
479 my $tradition = $c->model('Directory')->tradition( $textid );
480 unless( $tradition ) {
481 return _json_error( $c, 404, "No tradition with ID $textid" );
482 }
483 my $ok = _check_permission( $c, $tradition );
484 return unless $ok;
485 try {
486 $c->stash->{'result'} = $tradition->collation->as_graphml();
487 } catch( Text::Tradition::Error $e ) {
488 return _json_error( $c, 500, $e->message );
489 }
490 $c->forward('View::GraphML');
491}
492
75354c3a 493####################
494### Helper functions
495####################
41279a86 496
75354c3a 497# Helper to check what permission, if any, the active user has for
498# the given tradition
41279a86 499sub _check_permission {
500 my( $c, $tradition ) = @_;
501 my $user = $c->user_exists ? $c->user->get_object : undef;
502 if( $user ) {
929ba7c8 503 return 'full' if ( $user->is_admin ||
504 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
080f8a02 505 }
506 # Text doesn't belong to us, so maybe it's public?
507 return 'readonly' if $tradition->public;
508
509 # ...nope. Forbidden!
75354c3a 510 return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
511}
512
513# Helper to throw a JSON exception
514sub _json_error {
515 my( $c, $code, $errmsg ) = @_;
516 $c->response->status( $code );
517 $c->stash->{'result'} = { 'error' => $errmsg };
518 $c->forward('View::JSON');
929ba7c8 519 return 0;
41279a86 520}
521
b8a92065 522=head2 default
523
524Standard 404 error page
525
526=cut
527
528sub default :Path {
529 my ( $self, $c ) = @_;
530 $c->response->body( 'Page not found' );
531 $c->response->status(404);
532}
533
534=head2 end
535
536Attempt to render a view, if needed.
537
538=cut
539
540sub end : ActionClass('RenderView') {}
541
542=head1 AUTHOR
543
544Tara L Andrews
545
546=head1 LICENSE
547
548This library is free software. You can redistribute it and/or modify
549it under the same terms as Perl itself.
550
551=cut
552
553__PACKAGE__->meta->make_immutable;
554
5551;