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 Text::Tradition::Error->throw(
15 'ident' => 'Collation error',
23 stemmaweb::Controller::Relation - Controller for the relationship mapper
27 The reading relationship mapper with draggable nodes.
35 Renders the application for the text identified by $textid.
39 sub index :Path :Args(0) {
41 $c->stash->{'template'} = 'relate.tt';
48 Runs the relationship mapper for the specified text ID.
52 sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
53 my( $self, $c, $textid ) = @_;
54 my $tradition = $c->model('Directory')->tradition( $textid );
55 unless( $tradition ) {
56 $c->response->status('404');
57 $c->response->body("No such tradition with ID $textid");
58 $c->detach('View::Plain');
62 # Account for a bad interaction between FastCGI and KiokuDB
63 unless( $tradition->collation->tradition ) {
64 $c->log->warn( "Fixing broken tradition link" );
65 $tradition->collation->_set_tradition( $tradition );
66 $c->model('Directory')->save( $tradition );
68 # Check permissions. Will return 403 if denied, otherwise will
69 # put the appropriate value in the stash.
70 my $ok = _check_permission( $c, $tradition );
73 $c->stash->{'textid'} = $textid;
74 $c->stash->{'tradition'} = $tradition;
77 sub main :Chained('text') :PathPart('') :Args(0) {
79 my $tradition = delete $c->stash->{'tradition'};
80 my $collation = $tradition->collation;
82 # Stash text direction to use in JS.
83 $c->stash->{'direction'} = $collation->direction;
85 # Stash the relationship definitions
86 $c->stash->{'relationship_scopes'} =
87 to_json( find_type_constraint( 'RelationshipScope' )->values );
88 $c->stash->{'ternary_values'} =
89 to_json( find_type_constraint( 'Ternary' )->values );
91 foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
92 next if $type->is_weak;
93 my $struct = { name => $type->name, description => $type->description };
94 push( @reltypeinfo, $struct );
96 $c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
98 # See how big the tradition is. Edges are more important than nodes
99 # when it comes to rendering difficulty.
100 my $numnodes = scalar $collation->readings;
101 my $numedges = scalar $collation->paths;
102 my $length = $collation->end->rank;
103 # We should display no more than roughly 500 nodes, or roughly 700
105 my $segments = $numnodes / 500;
106 if( $numedges / 700 > $segments ) {
107 $segments = $numedges / 700;
109 my $segsize = sprintf( "%.0f", $length / $segments );
110 my $margin = sprintf( "%.0f", $segsize / 10 );
111 if( $segments > 1 ) {
112 # Segment the tradition in order not to overload the browser.
115 while( $r + $margin < $length ) {
119 $c->stash->{'textsegments'} = [];
120 foreach my $i ( 0..$#divs ) {
121 my $seg = { 'start' => $divs[$i] };
122 $seg->{'display'} = "Segment " . ($i+1);
123 push( @{$c->stash->{'textsegments'}}, $seg );
126 my $startseg = $c->req->param('start');
129 # Only render the subgraph from startseg to endseg or to END,
131 my $endseg = $startseg + $segsize + $margin;
132 $svgopts = { 'from' => $startseg };
133 $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
134 } elsif( exists $c->stash->{'textsegments'} ) {
135 # This is the unqualified load of a long tradition. We implicitly start
136 # at zero, but go only as far as our segment size.
137 my $endseg = $segsize + $margin;
139 $svgopts = { 'to' => $endseg };
142 my $svg_str = $collation->as_svg( $svgopts );
143 $svg_str =~ s/\n//gs;
144 $c->stash->{'startseg'} = $startseg if defined $startseg;
145 $c->stash->{'svg_string'} = $svg_str;
146 $c->stash->{'text_title'} = $tradition->name;
147 if( $tradition->can('language') && $tradition->language ) {
148 $c->stash->{'text_lang'} = $tradition->language;
149 $c->stash->{'can_morphologize'} = 1;
151 $c->stash->{'text_lang'} = 'Default';
153 $c->stash->{'template'} = 'relate.tt';
158 my $blsort = $a->bindlevel <=> $b->bindlevel;
159 return $blsort if $blsort;
160 return $a->name cmp $b->name;
165 GET relation/help/$language
167 Returns the help window HTML.
171 sub help :Local :Args(1) {
172 my( $self, $c, $lang ) = @_;
173 # Display the morphological help for the language if it is defined.
174 if( $lang && $lang ne 'Default' ) {
175 my $mod = 'Text::Tradition::Language::' . $lang;
179 $c->log->debug("Warning: could not load $mod");
181 my $has_mod = $mod->can('morphology_tags');
183 my $tagset = &$has_mod;
184 $c->stash->{'tagset'} = $tagset;
187 $c->stash->{'template'} = 'relatehelp.tt';
192 GET relation/$textid/relationships
194 Returns the list of relationships defined for this text.
196 POST relation/$textid/relationships { request }
198 Attempts to define the requested relationship within the text. Returns 200 on
199 success or 403 on error.
201 DELETE relation/$textid/relationships { request }
206 sub relationships :Chained('text') :PathPart :Args(0) {
207 my( $self, $c ) = @_;
208 my $tradition = delete $c->stash->{'tradition'};
209 my $ok = _check_permission( $c, $tradition );
211 my $collation = $tradition->collation;
212 my $m = $c->model('Directory');
213 if( $c->request->method eq 'GET' ) {
214 my @pairs = $collation->relationships; # returns the edges
216 foreach my $p ( @pairs ) {
217 my $relobj = $collation->relations->get_relationship( @$p );
218 next if $relobj->type eq 'collated'; # Don't show these
219 next if $p->[0] eq $p->[1]; # HACK until bugfix
220 my $relhash = { source_id => $p->[0], target_id => $p->[1],
221 source_text => $collation->reading( $p->[0] )->text,
222 target_text => $collation->reading( $p->[1] )->text,
223 type => $relobj->type, scope => $relobj->scope,
224 a_derivable_from_b => $relobj->a_derivable_from_b,
225 b_derivable_from_a => $relobj->b_derivable_from_a,
226 non_independent => $relobj->non_independent,
227 is_significant => $relobj->is_significant
229 $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
230 push( @all_relations, $relhash );
232 $c->stash->{'result'} = \@all_relations;
234 # Check write permissions first of all
235 if( $c->stash->{'permission'} ne 'full' ) {
236 $c->response->status( '403' );
237 $c->stash->{'result'} = {
238 'error' => 'You do not have permission to modify this tradition.' };
239 $c->detach( 'View::JSON' );
240 } elsif( $c->request->method eq 'POST' ) {
241 my $opts = $c->request->params;
243 # Retrieve the source / target from the options
244 my $node = delete $opts->{source_id};
245 my $target = delete $opts->{target_id};
247 # Make sure we didn't send a blank or invalid relationship type
248 my $relation = $opts->{type};
249 unless( $collation->get_relationship_type( $relation ) ) {
250 my $errmsg = $relation ? "No such relationship type $relation" :
251 "You must specify a relationship type";
252 $c->stash->{'result'} = { error => $errmsg };
253 $c->response->status( '400' );
254 $c->detach( 'View::JSON' );
257 # Keep the data clean
258 my @booleans = qw/ a_derivable_from_b b_derivable_from_a non_independent /;
259 foreach my $k ( keys %$opts ) {
260 if( $opts->{$k} && grep { $_ eq $k } @booleans ) {
265 delete $opts->{scope} unless $opts->{scope};
266 delete $opts->{annotation} unless $opts->{annotation};
267 delete $opts->{is_significant} unless $opts->{is_significant};
268 $opts->{propagate} = 1;
271 my @vectors = $collation->add_relationship( $node, $target, $opts );
272 $c->stash->{'result'} = \@vectors;
273 $m->save( $tradition );
274 } catch( Text::Tradition::Error $e ) {
275 $c->response->status( '403' );
276 $c->stash->{'result'} = { error => $e->message };
278 $c->response->status( '500' );
279 $c->stash->{'result'} = { error => "Something went wrong with the request" };
281 } elsif( $c->request->method eq 'DELETE' ) {
282 my $node = $c->request->param('source_id');
283 my $target = $c->request->param('target_id');
284 my $scopewide = $c->request->param('scopewide')
285 && $c->request->param('scopewide') eq 'true';
287 my @vectors = $collation->del_relationship( $node, $target, $scopewide );
288 $m->save( $tradition );
289 $c->stash->{'result'} = \@vectors;
290 } catch( Text::Tradition::Error $e ) {
291 $c->response->status( '403' );
292 $c->stash->{'result'} = { 'error' => $e->message };
294 $c->response->status( '500' );
295 $c->stash->{'result'} = { error => "Something went wrong with the request" };
299 $c->forward('View::JSON');
304 GET relation/$textid/readings
306 Returns the list of readings defined for this text along with their metadata.
310 my %read_write_keys = (
314 'grammar_invalid' => 1,
319 sub _reading_struct {
321 # Return a JSONable struct of the useful keys. Keys meant to be writable
322 # have a true value; read-only keys have a false value.
324 map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
326 $struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
327 # Look up any words related via spelling or orthography
330 return $t eq 'spelling' || $t eq 'orthographic';
332 # Now add the list data
333 $struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
334 $struct->{'witnesses'} = [ $reading->witnesses ];
338 sub readings :Chained('text') :PathPart :Args(0) {
339 my( $self, $c ) = @_;
340 my $tradition = delete $c->stash->{'tradition'};
341 my $ok = _check_permission( $c, $tradition );
343 my $collation = $tradition->collation;
344 my $m = $c->model('Directory');
345 if( $c->request->method eq 'GET' ) {
347 foreach my $rdg ( $collation->readings ) {
348 $rdginfo->{$rdg->id} = _reading_struct( $rdg );
350 $c->stash->{'result'} = $rdginfo;
352 $c->forward('View::JSON');
357 GET relation/$textid/reading/$id
359 Returns the list of readings defined for this text along with their metadata.
361 POST relation/$textid/reading/$id { request }
363 Alters the reading according to the values in request. Returns 403 Forbidden if
364 the alteration isn't allowed.
368 sub reading :Chained('text') :PathPart :Args(1) {
369 my( $self, $c, $reading_id ) = @_;
370 my $tradition = delete $c->stash->{'tradition'};
371 my $collation = $tradition->collation;
372 my $rdg = $collation->reading( $reading_id );
373 my $m = $c->model('Directory');
374 if( $c->request->method eq 'GET' ) {
375 $c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
376 : { 'error' => "No reading with ID $reading_id" };
377 } elsif ( $c->request->method eq 'POST' ) {
378 if( $c->stash->{'permission'} ne 'full' ) {
379 $c->response->status( '403' );
380 $c->stash->{'result'} = {
381 'error' => 'You do not have permission to modify this tradition.' };
382 $c->detach('View::JSON');
386 if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
387 # Are we re-lemmatizing?
388 if( $c->request->param('relemmatize') ) {
389 my $nf = $c->request->param('normal_form');
390 # TODO throw error unless $nf
391 $rdg->normal_form( $nf );
392 # TODO throw error if lemmatization fails
393 # TODO skip this if normal form hasn't changed
396 # Set all the values that we have for the reading.
397 # TODO error handling
398 foreach my $p ( keys %{$c->request->params} ) {
399 if( $p =~ /^morphology_(\d+)$/ ) {
400 # Set the form on the correct lexeme
401 my $morphval = $c->request->param( $p );
402 next unless $morphval;
404 my $lx = $rdg->lexeme( $midx );
405 my $strrep = $rdg->language . ' // ' . $morphval;
406 my $idx = $lx->has_form( $strrep );
407 unless( defined $idx ) {
408 # Make the word form and add it to the lexeme.
410 $idx = $lx->add_matching_form( $strrep ) - 1;
411 } catch( Text::Tradition::Error $e ) {
412 $c->response->status( '403' );
413 $errmsg = $e->message;
415 # Something else went wrong, probably a Moose error
416 $c->response->status( '500' );
417 $errmsg = 'Something went wrong with the request';
420 $lx->disambiguate( $idx ) if defined $idx;
421 } elsif( $read_write_keys{$p} ) {
422 my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
429 $errmsg = "Reading does not exist or cannot be morphologized";
431 $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
432 : _reading_struct( $rdg );
435 $c->forward('View::JSON');
439 sub compress :Chained('text') :PathPart :Args(0) {
440 my( $self, $c ) = @_;
441 my $tradition = delete $c->stash->{'tradition'};
442 my $collation = $tradition->collation;
443 my $m = $c->model('Directory');
445 my @rids = $c->request->param('readings[]');
448 foreach my $rid (@rids) {
449 my $rdg = $collation->reading( $rid );
451 push @readings, $rdg;
454 my $len = scalar @readings;
456 if( $c->request->method eq 'POST' ) {
457 if( $c->stash->{'permission'} ne 'full' ) {
458 $c->response->status( '403' );
459 $c->stash->{'result'} = {
460 'error' => 'You do not have permission to modify this tradition.' };
461 $c->detach('View::JSON');
465 # Sanity check: first save the original text of each witness.
467 foreach my $wit ( $tradition->witnesses ) {
468 $origtext{$wit->sigil} = $collation->path_text( $wit->sigil );
469 if( $wit->is_layered ) {
470 my $acsig = $wit->sigil . $collation->ac_label;
471 $origtext{$acsig} = $collation->path_text( $acsig );
477 for (my $i = 0; $i < $len; $i++) {
478 my $rdg = $readings[$i];
480 if ($rdg->is_combinable) {
487 push @nodes, "$readings[$first]";
489 for (my $i = $first+1; $i < $len; $i++) {
490 my $rdg = $readings[$first];
491 my $next = $readings[$i];
493 last unless $next->is_combinable;
494 push @nodes, "$next";
497 $collation->merge_readings( "$rdg", "$next", 1 );
499 $c->stash->{result} = {
500 error_msg => $e->message,
503 $c->detach('View::JSON');
508 # Finally, make sure we haven't screwed anything up.
509 foreach my $wit ( $tradition->witnesses ) {
510 my $pathtext = $collation->path_text( $wit->sigil );
511 throw( "Text differs for witness " . $wit->sigil )
512 unless $pathtext eq $origtext{$wit->sigil};
513 if( $wit->is_layered ) {
514 my $acsig = $wit->sigil . $collation->ac_label;
515 $pathtext = $collation->path_text( $acsig );
516 throw( "Layered text differs for witness " . $wit->sigil )
517 unless $pathtext eq $origtext{$acsig};
521 $c->stash->{result} = {
522 error_msg => $e->message,
525 $c->detach('View::JSON');
529 $collation->relations->rebuild_equivalence();
530 $collation->calculate_ranks();
532 $m->save($collation);
534 if ($collation->direction eq 'RL') {
535 @nodes = reverse @nodes;
538 $c->stash->{'result'} = {
543 $c->forward('View::JSON');
549 POST relation/$textid/merge { data }
551 Merges the requested readings, combining the witnesses of both readings into
552 the target reading. All non-conflicting source relationships are inherited by
553 the target relationship.
557 sub merge :Chained('text') :PathPart :Args(0) {
558 my( $self, $c ) = @_;
559 my $tradition = delete $c->stash->{'tradition'};
560 my $collation = $tradition->collation;
561 my $m = $c->model('Directory');
562 if( $c->request->method eq 'POST' ) {
563 if( $c->stash->{'permission'} ne 'full' ) {
564 $c->response->status( '403' );
565 $c->stash->{'result'} = {
566 'error' => 'You do not have permission to modify this tradition.' };
567 $c->detach('View::JSON');
573 my $main = $c->request->param('target_id');
574 my $second = $c->request->param('source_id');
575 # Find the common successor of these, so that we can detect other
576 # potentially identical readings.
577 my $csucc = $collation->common_successor( $main, $second );
579 # Try the merge if these are parallel readings.
580 if( $csucc->id eq $main || $csucc->id eq $second ) {
581 $errmsg = "Cannot merge readings in the same path";
584 $collation->merge_readings( $main, $second );
585 } catch( Text::Tradition::Error $e ) {
586 $c->response->status( '403' );
587 $errmsg = $e->message;
589 # Something else went wrong, probably a Moose error
590 $c->response->status( '403' );
591 $errmsg = 'Something went wrong with the request';
595 # Look for readings that are now identical.
597 $response = { status => 'error', error => $errmsg };
599 $response = { status => 'ok' };
600 unless( $c->request->param('single') ) {
601 my @identical = $collation->identical_readings(
602 start => $main, end => $csucc->id );
604 $response->{'checkalign'} = [
605 map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
608 $m->save( $collation );
610 $c->stash->{'result'} = $response;
611 $c->forward('View::JSON');
617 POST relation/$textid/duplicate { data }
619 Duplicates the requested readings, detaching the witnesses specified in
620 the list to use the new reading(s) instead of the old. The data to be
621 passed should be a JSON structure:
623 { readings: rid1,rid2,rid3,...
624 witnesses: [ wit1, ... ] }
628 sub duplicate :Chained('text') :PathPart :Args(0) {
629 my( $self, $c ) = @_;
630 my $tradition = delete $c->stash->{'tradition'};
631 my $collation = $tradition->collation;
632 my $m = $c->model('Directory');
633 if( $c->request->method eq 'POST' ) {
634 if( $c->stash->{'permission'} ne 'full' ) {
635 $c->response->status( '403' );
636 $c->stash->{'result'} = {
637 'error' => 'You do not have permission to modify this tradition.' };
638 $c->detach('View::JSON');
643 # Sort out which readings need to be duplicated from the set given, and
644 # ensure that all the given wits bear each relevant reading.
647 map { $wits{$_} = 1 } $c->request->param('witnesses[]');
649 foreach my $rid ( $c->request->param('readings[]') ) {
651 my $rdg = $collation->reading( $rid );
652 foreach my $rwit ( $rdg->witnesses( $rid ) ) {
653 $numwits++ if exists $wits{$rwit};
655 next unless $numwits; # Disregard readings with none of our witnesses
656 if( $numwits < keys( %wits ) ) {
657 $errmsg = "Reading $rid contains some but not all of the specified witnesses.";
659 } elsif( exists $rdgranks{ $rdg->rank } ) {
660 $errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
663 $rdgranks{ $rdg->rank } = $rid;
667 # Now check that the readings make a single sequence.
670 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
671 my $rid = $rdgranks{$rank};
673 # Check that there is only one path between $prior and $rdg.
674 foreach my $wit ( keys %wits ) {
675 unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
676 $errmsg = "Diverging witness paths from $prior to $rid at $wit";
685 # Abort if we've run into a problem.
687 $c->stash->{'result'} = { 'error' => $errmsg };
688 $c->response->status( '403' );
689 $c->forward('View::JSON');
693 # Otherwise, do the dirty work.
694 my @witlist = keys %wits;
695 my @deleted_relations;
696 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
698 my $reading_id = $rdgranks{$rank};
701 ( $newrdg, @delrels ) =
702 $collation->duplicate_reading( $reading_id, @witlist );
703 } catch( Text::Tradition::Error $e ) {
704 $c->response->status( '403' );
705 $errmsg = $e->message;
707 # Something else went wrong, probably a Moose error
708 $c->response->status( '500' );
709 $errmsg = 'Something went wrong with the request';
712 my $data = _reading_struct( $newrdg );
713 $data->{'orig_rdg'} = $reading_id;
714 $response->{"$newrdg"} = $data;
715 push( @deleted_relations, @delrels );
719 $c->stash->{'result'} = { 'error' => $errmsg };
721 $m->save( $collation );
722 $response->{'DELETED'} = \@deleted_relations;
723 $c->stash->{'result'} = $response;
726 $c->forward('View::JSON');
731 sub _check_permission {
732 my( $c, $tradition ) = @_;
733 my $user = $c->user_exists ? $c->user->get_object : undef;
734 # Does this user have access?
736 if( $user->is_admin ||
737 ( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
738 $c->stash->{'permission'} = 'full';
743 if( $tradition->public ) {
744 $c->stash->{'permission'} = 'readonly';
748 $c->response->status( 403 );
749 $c->response->body( 'You do not have permission to view this tradition.' );
750 $c->detach( 'View::Plain' );
754 sub _clean_booleans {
755 my( $obj, $param, $val ) = @_;
756 if( $obj->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
757 $val = 1 if $val eq 'true';
758 $val = undef if $val eq 'false';
765 Attempt to render a view, if needed.
769 sub end : ActionClass('RenderView') {}
777 This library is free software. You can redistribute it and/or modify
778 it under the same terms as Perl itself.
782 __PACKAGE__->meta->make_immutable;