1 package stemmaweb::Controller::Relation;
2 use JSON qw/ to_json from_json /;
4 use Moose::Util::TypeConstraints qw/ find_type_constraint /;
6 use namespace::autoclean;
7 use Text::Tradition::Datatypes;
10 BEGIN { extends 'Catalyst::Controller' }
14 stemmaweb::Controller::Relation - Controller for the relationship mapper
18 The reading relationship mapper with draggable nodes.
26 Renders the application for the text identified by $textid.
30 sub index :Path :Args(0) {
32 $c->stash->{'template'} = 'relate.tt';
39 Runs the relationship mapper for the specified text ID.
43 sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
44 my( $self, $c, $textid ) = @_;
45 my $tradition = $c->model('Directory')->tradition( $textid );
46 unless( $tradition ) {
47 $c->response->status('404');
48 $c->response->body("No such tradition with ID $textid");
49 $c->detach('View::Plain');
53 # Account for a bad interaction between FastCGI and KiokuDB
54 unless( $tradition->collation->tradition ) {
55 $c->log->warn( "Fixing broken tradition link" );
56 $tradition->collation->_set_tradition( $tradition );
57 $c->model('Directory')->save( $tradition );
59 # Check permissions. Will return 403 if denied, otherwise will
60 # put the appropriate value in the stash.
61 my $ok = _check_permission( $c, $tradition );
64 $c->stash->{'textid'} = $textid;
65 $c->stash->{'tradition'} = $tradition;
68 sub main :Chained('text') :PathPart('') :Args(0) {
70 my $tradition = delete $c->stash->{'tradition'};
71 my $collation = $tradition->collation;
73 # Stash text direction to use in JS.
74 $c->stash->{'direction'} = $collation->direction;
76 # Stash the relationship definitions
77 $c->stash->{'relationship_scopes'} =
78 to_json( find_type_constraint( 'RelationshipScope' )->values );
79 $c->stash->{'ternary_values'} =
80 to_json( find_type_constraint( 'Ternary' )->values );
82 foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
83 next if $type->is_weak;
84 my $struct = { name => $type->name, description => $type->description };
85 push( @reltypeinfo, $struct );
87 $c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
89 # See how big the tradition is. Edges are more important than nodes
90 # when it comes to rendering difficulty.
91 my $numnodes = scalar $collation->readings;
92 my $numedges = scalar $collation->paths;
93 my $length = $collation->end->rank;
94 # We should display no more than roughly 500 nodes, or roughly 700
96 my $segments = $numnodes / 500;
97 if( $numedges / 700 > $segments ) {
98 $segments = $numedges / 700;
100 my $segsize = sprintf( "%.0f", $length / $segments );
101 my $margin = sprintf( "%.0f", $segsize / 10 );
102 if( $segments > 1 ) {
103 # Segment the tradition in order not to overload the browser.
106 while( $r + $margin < $length ) {
110 $c->stash->{'textsegments'} = [];
111 foreach my $i ( 0..$#divs ) {
112 my $seg = { 'start' => $divs[$i] };
113 $seg->{'display'} = "Segment " . ($i+1);
114 push( @{$c->stash->{'textsegments'}}, $seg );
117 my $startseg = $c->req->param('start');
120 # Only render the subgraph from startseg to endseg or to END,
122 my $endseg = $startseg + $segsize + $margin;
123 $svgopts = { 'from' => $startseg };
124 $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
125 } elsif( exists $c->stash->{'textsegments'} ) {
126 # This is the unqualified load of a long tradition. We implicitly start
127 # at zero, but go only as far as our segment size.
128 my $endseg = $segsize + $margin;
130 $svgopts = { 'to' => $endseg };
133 my $svg_str = $collation->as_svg( $svgopts );
134 $svg_str =~ s/\n//gs;
135 $c->stash->{'startseg'} = $startseg if defined $startseg;
136 $c->stash->{'svg_string'} = $svg_str;
137 $c->stash->{'text_title'} = $tradition->name;
138 if( $tradition->can('language') && $tradition->language ) {
139 $c->stash->{'text_lang'} = $tradition->language;
140 $c->stash->{'can_morphologize'} = 1;
142 $c->stash->{'text_lang'} = 'Default';
144 $c->stash->{'template'} = 'relate.tt';
149 my $blsort = $a->bindlevel <=> $b->bindlevel;
150 return $blsort if $blsort;
151 return $a->name cmp $b->name;
156 GET relation/help/$language
158 Returns the help window HTML.
162 sub help :Local :Args(1) {
163 my( $self, $c, $lang ) = @_;
164 # Display the morphological help for the language if it is defined.
165 if( $lang && $lang ne 'Default' ) {
166 my $mod = 'Text::Tradition::Language::' . $lang;
170 $c->log->debug("Warning: could not load $mod");
172 my $has_mod = $mod->can('morphology_tags');
174 my $tagset = &$has_mod;
175 $c->stash->{'tagset'} = $tagset;
178 $c->stash->{'template'} = 'relatehelp.tt';
183 GET relation/$textid/relationships
185 Returns the list of relationships defined for this text.
187 POST relation/$textid/relationships { request }
189 Attempts to define the requested relationship within the text. Returns 200 on
190 success or 403 on error.
192 DELETE relation/$textid/relationships { request }
197 sub relationships :Chained('text') :PathPart :Args(0) {
198 my( $self, $c ) = @_;
199 my $tradition = delete $c->stash->{'tradition'};
200 my $ok = _check_permission( $c, $tradition );
202 my $collation = $tradition->collation;
203 my $m = $c->model('Directory');
204 if( $c->request->method eq 'GET' ) {
205 my @pairs = $collation->relationships; # returns the edges
207 foreach my $p ( @pairs ) {
208 my $relobj = $collation->relations->get_relationship( @$p );
209 next if $relobj->type eq 'collated'; # Don't show these
210 next if $p->[0] eq $p->[1]; # HACK until bugfix
211 my $relhash = { source_id => $p->[0], target_id => $p->[1],
212 source_text => $collation->reading( $p->[0] )->text,
213 target_text => $collation->reading( $p->[1] )->text,
214 type => $relobj->type, scope => $relobj->scope,
215 a_derivable_from_b => $relobj->a_derivable_from_b,
216 b_derivable_from_a => $relobj->b_derivable_from_a,
217 non_independent => $relobj->non_independent,
218 is_significant => $relobj->is_significant
220 $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
221 push( @all_relations, $relhash );
223 $c->stash->{'result'} = \@all_relations;
225 # Check write permissions first of all
226 if( $c->stash->{'permission'} ne 'full' ) {
227 $c->response->status( '403' );
228 $c->stash->{'result'} = {
229 'error' => 'You do not have permission to modify this tradition.' };
230 $c->detach( 'View::JSON' );
231 } elsif( $c->request->method eq 'POST' ) {
232 my $opts = $c->request->params;
234 # Retrieve the source / target from the options
235 my $node = delete $opts->{source_id};
236 my $target = delete $opts->{target_id};
238 # Make sure we didn't send a blank or invalid relationship type
239 my $relation = $opts->{type};
240 unless( $collation->get_relationship_type( $relation ) ) {
241 my $errmsg = $relation ? "No such relationship type $relation" :
242 "You must specify a relationship type";
243 $c->stash->{'result'} = { error => $errmsg };
244 $c->response->status( '400' );
245 $c->detach( 'View::JSON' );
248 # Keep the data clean
249 my @booleans = qw/ a_derivable_from_b b_derivable_from_a non_independent /;
250 foreach my $k ( keys %$opts ) {
251 if( $opts->{$k} && grep { $_ eq $k } @booleans ) {
256 delete $opts->{scope} unless $opts->{scope};
257 delete $opts->{annotation} unless $opts->{annotation};
258 delete $opts->{is_significant} unless $opts->{is_significant};
259 $opts->{propagate} = 1;
262 my @vectors = $collation->add_relationship( $node, $target, $opts );
263 $c->stash->{'result'} = \@vectors;
264 $m->save( $tradition );
265 } catch( Text::Tradition::Error $e ) {
266 $c->response->status( '403' );
267 $c->stash->{'result'} = { error => $e->message };
269 $c->response->status( '500' );
270 $c->stash->{'result'} = { error => "Something went wrong with the request" };
272 } elsif( $c->request->method eq 'DELETE' ) {
273 my $node = $c->request->param('source_id');
274 my $target = $c->request->param('target_id');
275 my $scopewide = $c->request->param('scopewide')
276 && $c->request->param('scopewide') eq 'true';
278 my @vectors = $collation->del_relationship( $node, $target, $scopewide );
279 $m->save( $tradition );
280 $c->stash->{'result'} = \@vectors;
281 } catch( Text::Tradition::Error $e ) {
282 $c->response->status( '403' );
283 $c->stash->{'result'} = { 'error' => $e->message };
285 $c->response->status( '500' );
286 $c->stash->{'result'} = { error => "Something went wrong with the request" };
290 $c->forward('View::JSON');
295 GET relation/$textid/readings
297 Returns the list of readings defined for this text along with their metadata.
301 my %read_write_keys = (
305 'grammar_invalid' => 1,
310 sub _reading_struct {
312 # Return a JSONable struct of the useful keys. Keys meant to be writable
313 # have a true value; read-only keys have a false value.
315 map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
317 $struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
318 # Look up any words related via spelling or orthography
321 return $t eq 'spelling' || $t eq 'orthographic';
323 # Now add the list data
324 $struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
325 $struct->{'witnesses'} = [ $reading->witnesses ];
329 sub readings :Chained('text') :PathPart :Args(0) {
330 my( $self, $c ) = @_;
331 my $tradition = delete $c->stash->{'tradition'};
332 my $ok = _check_permission( $c, $tradition );
334 my $collation = $tradition->collation;
335 my $m = $c->model('Directory');
336 if( $c->request->method eq 'GET' ) {
338 foreach my $rdg ( $collation->readings ) {
339 $rdginfo->{$rdg->id} = _reading_struct( $rdg );
341 $c->stash->{'result'} = $rdginfo;
343 $c->forward('View::JSON');
348 GET relation/$textid/reading/$id
350 Returns the list of readings defined for this text along with their metadata.
352 POST relation/$textid/reading/$id { request }
354 Alters the reading according to the values in request. Returns 403 Forbidden if
355 the alteration isn't allowed.
359 sub reading :Chained('text') :PathPart :Args(1) {
360 my( $self, $c, $reading_id ) = @_;
361 my $tradition = delete $c->stash->{'tradition'};
362 my $collation = $tradition->collation;
363 my $rdg = $collation->reading( $reading_id );
364 my $m = $c->model('Directory');
365 if( $c->request->method eq 'GET' ) {
366 $c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
367 : { 'error' => "No reading with ID $reading_id" };
368 } elsif ( $c->request->method eq 'POST' ) {
369 if( $c->stash->{'permission'} ne 'full' ) {
370 $c->response->status( '403' );
371 $c->stash->{'result'} = {
372 'error' => 'You do not have permission to modify this tradition.' };
373 $c->detach('View::JSON');
377 if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
378 # Are we re-lemmatizing?
379 if( $c->request->param('relemmatize') ) {
380 my $nf = $c->request->param('normal_form');
381 # TODO throw error unless $nf
382 $rdg->normal_form( $nf );
383 # TODO throw error if lemmatization fails
384 # TODO skip this if normal form hasn't changed
387 # Set all the values that we have for the reading.
388 # TODO error handling
389 foreach my $p ( keys %{$c->request->params} ) {
390 if( $p =~ /^morphology_(\d+)$/ ) {
391 # Set the form on the correct lexeme
392 my $morphval = $c->request->param( $p );
393 next unless $morphval;
395 my $lx = $rdg->lexeme( $midx );
396 my $strrep = $rdg->language . ' // ' . $morphval;
397 my $idx = $lx->has_form( $strrep );
398 unless( defined $idx ) {
399 # Make the word form and add it to the lexeme.
401 $idx = $lx->add_matching_form( $strrep ) - 1;
402 } catch( Text::Tradition::Error $e ) {
403 $c->response->status( '403' );
404 $errmsg = $e->message;
406 # Something else went wrong, probably a Moose error
407 $c->response->status( '500' );
408 $errmsg = 'Something went wrong with the request';
411 $lx->disambiguate( $idx ) if defined $idx;
412 } elsif( $read_write_keys{$p} ) {
413 my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
420 $errmsg = "Reading does not exist or cannot be morphologized";
422 $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
423 : _reading_struct( $rdg );
426 $c->forward('View::JSON');
430 sub compress :Chained('text') :PathPart :Args(0) {
431 my( $self, $c ) = @_;
432 my $tradition = delete $c->stash->{'tradition'};
433 my $collation = $tradition->collation;
434 my $m = $c->model('Directory');
436 my @rids = $c->request->param('readings[]');
439 foreach my $rid (@rids) {
440 my $rdg = $collation->reading( $rid );
442 push @readings, $rdg;
445 my $len = scalar @readings;
447 if( $c->request->method eq 'POST' ) {
448 if( $c->stash->{'permission'} ne 'full' ) {
449 $c->response->status( '403' );
450 $c->stash->{'result'} = {
451 'error' => 'You do not have permission to modify this tradition.' };
452 $c->detach('View::JSON');
456 # Sanity check: first save the original text of each witness.
458 foreach my $wit ( $tradition->witnesses ) {
459 $origtext{$wit->sigil} = $collation->path_text( $wit->sigil );
460 if( $wit->is_layered ) {
461 my $acsig = $wit->sigil . $collation->ac_label;
462 $origtext{$acsig} = $collation->path_text( $acsig );
468 for (my $i = 0; $i < $len; $i++) {
469 my $rdg = $readings[$i];
471 if ($rdg->is_combinable) {
478 push @nodes, "$readings[$first]";
480 for (my $i = $first+1; $i < $len; $i++) {
481 my $rdg = $readings[$first];
482 my $next = $readings[$i];
484 last unless $next->is_combinable;
485 push @nodes, "$next";
488 $collation->merge_readings( "$rdg", "$next", 1 );
490 $c->stash->{result} = {
491 error_msg => $e->message,
494 $c->detach('View::JSON');
499 # Finally, make sure we haven't screwed anything up.
500 foreach my $wit ( $tradition->witnesses ) {
501 my $pathtext = $collation->path_text( $wit->sigil );
502 Text::Tradition::Error->throw_collation_error( "Text differs for witness " . $wit->sigil )
503 unless $pathtext eq $origtext{$wit->sigil};
504 if( $wit->is_layered ) {
505 my $acsig = $wit->sigil . $collation->ac_label;
506 $pathtext = $collation->path_text( $acsig );
507 Text::Tradition::Error->throw_collation_error( "Layered text differs for witness " . $wit->sigil )
508 unless $pathtext eq $origtext{$acsig};
511 } catch (Text::Tradition::Error $e) {
512 $c->stash->{result} = {
513 error_msg => $e->message,
516 $c->detach('View::JSON');
520 $collation->relations->rebuild_equivalence();
521 $collation->calculate_ranks();
523 $m->save($collation);
525 if ($collation->direction eq 'RL') {
526 @nodes = reverse @nodes;
529 $c->stash->{'result'} = {
534 $c->forward('View::JSON');
540 POST relation/$textid/merge { data }
542 Merges the requested readings, combining the witnesses of both readings into
543 the target reading. All non-conflicting source relationships are inherited by
544 the target relationship.
548 sub merge :Chained('text') :PathPart :Args(0) {
549 my( $self, $c ) = @_;
550 my $tradition = delete $c->stash->{'tradition'};
551 my $collation = $tradition->collation;
552 my $m = $c->model('Directory');
553 if( $c->request->method eq 'POST' ) {
554 if( $c->stash->{'permission'} ne 'full' ) {
555 $c->response->status( '403' );
556 $c->stash->{'result'} = {
557 'error' => 'You do not have permission to modify this tradition.' };
558 $c->detach('View::JSON');
564 my $main = $c->request->param('target_id');
565 my $second = $c->request->param('source_id');
566 # Find the common successor of these, so that we can detect other
567 # potentially identical readings.
568 my $csucc = $collation->common_successor( $main, $second );
570 # Try the merge if these are parallel readings.
571 if( $csucc->id eq $main || $csucc->id eq $second ) {
572 $errmsg = "Cannot merge readings in the same path";
575 $collation->merge_readings( $main, $second );
576 } catch( Text::Tradition::Error $e ) {
577 $c->response->status( '403' );
578 $errmsg = $e->message;
580 # Something else went wrong, probably a Moose error
581 $c->response->status( '403' );
582 $errmsg = 'Something went wrong with the request';
586 # Look for readings that are now identical.
588 $response = { status => 'error', error => $errmsg };
590 $response = { status => 'ok' };
591 unless( $c->request->param('single') ) {
592 my @identical = $collation->identical_readings(
593 start => $main, end => $csucc->id );
595 $response->{'checkalign'} = [
596 map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
599 $m->save( $collation );
601 $c->stash->{'result'} = $response;
602 $c->forward('View::JSON');
608 POST relation/$textid/duplicate { data }
610 Duplicates the requested readings, detaching the witnesses specified in
611 the list to use the new reading(s) instead of the old. The data to be
612 passed should be a JSON structure:
614 { readings: rid1,rid2,rid3,...
615 witnesses: [ wit1, ... ] }
619 sub duplicate :Chained('text') :PathPart :Args(0) {
620 my( $self, $c ) = @_;
621 my $tradition = delete $c->stash->{'tradition'};
622 my $collation = $tradition->collation;
623 my $m = $c->model('Directory');
624 if( $c->request->method eq 'POST' ) {
625 if( $c->stash->{'permission'} ne 'full' ) {
626 $c->response->status( '403' );
627 $c->stash->{'result'} = {
628 'error' => 'You do not have permission to modify this tradition.' };
629 $c->detach('View::JSON');
634 # Sort out which readings need to be duplicated from the set given, and
635 # ensure that all the given wits bear each relevant reading.
638 map { $wits{$_} = 1 } $c->request->param('witnesses[]');
640 foreach my $rid ( $c->request->param('readings[]') ) {
642 my $rdg = $collation->reading( $rid );
643 foreach my $rwit ( $rdg->witnesses( $rid ) ) {
644 $numwits++ if exists $wits{$rwit};
646 next unless $numwits; # Disregard readings with none of our witnesses
647 if( $numwits < keys( %wits ) ) {
648 $errmsg = "Reading $rid contains some but not all of the specified witnesses.";
650 } elsif( exists $rdgranks{ $rdg->rank } ) {
651 $errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
654 $rdgranks{ $rdg->rank } = $rid;
658 # Now check that the readings make a single sequence.
661 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
662 my $rid = $rdgranks{$rank};
664 # Check that there is only one path between $prior and $rdg.
665 foreach my $wit ( keys %wits ) {
666 unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
667 $errmsg = "Diverging witness paths from $prior to $rid at $wit";
676 # Abort if we've run into a problem.
678 $c->stash->{'result'} = { 'error' => $errmsg };
679 $c->response->status( '403' );
680 $c->forward('View::JSON');
684 # Otherwise, do the dirty work.
685 my @witlist = keys %wits;
686 my @deleted_relations;
687 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
689 my $reading_id = $rdgranks{$rank};
692 ( $newrdg, @delrels ) =
693 $collation->duplicate_reading( $reading_id, @witlist );
694 } catch( Text::Tradition::Error $e ) {
695 $c->response->status( '403' );
696 $errmsg = $e->message;
698 # Something else went wrong, probably a Moose error
699 $c->response->status( '500' );
700 $errmsg = 'Something went wrong with the request';
703 my $data = _reading_struct( $newrdg );
704 $data->{'orig_rdg'} = $reading_id;
705 $response->{"$newrdg"} = $data;
706 push( @deleted_relations, @delrels );
710 $c->stash->{'result'} = { 'error' => $errmsg };
712 $m->save( $collation );
713 $response->{'DELETED'} = \@deleted_relations;
714 $c->stash->{'result'} = $response;
717 $c->forward('View::JSON');
722 sub _check_permission {
723 my( $c, $tradition ) = @_;
724 my $user = $c->user_exists ? $c->user->get_object : undef;
725 # Does this user have access?
727 if( $user->is_admin ||
728 ( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
729 $c->stash->{'permission'} = 'full';
734 if( $tradition->public ) {
735 $c->stash->{'permission'} = 'readonly';
739 $c->response->status( 403 );
740 $c->response->body( 'You do not have permission to view this tradition.' );
741 $c->detach( 'View::Plain' );
745 sub _clean_booleans {
746 my( $obj, $param, $val ) = @_;
747 if( $obj->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
748 $val = 1 if $val eq 'true';
749 $val = undef if $val eq 'false';
756 Attempt to render a view, if needed.
760 sub end : ActionClass('RenderView') {}
768 This library is free software. You can redistribute it and/or modify
769 it under the same terms as Perl itself.
773 __PACKAGE__->meta->make_immutable;