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' }
15 stemmaweb::Controller::Relation - Controller for the relationship mapper
19 The reading relationship mapper with draggable nodes.
27 Renders the application for the text identified by $textid.
31 sub index :Path :Args(0) {
33 $c->stash->{'template'} = 'relate.tt';
40 Runs the relationship mapper for the specified text ID.
44 sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
45 my( $self, $c, $textid ) = @_;
46 my $tradition = $c->model('Directory')->tradition( $textid );
47 unless( $tradition ) {
48 $c->response->status('404');
49 $c->response->body("No such tradition with ID $textid");
50 $c->detach('View::Plain');
54 # Account for a bad interaction between FastCGI and KiokuDB
55 unless( $tradition->collation->tradition ) {
56 $c->log->warn( "Fixing broken tradition link" );
57 $tradition->collation->_set_tradition( $tradition );
58 $c->model('Directory')->save( $tradition );
60 # Check permissions. Will return 403 if denied, otherwise will
61 # put the appropriate value in the stash.
62 my $ok = _check_permission( $c, $tradition );
65 $c->stash->{'textid'} = $textid;
66 $c->stash->{'tradition'} = $tradition;
69 sub main :Chained('text') :PathPart('') :Args(0) {
71 my $tradition = delete $c->stash->{'tradition'};
72 my $collation = $tradition->collation;
74 # Stash text direction to use in JS.
75 $c->stash->{'direction'} = $collation->direction;
77 # Stash the relationship definitions
78 $c->stash->{'relationship_scopes'} =
79 to_json( find_type_constraint( 'RelationshipScope' )->values );
80 $c->stash->{'ternary_values'} =
81 to_json( find_type_constraint( 'Ternary' )->values );
83 foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
84 next if $type->is_weak;
85 my $struct = { name => $type->name, description => $type->description };
86 push( @reltypeinfo, $struct );
88 $c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
90 # See how big the tradition is. Edges are more important than nodes
91 # when it comes to rendering difficulty.
92 my $numnodes = scalar $collation->readings;
93 my $numedges = scalar $collation->paths;
94 my $length = $collation->end->rank;
95 # We should display no more than roughly 500 nodes, or roughly 700
97 my $segments = $numnodes / 500;
98 if( $numedges / 700 > $segments ) {
99 $segments = $numedges / 700;
101 my $segsize = sprintf( "%.0f", $length / $segments );
102 my $margin = sprintf( "%.0f", $segsize / 10 );
103 if( $segments > 1 ) {
104 # Segment the tradition in order not to overload the browser.
107 while( $r + $margin < $length ) {
111 $c->stash->{'textsegments'} = [];
112 foreach my $i ( 0..$#divs ) {
113 my $seg = { 'start' => $divs[$i] };
114 $seg->{'display'} = "Segment " . ($i+1);
115 push( @{$c->stash->{'textsegments'}}, $seg );
118 my $startseg = $c->req->param('start');
121 # Only render the subgraph from startseg to endseg or to END,
123 my $endseg = $startseg + $segsize + $margin;
124 $svgopts = { 'from' => $startseg };
125 $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
126 } elsif( exists $c->stash->{'textsegments'} ) {
127 # This is the unqualified load of a long tradition. We implicitly start
128 # at zero, but go only as far as our segment size.
129 my $endseg = $segsize + $margin;
131 $svgopts = { 'to' => $endseg };
134 my $svg_str = $collation->as_svg( $svgopts );
135 $svg_str =~ s/\n//gs;
136 $c->stash->{'startseg'} = $startseg if defined $startseg;
137 $c->stash->{'svg_string'} = $svg_str;
138 $c->stash->{'text_title'} = $tradition->name;
139 if( $tradition->can('language') && $tradition->language ) {
140 $c->stash->{'text_lang'} = $tradition->language;
141 $c->stash->{'can_morphologize'} = 1;
143 $c->stash->{'text_lang'} = 'Default';
145 $c->stash->{'template'} = 'relate.tt';
150 my $blsort = $a->bindlevel <=> $b->bindlevel;
151 return $blsort if $blsort;
152 return $a->name cmp $b->name;
157 GET relation/help/$language
159 Returns the help window HTML.
163 sub help :Local :Args(1) {
164 my( $self, $c, $lang ) = @_;
165 # Display the morphological help for the language if it is defined.
166 if( $lang && $lang ne 'Default' ) {
167 my $mod = 'Text::Tradition::Language::' . $lang;
171 $c->log->debug("Warning: could not load $mod");
173 my $has_mod = $mod->can('morphology_tags');
175 my $tagset = &$has_mod;
176 $c->stash->{'tagset'} = $tagset;
179 $c->stash->{'template'} = 'relatehelp.tt';
184 GET relation/$textid/relationships
186 Returns the list of relationships defined for this text.
188 POST relation/$textid/relationships { request }
190 Attempts to define the requested relationship within the text. Returns 200 on
191 success or 403 on error.
193 DELETE relation/$textid/relationships { request }
198 sub relationships :Chained('text') :PathPart :Args(0) {
199 my( $self, $c ) = @_;
200 my $tradition = delete $c->stash->{'tradition'};
201 my $ok = _check_permission( $c, $tradition );
203 my $collation = $tradition->collation;
204 my $m = $c->model('Directory');
205 if( $c->request->method eq 'GET' ) {
206 my @pairs = $collation->relationships; # returns the edges
208 foreach my $p ( @pairs ) {
209 my $relobj = $collation->relations->get_relationship( @$p );
210 next if $relobj->type eq 'collated'; # Don't show these
211 next if $p->[0] eq $p->[1]; # HACK until bugfix
212 my $relhash = { source_id => $p->[0], target_id => $p->[1],
213 source_text => $collation->reading( $p->[0] )->text,
214 target_text => $collation->reading( $p->[1] )->text,
215 type => $relobj->type, scope => $relobj->scope,
216 a_derivable_from_b => $relobj->a_derivable_from_b,
217 b_derivable_from_a => $relobj->b_derivable_from_a,
218 non_independent => $relobj->non_independent,
219 is_significant => $relobj->is_significant
221 $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
222 push( @all_relations, $relhash );
224 $c->stash->{'result'} = \@all_relations;
226 # Check write permissions first of all
227 if( $c->stash->{'permission'} ne 'full' ) {
228 $c->response->status( '403' );
229 $c->stash->{'result'} = {
230 'error' => 'You do not have permission to modify this tradition.' };
231 $c->detach( 'View::JSON' );
232 } elsif( $c->request->method eq 'POST' ) {
233 my $opts = $c->request->params;
235 # Retrieve the source / target from the options
236 my $node = delete $opts->{source_id};
237 my $target = delete $opts->{target_id};
239 # Make sure we didn't send a blank or invalid relationship type
240 my $relation = $opts->{type};
241 unless( $collation->get_relationship_type( $relation ) ) {
242 my $errmsg = $relation ? "No such relationship type $relation" :
243 "You must specify a relationship type";
244 $c->stash->{'result'} = { error => $errmsg };
245 $c->response->status( '400' );
246 $c->detach( 'View::JSON' );
249 # Keep the data clean
250 my @booleans = qw/ a_derivable_from_b b_derivable_from_a non_independent /;
251 foreach my $k ( keys %$opts ) {
252 if( $opts->{$k} && grep { $_ eq $k } @booleans ) {
257 delete $opts->{scope} unless $opts->{scope};
258 delete $opts->{annotation} unless $opts->{annotation};
259 delete $opts->{is_significant} unless $opts->{is_significant};
260 $opts->{propagate} = 1;
263 my @vectors = $collation->add_relationship( $node, $target, $opts );
264 $c->stash->{'result'} = \@vectors;
265 $m->save( $tradition );
266 } catch( Text::Tradition::Error $e ) {
267 $c->response->status( '403' );
268 $c->stash->{'result'} = { error => $e->message };
270 $c->response->status( '500' );
271 $c->stash->{'result'} = { error => "Something went wrong with the request" };
273 } elsif( $c->request->method eq 'DELETE' ) {
274 my $node = $c->request->param('source_id');
275 my $target = $c->request->param('target_id');
276 my $scopewide = $c->request->param('scopewide')
277 && $c->request->param('scopewide') eq 'true';
279 my @vectors = $collation->del_relationship( $node, $target, $scopewide );
280 $m->save( $tradition );
281 $c->stash->{'result'} = \@vectors;
282 } catch( Text::Tradition::Error $e ) {
283 $c->response->status( '403' );
284 $c->stash->{'result'} = { 'error' => $e->message };
286 $c->response->status( '500' );
287 $c->stash->{'result'} = { error => "Something went wrong with the request" };
291 $c->forward('View::JSON');
296 GET relation/$textid/readings
298 Returns the list of readings defined for this text along with their metadata.
302 my %read_write_keys = (
306 'grammar_invalid' => 1,
311 sub _reading_struct {
313 # Return a JSONable struct of the useful keys. Keys meant to be writable
314 # have a true value; read-only keys have a false value.
316 map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
318 $struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
319 # Look up any words related via spelling or orthography
322 return $t eq 'spelling' || $t eq 'orthographic';
324 # Now add the list data
325 $struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
326 $struct->{'witnesses'} = [ $reading->witnesses ];
330 sub readings :Chained('text') :PathPart :Args(0) {
331 my( $self, $c ) = @_;
332 my $tradition = delete $c->stash->{'tradition'};
333 my $ok = _check_permission( $c, $tradition );
335 my $collation = $tradition->collation;
336 my $m = $c->model('Directory');
337 if( $c->request->method eq 'GET' ) {
339 foreach my $rdg ( $collation->readings ) {
340 $rdginfo->{$rdg->id} = _reading_struct( $rdg );
342 $c->stash->{'result'} = $rdginfo;
344 $c->forward('View::JSON');
349 GET relation/$textid/reading/$id
351 Returns the list of readings defined for this text along with their metadata.
353 POST relation/$textid/reading/$id { request }
355 Alters the reading according to the values in request. Returns 403 Forbidden if
356 the alteration isn't allowed.
360 sub reading :Chained('text') :PathPart :Args(1) {
361 my( $self, $c, $reading_id ) = @_;
362 my $tradition = delete $c->stash->{'tradition'};
363 my $collation = $tradition->collation;
364 my $rdg = $collation->reading( $reading_id );
365 my $m = $c->model('Directory');
366 if( $c->request->method eq 'GET' ) {
367 $c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
368 : { 'error' => "No reading with ID $reading_id" };
369 } elsif ( $c->request->method eq 'POST' ) {
370 if( $c->stash->{'permission'} ne 'full' ) {
371 $c->response->status( '403' );
372 $c->stash->{'result'} = {
373 'error' => 'You do not have permission to modify this tradition.' };
374 $c->detach('View::JSON');
378 if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
379 # Are we re-lemmatizing?
380 if( $c->request->param('relemmatize') ) {
381 my $nf = $c->request->param('normal_form');
382 # TODO throw error unless $nf
383 $rdg->normal_form( $nf );
384 # TODO throw error if lemmatization fails
385 # TODO skip this if normal form hasn't changed
388 # Set all the values that we have for the reading.
389 # TODO error handling
390 foreach my $p ( keys %{$c->request->params} ) {
391 if( $p =~ /^morphology_(\d+)$/ ) {
392 # Set the form on the correct lexeme
393 my $morphval = $c->request->param( $p );
394 next unless $morphval;
396 my $lx = $rdg->lexeme( $midx );
397 my $strrep = $rdg->language . ' // ' . $morphval;
398 my $idx = $lx->has_form( $strrep );
399 unless( defined $idx ) {
400 # Make the word form and add it to the lexeme.
402 $idx = $lx->add_matching_form( $strrep ) - 1;
403 } catch( Text::Tradition::Error $e ) {
404 $c->response->status( '403' );
405 $errmsg = $e->message;
407 # Something else went wrong, probably a Moose error
408 $c->response->status( '500' );
409 $errmsg = 'Something went wrong with the request';
412 $lx->disambiguate( $idx ) if defined $idx;
413 } elsif( $read_write_keys{$p} ) {
414 my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
421 $errmsg = "Reading does not exist or cannot be morphologized";
423 $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
424 : _reading_struct( $rdg );
427 $c->forward('View::JSON');
431 sub compress :Chained('text') :PathPart :Args(0) {
432 my( $self, $c ) = @_;
433 my $tradition = delete $c->stash->{'tradition'};
434 my $collation = $tradition->collation;
435 my $m = $c->model('Directory');
437 my @rids = $c->request->param('readings[]');
440 foreach my $rid (@rids) {
441 my $rdg = $collation->reading( $rid );
443 push @readings, $rdg;
446 my $len = scalar @readings;
448 if( $c->request->method eq 'POST' ) {
449 if( $c->stash->{'permission'} ne 'full' ) {
450 $c->response->status( '403' );
451 $c->stash->{'result'} = {
452 'error' => 'You do not have permission to modify this tradition.' };
453 $c->detach('View::JSON');
457 # Sanity check: first save the original text of each witness.
459 foreach my $wit ( $tradition->witnesses ) {
460 $origtext{$wit->sigil} = $collation->path_text( $wit->sigil );
461 if( $wit->is_layered ) {
462 my $acsig = $wit->sigil . $collation->ac_label;
463 $origtext{$acsig} = $collation->path_text( $acsig );
469 for (my $i = 0; $i < $len; $i++) {
470 my $rdg = $readings[$i];
472 if ($rdg->is_combinable) {
478 for (my $i = $first+1; $i < $len; $i++) {
479 my $rdg = $readings[$first];
480 my $next = $readings[$i];
482 last unless $next->is_combinable;
484 warn "Joining readings $rdg and $next\n";
486 $collation->merge_readings( "$rdg", "$next", 1 );
489 # Finally, make sure we haven't screwed anything up.
490 foreach my $wit ( $tradition->witnesses ) {
491 my $pathtext = $collation->path_text( $wit->sigil );
492 throw( "Text differs for witness " . $wit->sigil )
493 unless $pathtext eq $origtext{$wit->sigil};
494 if( $wit->is_layered ) {
495 my $acsig = $wit->sigil . $collation->ac_label;
496 $pathtext = $collation->path_text( $acsig );
497 throw( "Layered text differs for witness " . $wit->sigil )
498 unless $pathtext eq $origtext{$acsig};
502 $collation->relations->rebuild_equivalence();
503 $collation->calculate_ranks();
505 $m->save($collation);
507 $c->stash->{'result'} = {};
508 $c->forward('View::JSON');
514 POST relation/$textid/merge { data }
516 Merges the requested readings, combining the witnesses of both readings into
517 the target reading. All non-conflicting source relationships are inherited by
518 the target relationship.
522 sub merge :Chained('text') :PathPart :Args(0) {
523 my( $self, $c ) = @_;
524 my $tradition = delete $c->stash->{'tradition'};
525 my $collation = $tradition->collation;
526 my $m = $c->model('Directory');
527 if( $c->request->method eq 'POST' ) {
528 if( $c->stash->{'permission'} ne 'full' ) {
529 $c->response->status( '403' );
530 $c->stash->{'result'} = {
531 'error' => 'You do not have permission to modify this tradition.' };
532 $c->detach('View::JSON');
538 my $main = $c->request->param('target_id');
539 my $second = $c->request->param('source_id');
540 # Find the common successor of these, so that we can detect other
541 # potentially identical readings.
542 my $csucc = $collation->common_successor( $main, $second );
544 # Try the merge if these are parallel readings.
545 if( $csucc->id eq $main || $csucc->id eq $second ) {
546 $errmsg = "Cannot merge readings in the same path";
549 $collation->merge_readings( $main, $second );
550 } catch( Text::Tradition::Error $e ) {
551 $c->response->status( '403' );
552 $errmsg = $e->message;
554 # Something else went wrong, probably a Moose error
555 $c->response->status( '403' );
556 $errmsg = 'Something went wrong with the request';
560 # Look for readings that are now identical.
562 $response = { status => 'error', error => $errmsg };
564 $response = { status => 'ok' };
565 unless( $c->request->param('single') ) {
566 my @identical = $collation->identical_readings(
567 start => $main, end => $csucc->id );
569 $response->{'checkalign'} = [
570 map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
573 $m->save( $collation );
575 $c->stash->{'result'} = $response;
576 $c->forward('View::JSON');
582 POST relation/$textid/duplicate { data }
584 Duplicates the requested readings, detaching the witnesses specified in
585 the list to use the new reading(s) instead of the old. The data to be
586 passed should be a JSON structure:
588 { readings: rid1,rid2,rid3,...
589 witnesses: [ wit1, ... ] }
593 sub duplicate :Chained('text') :PathPart :Args(0) {
594 my( $self, $c ) = @_;
595 my $tradition = delete $c->stash->{'tradition'};
596 my $collation = $tradition->collation;
597 my $m = $c->model('Directory');
598 if( $c->request->method eq 'POST' ) {
599 if( $c->stash->{'permission'} ne 'full' ) {
600 $c->response->status( '403' );
601 $c->stash->{'result'} = {
602 'error' => 'You do not have permission to modify this tradition.' };
603 $c->detach('View::JSON');
608 # Sort out which readings need to be duplicated from the set given, and
609 # ensure that all the given wits bear each relevant reading.
612 map { $wits{$_} = 1 } $c->request->param('witnesses[]');
614 foreach my $rid ( $c->request->param('readings[]') ) {
616 my $rdg = $collation->reading( $rid );
617 foreach my $rwit ( $rdg->witnesses( $rid ) ) {
618 $numwits++ if exists $wits{$rwit};
620 next unless $numwits; # Disregard readings with none of our witnesses
621 if( $numwits < keys( %wits ) ) {
622 $errmsg = "Reading $rid contains some but not all of the specified witnesses.";
624 } elsif( exists $rdgranks{ $rdg->rank } ) {
625 $errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
628 $rdgranks{ $rdg->rank } = $rid;
632 # Now check that the readings make a single sequence.
635 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
636 my $rid = $rdgranks{$rank};
638 # Check that there is only one path between $prior and $rdg.
639 foreach my $wit ( keys %wits ) {
640 unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
641 $errmsg = "Diverging witness paths from $prior to $rid at $wit";
650 # Abort if we've run into a problem.
652 $c->stash->{'result'} = { 'error' => $errmsg };
653 $c->response->status( '403' );
654 $c->forward('View::JSON');
658 # Otherwise, do the dirty work.
659 my @witlist = keys %wits;
660 my @deleted_relations;
661 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
663 my $reading_id = $rdgranks{$rank};
666 ( $newrdg, @delrels ) =
667 $collation->duplicate_reading( $reading_id, @witlist );
668 } catch( Text::Tradition::Error $e ) {
669 $c->response->status( '403' );
670 $errmsg = $e->message;
672 # Something else went wrong, probably a Moose error
673 $c->response->status( '500' );
674 $errmsg = 'Something went wrong with the request';
677 my $data = _reading_struct( $newrdg );
678 $data->{'orig_rdg'} = $reading_id;
679 $response->{"$newrdg"} = $data;
680 push( @deleted_relations, @delrels );
684 $c->stash->{'result'} = { 'error' => $errmsg };
686 $m->save( $collation );
687 $response->{'DELETED'} = \@deleted_relations;
688 $c->stash->{'result'} = $response;
691 $c->forward('View::JSON');
696 sub _check_permission {
697 my( $c, $tradition ) = @_;
698 my $user = $c->user_exists ? $c->user->get_object : undef;
699 # Does this user have access?
701 if( $user->is_admin ||
702 ( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
703 $c->stash->{'permission'} = 'full';
708 if( $tradition->public ) {
709 $c->stash->{'permission'} = 'readonly';
713 $c->response->status( 403 );
714 $c->response->body( 'You do not have permission to view this tradition.' );
715 $c->detach( 'View::Plain' );
719 sub _clean_booleans {
720 my( $obj, $param, $val ) = @_;
721 if( $obj->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
722 $val = 1 if $val eq 'true';
723 $val = undef if $val eq 'false';
730 Attempt to render a view, if needed.
734 sub end : ActionClass('RenderView') {}
742 This library is free software. You can redistribute it and/or modify
743 it under the same terms as Perl itself.
747 __PACKAGE__->meta->make_immutable;