[scpubgit/stemmaweb.git] / lib / stemmaweb / Controller / Relation.pm

package stemmaweb::Controller::Relation;
use JSON qw/ to_json from_json /;
use Moose;
use Module::Load;
use namespace::autoclean;
use TryCatch;

BEGIN { extends 'Catalyst::Controller' }


=head1 NAME

stemmaweb::Controller::Relation - Controller for the relationship mapper

=head1 DESCRIPTION

The reading relationship mapper with draggable nodes.

=head1 METHODS

=head2 index

 GET relation/$textid
 
Renders the application for the text identified by $textid.

=cut

sub index :Path :Args(0) {
	my( $self, $c ) = @_;
	$c->stash->{'template'} = 'relate.tt';
}

=head2 text

 GET relation/$textid/
 
 Runs the relationship mapper for the specified text ID.
 
=cut

sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
	my( $self, $c, $textid ) = @_;
	my $tradition = $c->model('Directory')->tradition( $textid );
	unless( $tradition ) {
		$c->response->status('404');
		$c->response->body("No such tradition with ID $textid");
		$c->detach('View::Plain');
		return;
	}
	
    # Account for a bad interaction between FastCGI and KiokuDB
    unless( $tradition->collation->tradition ) {
        $c->log->warn( "Fixing broken tradition link" );
        $tradition->collation->_set_tradition( $tradition );
        $c->model('Directory')->save( $tradition );
    }
    # Check permissions. Will return 403 if denied, otherwise will
    # put the appropriate value in the stash.
    my $ok = _check_permission( $c, $tradition );
    return unless $ok;

	$c->stash->{'textid'} = $textid;
	$c->stash->{'tradition'} = $tradition;
}

sub main :Chained('text') :PathPart('') :Args(0) {
	my( $self, $c ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $collation = $tradition->collation;
	
	# Stash the relationship definitions
	$c->stash->{'relationship_scopes'} = to_json( [ qw/ local global / ] );
	my @reltypeinfo;
	foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
		next if $type->is_weak;
		my $struct = { name => $type->name, description => $type->description };
		push( @reltypeinfo, $struct );
	}
	$c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
	
	# See how big the tradition is. Edges are more important than nodes
	# when it comes to rendering difficulty.
	my $numnodes = scalar $collation->readings;
	my $numedges = scalar $collation->paths;
	my $length = $collation->end->rank;
	# We should display no more than roughly 500 nodes, or roughly 700
	# edges, at a time.
	my $segments = $numnodes / 500;
	if( $numedges / 700 > $segments ) {
		$segments = $numedges / 700;
	}
	my $segsize = sprintf( "%.0f", $length / $segments );
	my $margin = sprintf( "%.0f", $segsize / 10 );
	if( $segments > 1 ) {
		# Segment the tradition in order not to overload the browser.
		my @divs;
		my $r = 0;
		while( $r + $margin < $length ) {
			push( @divs, $r );
			$r += $segsize;
		}
		$c->stash->{'textsegments'} = [];
		foreach my $i ( 0..$#divs ) {
			my $seg = { 'start' => $divs[$i] };
			$seg->{'display'} = "Segment " . ($i+1);
			push( @{$c->stash->{'textsegments'}}, $seg );
		}
	}
	my $startseg = $c->req->param('start');
	my $svgopts;
	if( $startseg ) {
		# Only render the subgraph from startseg to endseg or to END,
		# whichever is less.
		my $endseg = $startseg + $segsize + $margin;
		$svgopts = { 'from' => $startseg };
		$svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
	} elsif( exists $c->stash->{'textsegments'} ) {
		# This is the unqualified load of a long tradition. We implicitly start 
		# at zero, but go only as far as our segment size.
		my $endseg = $segsize + $margin;
		$startseg = 0;
		$svgopts = { 'to' => $endseg };
	}
	# Spit out the SVG
	my $svg_str = $collation->as_svg( $svgopts );
	$svg_str =~ s/\n//gs;
	$c->stash->{'startseg'} = $startseg if defined $startseg;
	$c->stash->{'svg_string'} = $svg_str;
	$c->stash->{'text_title'} = $tradition->name;
	if( $tradition->can('language') ) {
		$c->stash->{'text_lang'} = $tradition->language;
		$c->stash->{'can_morphologize'} = 1;
	} else {
		$c->stash->{'text_lang'} = 'Default';
	}
	$c->stash->{'template'} = 'relate.tt';
}

sub _typesort {
	my( $a, $b ) = @_;
	my $blsort = $a->bindlevel <=> $b->bindlevel;
	return $blsort if $blsort;
	return $a->name cmp $b->name;
}

=head2 help

 GET relation/help/$language

Returns the help window HTML.

=cut

sub help :Local :Args(1) {
	my( $self, $c, $lang ) = @_;
	# Display the morphological help for the language if it is defined.
	if( $lang && $lang ne 'Default' ) {
		my $mod = 'Text::Tradition::Language::' . $lang;
		try {
			load( $mod );
		} catch {
			$c->log->debug("Warning: could not load $mod");
		}
		my $has_mod = $mod->can('morphology_tags');
		if( $has_mod ) {
			my $tagset = &$has_mod;
			$c->stash->{'tagset'} = $tagset;
		}
	}
	$c->stash->{'template'} = 'relatehelp.tt';
}

=head2 relationships

 GET relation/$textid/relationships

Returns the list of relationships defined for this text.

 POST relation/$textid/relationships { request }
 
Attempts to define the requested relationship within the text. Returns 200 on
success or 403 on error.

 DELETE relation/$textid/relationships { request }
 

=cut

sub relationships :Chained('text') :PathPart :Args(0) {
	my( $self, $c ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;
	my $collation = $tradition->collation;
	my $m = $c->model('Directory');
	if( $c->request->method eq 'GET' ) {
		my @pairs = $collation->relationships; # returns the edges
		my @all_relations;
		foreach my $p ( @pairs ) {
			my $relobj = $collation->relations->get_relationship( @$p );
			next if $relobj->type eq 'collated'; # Don't show these
			next if $p->[0] eq $p->[1]; # HACK until bugfix
			my $relhash = { source => $p->[0], target => $p->[1], 
				  type => $relobj->type, scope => $relobj->scope };
			$relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
			push( @all_relations, $relhash );
		}
		$c->stash->{'result'} = \@all_relations;
	} else {
		# Check write permissions first of all
		if( $c->stash->{'permission'} ne 'full' ) {
			$c->response->status( '403' );
			$c->stash->{'result'} = { 
				'error' => 'You do not have permission to modify this tradition.' };
			$c->detach( 'View::JSON' );
		} elsif( $c->request->method eq 'POST' ) {
			my $node = $c->request->param('source_id');
			my $target = $c->request->param('target_id');
			my $relation = $c->request->param('rel_type');
			my $note = $c->request->param('note');
			my $scope = $c->request->param('scope');
		
			my $opts = { 'type' => $relation, 'propagate' => 1 };
			$opts->{'scope'} = $scope if $scope;
			$opts->{'annotation'} = $note if $note;
			
			try {
				my @vectors = $collation->add_relationship( $node, $target, $opts );
				$c->stash->{'result'} = \@vectors;
				$m->save( $tradition );
			} catch( Text::Tradition::Error $e ) {
				$c->response->status( '403' );
				$c->stash->{'result'} = { 'error' => $e->message };
			}
		} elsif( $c->request->method eq 'DELETE' ) {
			my $node = $c->request->param('source_id');
			my $target = $c->request->param('target_id');
			my $scopewide = $c->request->param('scopewide') 
				&& $c->request->param('scopewide') eq 'true';
			try {
				my @vectors = $collation->del_relationship( $node, $target, $scopewide );
				$m->save( $tradition );
				$c->stash->{'result'} = \@vectors;
			} catch( Text::Tradition::Error $e ) {
				$c->response->status( '403' );
				$c->stash->{'result'} = { 'error' => $e->message };
			}	
		}
	}
	$c->forward('View::JSON');
}

=head2 readings

 GET relation/$textid/readings

Returns the list of readings defined for this text along with their metadata.

=cut

my %read_write_keys = (
	'id' => 0,
	'text' => 0,
	'is_meta' => 0,
	'grammar_invalid' => 1,
	'is_nonsense' => 1,
	'normal_form' => 1,
);

sub _reading_struct {
	my( $reading ) = @_;
	# Return a JSONable struct of the useful keys.  Keys meant to be writable
	# have a true value; read-only keys have a false value.
	my $struct = {};
	map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
	# Special case
	$struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
	# Look up any words related via spelling or orthography
	my $sameword = sub { 
		my $t = $_[0]->type;
		return $t eq 'spelling' || $t eq 'orthographic';
	};
	# Now add the list data
	$struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
	$struct->{'witnesses'} = [ $reading->witnesses ];
	return $struct;
}

sub readings :Chained('text') :PathPart :Args(0) {
	my( $self, $c ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;
	my $collation = $tradition->collation;
	my $m = $c->model('Directory');
	if( $c->request->method eq 'GET' ) {
		my $rdginfo = {};
		foreach my $rdg ( $collation->readings ) {
			$rdginfo->{$rdg->id} = _reading_struct( $rdg );
		}
		$c->stash->{'result'} = $rdginfo;
	}
	$c->forward('View::JSON');
}

=head2 reading

 GET relation/$textid/reading/$id

Returns the list of readings defined for this text along with their metadata.

 POST relation/$textid/reading/$id { request }
 
Alters the reading according to the values in request. Returns 403 Forbidden if
the alteration isn't allowed.

=cut

sub reading :Chained('text') :PathPart :Args(1) {
	my( $self, $c, $reading_id ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $collation = $tradition->collation;
	my $rdg = $collation->reading( $reading_id );
	my $m = $c->model('Directory');
	if( $c->request->method eq 'GET' ) {
		$c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
			: { 'error' => "No reading with ID $reading_id" };
	} elsif ( $c->request->method eq 'POST' ) {
		if( $c->stash->{'permission'} ne 'full' ) {
			$c->response->status( '403' );
			$c->stash->{'result'} = { 
				'error' => 'You do not have permission to modify this tradition.' };
			$c->detach('View::JSON');
			return;
		}
		my $errmsg;
		if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
			# Are we re-lemmatizing?
			if( $c->request->param('relemmatize') ) {
				my $nf = $c->request->param('normal_form');
				# TODO throw error unless $nf
				$rdg->normal_form( $nf );
				# TODO throw error if lemmatization fails
				# TODO skip this if normal form hasn't changed
				$rdg->lemmatize();
			} else {
				# Set all the values that we have for the reading.
				# TODO error handling
				foreach my $p ( keys %{$c->request->params} ) {
					if( $p =~ /^morphology_(\d+)$/ ) {
						# Set the form on the correct lexeme
						my $morphval = $c->request->param( $p );
						next unless $morphval;
						my $midx = $1;
						my $lx = $rdg->lexeme( $midx );
						my $strrep = $rdg->language . ' // ' . $morphval;
						my $idx = $lx->has_form( $strrep );
						unless( defined $idx ) {
							# Make the word form and add it to the lexeme.
							try {
								$idx = $lx->add_matching_form( $strrep ) - 1;
							} catch( Text::Tradition::Error $e ) {
								$c->response->status( '403' );
								$errmsg = $e->message;
							} catch {
								# Something else went wrong, probably a Moose error
								$c->response->status( '403' );
								$errmsg = 'Something went wrong with the request';	
							}
						}
						$lx->disambiguate( $idx ) if defined $idx;
					} elsif( $read_write_keys{$p} ) {
						my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
						$rdg->$p( $val );
					}
				}		
			}
			$m->save( $rdg );
		} else {
			$errmsg = "Reading does not exist or cannot be morphologized";
		}
		$c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
			: _reading_struct( $rdg );

	}
	$c->forward('View::JSON');

}

=head2 merge

 POST relation/$textid/merge { data }
 
Merges the requested readings, combining the witnesses of both readings into
the target reading. All non-conflicting source relationships are inherited by
the target relationship.

=cut

sub merge :Chained('text') :PathPart :Args(0) {
	my( $self, $c ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $collation = $tradition->collation;
	my $m = $c->model('Directory');
	if( $c->request->method eq 'POST' ) {
		if( $c->stash->{'permission'} ne 'full' ) {
			$c->response->status( '403' );
			$c->stash->{'result'} = { 
				'error' => 'You do not have permission to modify this tradition.' };
			$c->detach('View::JSON');
			return;
		}
		my $errmsg;
		my $response;
		
		my $main = $c->request->param('target_id');
		my $second = $c->request->param('source_id');
		# Find the common successor of these, so that we can detect other
		# potentially identical readings.
		my $csucc = $collation->common_successor( $main, $second );

		# Try the merge if these are parallel readings.
		if( $csucc->id eq $main || $csucc->id eq $second ) {
			$errmsg = "Cannot merge readings in the same path";
		} else {
			try {
				$collation->merge_readings( $main, $second );
			} catch( Text::Tradition::Error $e ) {
				$c->response->status( '403' );
				$errmsg = $e->message;
			} catch {
				# Something else went wrong, probably a Moose error
				$c->response->status( '403' );
				$errmsg = 'Something went wrong with the request';	
			}
		}
		
		# Look for readings that are now identical.
		if( $errmsg ) {
			$response = { status => 'error', error => $errmsg };
		} else {
			$response = { status => 'ok' };
			unless( $c->request->param('single') ) {
				my @identical = $collation->identical_readings(
					start => $main, end => $csucc->id );
				if( @identical ) {
					$response->{'checkalign'} = [ 
						map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
				}
			}
			$m->save( $collation );
		}
		$c->stash->{'result'} = $response;
		$c->forward('View::JSON');			
	}
}

=head2 duplicate

 POST relation/$textid/duplicate { data }
 
Duplicates the requested readings, detaching the witnesses specified in
the list to use the new reading(s) instead of the old. The data to be
passed should be a JSON structure:

 { readings: rid1,rid2,rid3,...
   witnesses: [ wit1, ... ] }

=cut

sub duplicate :Chained('text') :PathPart :Args(0) {
	my( $self, $c ) = @_;
	my $tradition = delete $c->stash->{'tradition'};
	my $collation = $tradition->collation;
	my $m = $c->model('Directory');
	if( $c->request->method eq 'POST' ) {
		if( $c->stash->{'permission'} ne 'full' ) {
			$c->response->status( '403' );
			$c->stash->{'result'} = { 
				'error' => 'You do not have permission to modify this tradition.' };
			$c->detach('View::JSON');
			return;
		}
		my $errmsg;
		my $response = {};
		# Sort out which readings need to be duplicated from the set given, and
		# ensure that all the given wits bear each relevant reading.
		
		my %wits = ();
		map { $wits{$_} = 1 } $c->request->param('witnesses[]');
		my %rdgranks = ();
		foreach my $rid ( $c->request->param('readings[]') ) {
			my $numwits = 0;
			my $rdg = $collation->reading( $rid );
			foreach my $rwit ( $rdg->witnesses( $rid ) ) {
				$numwits++ if exists $wits{$rwit};
			}
			next unless $numwits; # Disregard readings with none of our witnesses
			if( $numwits < keys( %wits ) ) {
				$errmsg = "Reading $rid contains some but not all of the specified witnesses.";
				last;
			} elsif( exists $rdgranks{ $rdg->rank } ) {
				$errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
				last;
			} else {
				$rdgranks{ $rdg->rank } = $rid;
			}
		}
		
		# Now check that the readings make a single sequence.
		unless( $errmsg ) {
			my $prior;
			foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
				my $rid = $rdgranks{$rank};
				if( $prior ) {
					# Check that there is only one path between $prior and $rdg.
					foreach my $wit ( keys %wits ) {
						unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
							$errmsg = "Diverging witness paths from $prior to $rid at $wit";
							last;
						}
					}
				}
				$prior = $rid;
			}
		}
		
		# Abort if we've run into a problem.
		if( $errmsg ) {
			$c->stash->{'result'} = { 'error' => $errmsg };
			$c->response->status( '403' );
			$c->forward('View::JSON');
			return;
		}
		
		# Otherwise, do the dirty work.
		my @witlist = keys %wits;
		foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
			my $newrdg;
			my $reading_id = $rdgranks{$rank};
			try {
				$newrdg = $collation->duplicate_reading( $reading_id, @witlist );
			} catch( Text::Tradition::Error $e ) {
				$c->response->status( '403' );
				$errmsg = $e->message;
			} catch {
				# Something else went wrong, probably a Moose error
				$c->response->status( '403' );
				$errmsg = 'Something went wrong with the request';	
			}
			if( $newrdg ) {
				my $data = _reading_struct( $newrdg );
				$data->{'orig_rdg'} = $reading_id;
				$response->{"$newrdg"} = $data;
			}
		} 
		if( $errmsg ) {
			$c->stash->{'result'} = { 'error' => $errmsg };
		} else {
			$m->save( $collation );
			$c->stash->{'result'} = $response;
		}
	}
	$c->forward('View::JSON');
}


sub _check_permission {
	my( $c, $tradition ) = @_;
    my $user = $c->user_exists ? $c->user->get_object : undef;
    # Does this user have access?
    if( $user ) {
   		if( $user->is_admin || 
    			( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
			$c->stash->{'permission'} = 'full';
			return 1;
		}
    } 
    # Is it public?
    if( $tradition->public ) {
    	$c->stash->{'permission'} = 'readonly';
    	return 1;
    } 
	# Forbidden!
	$c->response->status( 403 );
	$c->response->body( 'You do not have permission to view this tradition.' );
	$c->detach( 'View::Plain' );
	return 0;
}

sub _clean_booleans {
	my( $rdg, $param, $val ) = @_;
	if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
		$val = 1 if $val eq 'true';
		$val = undef if $val eq 'false';
	} 
	return $val;
}

=head2 end

Attempt to render a view, if needed.

=cut

sub end : ActionClass('RenderView') {}

=head1 AUTHOR

Tara L Andrews

=head1 LICENSE

This library is free software. You can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

__PACKAGE__->meta->make_immutable;

1;
Commit	Line	Data
b8a92065	1	package stemmaweb::Controller::Relation;
5539cba3	2	use JSON qw/ to_json from_json /;
b8a92065	3	use Moose;
cc86fa11	4	use Module::Load;
b8a92065	5	use namespace::autoclean;
b28e606e	6	use TryCatch;
b8a92065	7
	8	BEGIN { extends 'Catalyst::Controller' }
	9
	10
	11	=head1 NAME
	12
	13	stemmaweb::Controller::Relation - Controller for the relationship mapper
	14
	15	=head1 DESCRIPTION
	16
b28e606e	17	The reading relationship mapper with draggable nodes.
b8a92065	18
	19	=head1 METHODS
	20
b28e606e	21	=head2 index
b28e606e	22
b8a92065	23	GET relation/$textid
	24
	25	Renders the application for the text identified by $textid.
	26
b8a92065	27	=cut
b8a92065	28
9529f69c	29	sub index :Path :Args(0) {
9529f69c	30	my( $self, $c ) = @_;
b28e606e	31	$c->stash->{'template'} = 'relate.tt';
	32	}
	33
9529f69c	34	=head2 text
b28e606e	35
9529f69c	36	GET relation/$textid/
	37
	38	Runs the relationship mapper for the specified text ID.
	39
b28e606e	40	=cut
b28e606e	41
9529f69c	42	sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
9529f69c	43	my( $self, $c, $textid ) = @_;
13aa153c	44	my $tradition = $c->model('Directory')->tradition( $textid );
cd3f7f55	45	unless( $tradition ) {
	46	$c->response->status('404');
	47	$c->response->body("No such tradition with ID $textid");
	48	$c->detach('View::Plain');
	49	return;
	50	}
	51
7562a27b	52	# Account for a bad interaction between FastCGI and KiokuDB
	53	unless( $tradition->collation->tradition ) {
	54	$c->log->warn( "Fixing broken tradition link" );
	55	$tradition->collation->_set_tradition( $tradition );
	56	$c->model('Directory')->save( $tradition );
	57	}
20198e59	58	# Check permissions. Will return 403 if denied, otherwise will
	59	# put the appropriate value in the stash.
	60	my $ok = _check_permission( $c, $tradition );
	61	return unless $ok;
	62
8843c8b9	63	$c->stash->{'textid'} = $textid;
	64	$c->stash->{'tradition'} = $tradition;
	65	}
	66
	67	sub main :Chained('text') :PathPart('') :Args(0) {
	68	my( $self, $c ) = @_;
	69	my $tradition = delete $c->stash->{'tradition'};
	70	my $collation = $tradition->collation;
	71
56e3972e	72	# Stash the relationship definitions
	73	$c->stash->{'relationship_scopes'} = to_json( [ qw/ local global / ] );
	74	my @reltypeinfo;
	75	foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
	76	next if $type->is_weak;
	77	my $struct = { name => $type->name, description => $type->description };
	78	push( @reltypeinfo, $struct );
	79	}
	80	$c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
	81
d58766c0	82	# See how big the tradition is. Edges are more important than nodes
d58766c0	83	# when it comes to rendering difficulty.
8843c8b9	84	my $numnodes = scalar $collation->readings;
	85	my $numedges = scalar $collation->paths;
	86	my $length = $collation->end->rank;
d58766c0	87	# We should display no more than roughly 500 nodes, or roughly 700
	88	# edges, at a time.
	89	my $segments = $numnodes / 500;
	90	if( $numedges / 700 > $segments ) {
	91	$segments = $numedges / 700;
	92	}
	93	my $segsize = sprintf( "%.0f", $length / $segments );
	94	my $margin = sprintf( "%.0f", $segsize / 10 );
	95	if( $segments > 1 ) {
13aa153c	96	# Segment the tradition in order not to overload the browser.
13aa153c	97	my @divs;
13aa153c	98	my $r = 0;
d58766c0	99	while( $r + $margin < $length ) {
13aa153c	100	push( @divs, $r );
d58766c0	101	$r += $segsize;
13aa153c	102	}
13aa153c	103	$c->stash->{'textsegments'} = [];
ea8e8b3c	104	foreach my $i ( 0..$#divs ) {
	105	my $seg = { 'start' => $divs[$i] };
	106	$seg->{'display'} = "Segment " . ($i+1);
13aa153c	107	push( @{$c->stash->{'textsegments'}}, $seg );
	108	}
	109	}
13aa153c	110	my $startseg = $c->req->param('start');
13aa153c	111	my $svgopts;
13aa153c	112	if( $startseg ) {
d58766c0	113	# Only render the subgraph from startseg to endseg or to END,
13aa153c	114	# whichever is less.
8843c8b9	115	my $endseg = $startseg + $segsize + $margin;
13aa153c	116	$svgopts = { 'from' => $startseg };
d58766c0	117	$svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
13aa153c	118	} elsif( exists $c->stash->{'textsegments'} ) {
13aa153c	119	# This is the unqualified load of a long tradition. We implicitly start
8843c8b9	120	# at zero, but go only as far as our segment size.
8843c8b9	121	my $endseg = $segsize + $margin;
ea8e8b3c	122	$startseg = 0;
d58766c0	123	$svgopts = { 'to' => $endseg };
13aa153c	124	}
8843c8b9	125	# Spit out the SVG
13aa153c	126	my $svg_str = $collation->as_svg( $svgopts );
9529f69c	127	$svg_str =~ s/\n//gs;
ea8e8b3c	128	$c->stash->{'startseg'} = $startseg if defined $startseg;
9529f69c	129	$c->stash->{'svg_string'} = $svg_str;
9529f69c	130	$c->stash->{'text_title'} = $tradition->name;
487674b9	131	if( $tradition->can('language') ) {
	132	$c->stash->{'text_lang'} = $tradition->language;
	133	$c->stash->{'can_morphologize'} = 1;
	134	} else {
	135	$c->stash->{'text_lang'} = 'Default';
	136	}
9529f69c	137	$c->stash->{'template'} = 'relate.tt';
b28e606e	138	}
b28e606e	139
56e3972e	140	sub _typesort {
	141	my( $a, $b ) = @_;
	142	my $blsort = $a->bindlevel <=> $b->bindlevel;
	143	return $blsort if $blsort;
	144	return $a->name cmp $b->name;
8843c8b9	145	}
8843c8b9	146
cc86fa11	147	=head2 help
	148
	149	GET relation/help/$language
	150
	151	Returns the help window HTML.
	152
	153	=cut
	154
	155	sub help :Local :Args(1) {
	156	my( $self, $c, $lang ) = @_;
	157	# Display the morphological help for the language if it is defined.
	158	if( $lang && $lang ne 'Default' ) {
	159	my $mod = 'Text::Tradition::Language::' . $lang;
	160	try {
	161	load( $mod );
	162	} catch {
	163	$c->log->debug("Warning: could not load $mod");
	164	}
	165	my $has_mod = $mod->can('morphology_tags');
cc86fa11	166	if( $has_mod ) {
	167	my $tagset = &$has_mod;
	168	$c->stash->{'tagset'} = $tagset;
	169	}
	170	}
	171	$c->stash->{'template'} = 'relatehelp.tt';
	172	}
	173
b28e606e	174	=head2 relationships
b28e606e	175
13aa153c	176	GET relation/$textid/relationships
9529f69c	177
9529f69c	178	Returns the list of relationships defined for this text.
b28e606e	179
13aa153c	180	POST relation/$textid/relationships { request }
9529f69c	181
	182	Attempts to define the requested relationship within the text. Returns 200 on
	183	success or 403 on error.
b28e606e	184
13aa153c	185	DELETE relation/$textid/relationships { request }
9529f69c	186
b28e606e	187
	188	=cut
	189
9529f69c	190	sub relationships :Chained('text') :PathPart :Args(0) {
b28e606e	191	my( $self, $c ) = @_;
6d124a83	192	my $tradition = delete $c->stash->{'tradition'};
20198e59	193	my $ok = _check_permission( $c, $tradition );
20198e59	194	return unless $ok;
6d124a83	195	my $collation = $tradition->collation;
cdd592f3	196	my $m = $c->model('Directory');
9529f69c	197	if( $c->request->method eq 'GET' ) {
	198	my @pairs = $collation->relationships; # returns the edges
	199	my @all_relations;
	200	foreach my $p ( @pairs ) {
	201	my $relobj = $collation->relations->get_relationship( @$p );
545163a2	202	next if $relobj->type eq 'collated'; # Don't show these
7562a27b	203	next if $p->[0] eq $p->[1]; # HACK until bugfix
69a19c91	204	my $relhash = { source => $p->[0], target => $p->[1],
	205	type => $relobj->type, scope => $relobj->scope };
	206	$relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
	207	push( @all_relations, $relhash );
9529f69c	208	}
9529f69c	209	$c->stash->{'result'} = \@all_relations;
20198e59	210	} else {
	211	# Check write permissions first of all
	212	if( $c->stash->{'permission'} ne 'full' ) {
9529f69c	213	$c->response->status( '403' );
20198e59	214	$c->stash->{'result'} = {
56e3972e	215	'error' => 'You do not have permission to modify this tradition.' };
56e3972e	216	$c->detach( 'View::JSON' );
20198e59	217	} elsif( $c->request->method eq 'POST' ) {
20198e59	218	my $node = $c->request->param('source_id');
	219	my $target = $c->request->param('target_id');
	220	my $relation = $c->request->param('rel_type');
	221	my $note = $c->request->param('note');
	222	my $scope = $c->request->param('scope');
	223
8073db65	224	my $opts = { 'type' => $relation, 'propagate' => 1 };
8073db65	225	$opts->{'scope'} = $scope if $scope;
20198e59	226	$opts->{'annotation'} = $note if $note;
	227
	228	try {
	229	my @vectors = $collation->add_relationship( $node, $target, $opts );
	230	$c->stash->{'result'} = \@vectors;
	231	$m->save( $tradition );
	232	} catch( Text::Tradition::Error $e ) {
	233	$c->response->status( '403' );
	234	$c->stash->{'result'} = { 'error' => $e->message };
	235	}
	236	} elsif( $c->request->method eq 'DELETE' ) {
	237	my $node = $c->request->param('source_id');
	238	my $target = $c->request->param('target_id');
088a14af	239	my $scopewide = $c->request->param('scopewide')
088a14af	240	&& $c->request->param('scopewide') eq 'true';
20198e59	241	try {
088a14af	242	my @vectors = $collation->del_relationship( $node, $target, $scopewide );
20198e59	243	$m->save( $tradition );
	244	$c->stash->{'result'} = \@vectors;
	245	} catch( Text::Tradition::Error $e ) {
	246	$c->response->status( '403' );
	247	$c->stash->{'result'} = { 'error' => $e->message };
	248	}
9529f69c	249	}
b28e606e	250	}
b28e606e	251	$c->forward('View::JSON');
5f15640c	252	}
	253
	254	=head2 readings
	255
	256	GET relation/$textid/readings
	257
	258	Returns the list of readings defined for this text along with their metadata.
	259
	260	=cut
	261
0dcdd5ec	262	my %read_write_keys = (
	263	'id' => 0,
	264	'text' => 0,
	265	'is_meta' => 0,
	266	'grammar_invalid' => 1,
	267	'is_nonsense' => 1,
	268	'normal_form' => 1,
	269	);
	270
5f15640c	271	sub _reading_struct {
	272	my( $reading ) = @_;
	273	# Return a JSONable struct of the useful keys. Keys meant to be writable
	274	# have a true value; read-only keys have a false value.
5f15640c	275	my $struct = {};
2be76d3f	276	map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
5f15640c	277	# Special case
2be76d3f	278	$struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
0dcdd5ec	279	# Look up any words related via spelling or orthography
	280	my $sameword = sub {
	281	my $t = $_[0]->type;
	282	return $t eq 'spelling' \|\| $t eq 'orthographic';
	283	};
5539cba3	284	# Now add the list data
	285	$struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
	286	$struct->{'witnesses'} = [ $reading->witnesses ];
5f15640c	287	return $struct;
	288	}
	289
	290	sub readings :Chained('text') :PathPart :Args(0) {
	291	my( $self, $c ) = @_;
	292	my $tradition = delete $c->stash->{'tradition'};
20198e59	293	my $ok = _check_permission( $c, $tradition );
20198e59	294	return unless $ok;
5f15640c	295	my $collation = $tradition->collation;
	296	my $m = $c->model('Directory');
	297	if( $c->request->method eq 'GET' ) {
	298	my $rdginfo = {};
	299	foreach my $rdg ( $collation->readings ) {
	300	$rdginfo->{$rdg->id} = _reading_struct( $rdg );
	301	}
	302	$c->stash->{'result'} = $rdginfo;
	303	}
	304	$c->forward('View::JSON');
	305	}
	306
	307	=head2 reading
	308
	309	GET relation/$textid/reading/$id
	310
	311	Returns the list of readings defined for this text along with their metadata.
	312
	313	POST relation/$textid/reading/$id { request }
	314
	315	Alters the reading according to the values in request. Returns 403 Forbidden if
	316	the alteration isn't allowed.
	317
	318	=cut
	319
	320	sub reading :Chained('text') :PathPart :Args(1) {
	321	my( $self, $c, $reading_id ) = @_;
	322	my $tradition = delete $c->stash->{'tradition'};
	323	my $collation = $tradition->collation;
0dcdd5ec	324	my $rdg = $collation->reading( $reading_id );
5f15640c	325	my $m = $c->model('Directory');
5f15640c	326	if( $c->request->method eq 'GET' ) {
5f15640c	327	$c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
	328	: { 'error' => "No reading with ID $reading_id" };
	329	} elsif ( $c->request->method eq 'POST' ) {
20198e59	330	if( $c->stash->{'permission'} ne 'full' ) {
	331	$c->response->status( '403' );
	332	$c->stash->{'result'} = {
5539cba3	333	'error' => 'You do not have permission to modify this tradition.' };
20198e59	334	$c->detach('View::JSON');
487674b9	335	return;
20198e59	336	}
6666d111	337	my $errmsg;
487674b9	338	if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
	339	# Are we re-lemmatizing?
	340	if( $c->request->param('relemmatize') ) {
	341	my $nf = $c->request->param('normal_form');
	342	# TODO throw error unless $nf
	343	$rdg->normal_form( $nf );
	344	# TODO throw error if lemmatization fails
	345	# TODO skip this if normal form hasn't changed
	346	$rdg->lemmatize();
	347	} else {
	348	# Set all the values that we have for the reading.
	349	# TODO error handling
	350	foreach my $p ( keys %{$c->request->params} ) {
	351	if( $p =~ /^morphology_(\d+)$/ ) {
	352	# Set the form on the correct lexeme
	353	my $morphval = $c->request->param( $p );
	354	next unless $morphval;
	355	my $midx = $1;
	356	my $lx = $rdg->lexeme( $midx );
	357	my $strrep = $rdg->language . ' // ' . $morphval;
	358	my $idx = $lx->has_form( $strrep );
	359	unless( defined $idx ) {
	360	# Make the word form and add it to the lexeme.
	361	try {
	362	$idx = $lx->add_matching_form( $strrep ) - 1;
	363	} catch( Text::Tradition::Error $e ) {
	364	$c->response->status( '403' );
	365	$errmsg = $e->message;
	366	} catch {
	367	# Something else went wrong, probably a Moose error
	368	$c->response->status( '403' );
	369	$errmsg = 'Something went wrong with the request';
	370	}
6666d111	371	}
487674b9	372	$lx->disambiguate( $idx ) if defined $idx;
	373	} elsif( $read_write_keys{$p} ) {
	374	my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
	375	$rdg->$p( $val );
0dcdd5ec	376	}
487674b9	377	}
	378	}
	379	$m->save( $rdg );
	380	} else {
	381	$errmsg = "Reading does not exist or cannot be morphologized";
0dcdd5ec	382	}
6666d111	383	$c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
6666d111	384	: _reading_struct( $rdg );
0dcdd5ec	385
5f15640c	386	}
	387	$c->forward('View::JSON');
	388
	389	}
b28e606e	390
b001c73d	391	=head2 merge
	392
	393	POST relation/$textid/merge { data }
	394
	395	Merges the requested readings, combining the witnesses of both readings into
	396	the target reading. All non-conflicting source relationships are inherited by
	397	the target relationship.
	398
	399	=cut
	400
	401	sub merge :Chained('text') :PathPart :Args(0) {
	402	my( $self, $c ) = @_;
	403	my $tradition = delete $c->stash->{'tradition'};
	404	my $collation = $tradition->collation;
	405	my $m = $c->model('Directory');
	406	if( $c->request->method eq 'POST' ) {
	407	if( $c->stash->{'permission'} ne 'full' ) {
	408	$c->response->status( '403' );
	409	$c->stash->{'result'} = {
	410	'error' => 'You do not have permission to modify this tradition.' };
	411	$c->detach('View::JSON');
	412	return;
	413	}
	414	my $errmsg;
	415	my $response;
	416
	417	my $main = $c->request->param('target_id');
	418	my $second = $c->request->param('source_id');
	419	# Find the common successor of these, so that we can detect other
	420	# potentially identical readings.
	421	my $csucc = $collation->common_successor( $main, $second );
	422
	423	# Try the merge if these are parallel readings.
	424	if( $csucc->id eq $main \|\| $csucc->id eq $second ) {
	425	$errmsg = "Cannot merge readings in the same path";
	426	} else {
	427	try {
	428	$collation->merge_readings( $main, $second );
	429	} catch( Text::Tradition::Error $e ) {
	430	$c->response->status( '403' );
	431	$errmsg = $e->message;
	432	} catch {
	433	# Something else went wrong, probably a Moose error
	434	$c->response->status( '403' );
	435	$errmsg = 'Something went wrong with the request';
	436	}
	437	}
	438
	439	# Look for readings that are now identical.
	440	if( $errmsg ) {
	441	$response = { status => 'error', error => $errmsg };
	442	} else {
	443	$response = { status => 'ok' };
8880c19d	444	unless( $c->request->param('single') ) {
	445	my @identical = $collation->identical_readings(
	446	start => $main, end => $csucc->id );
	447	if( @identical ) {
	448	$response->{'checkalign'} = [
	449	map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
	450	}
b001c73d	451	}
	452	$m->save( $collation );
	453	}
	454	$c->stash->{'result'} = $response;
	455	$c->forward('View::JSON');
	456	}
	457	}
	458
5539cba3	459	=head2 duplicate
5539cba3	460
fdb37581	461	POST relation/$textid/duplicate { data }
5539cba3	462
fdb37581	463	Duplicates the requested readings, detaching the witnesses specified in
	464	the list to use the new reading(s) instead of the old. The data to be
	465	passed should be a JSON structure:
	466
	467	{ readings: rid1,rid2,rid3,...
	468	witnesses: [ wit1, ... ] }
5539cba3	469
	470	=cut
	471
fdb37581	472	sub duplicate :Chained('text') :PathPart :Args(0) {
fdb37581	473	my( $self, $c ) = @_;
5539cba3	474	my $tradition = delete $c->stash->{'tradition'};
5539cba3	475	my $collation = $tradition->collation;
5539cba3	476	my $m = $c->model('Directory');
	477	if( $c->request->method eq 'POST' ) {
	478	if( $c->stash->{'permission'} ne 'full' ) {
	479	$c->response->status( '403' );
	480	$c->stash->{'result'} = {
	481	'error' => 'You do not have permission to modify this tradition.' };
	482	$c->detach('View::JSON');
	483	return;
	484	}
	485	my $errmsg;
	486	my $response = {};
fdb37581	487	# Sort out which readings need to be duplicated from the set given, and
	488	# ensure that all the given wits bear each relevant reading.
	489
	490	my %wits = ();
	491	map { $wits{$_} = 1 } $c->request->param('witnesses[]');
	492	my %rdgranks = ();
	493	foreach my $rid ( $c->request->param('readings[]') ) {
	494	my $numwits = 0;
	495	my $rdg = $collation->reading( $rid );
	496	foreach my $rwit ( $rdg->witnesses( $rid ) ) {
	497	$numwits++ if exists $wits{$rwit};
	498	}
769401c3	499	next unless $numwits; # Disregard readings with none of our witnesses
769401c3	500	if( $numwits < keys( %wits ) ) {
fdb37581	501	$errmsg = "Reading $rid contains some but not all of the specified witnesses.";
	502	last;
	503	} elsif( exists $rdgranks{ $rdg->rank } ) {
	504	$errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
	505	last;
	506	} else {
	507	$rdgranks{ $rdg->rank } = $rid;
	508	}
	509	}
	510
	511	# Now check that the readings make a single sequence.
	512	unless( $errmsg ) {
	513	my $prior;
	514	foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
	515	my $rid = $rdgranks{$rank};
	516	if( $prior ) {
	517	# Check that there is only one path between $prior and $rdg.
	518	foreach my $wit ( keys %wits ) {
	519	unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
	520	$errmsg = "Diverging witness paths from $prior to $rid at $wit";
	521	last;
	522	}
	523	}
	524	}
	525	$prior = $rid;
	526	}
	527	}
	528
	529	# Abort if we've run into a problem.
	530	if( $errmsg ) {
	531	$c->stash->{'result'} = { 'error' => $errmsg };
	532	$c->response->status( '403' );
	533	$c->forward('View::JSON');
	534	return;
	535	}
	536
	537	# Otherwise, do the dirty work.
	538	my @witlist = keys %wits;
	539	foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
5539cba3	540	my $newrdg;
fdb37581	541	my $reading_id = $rdgranks{$rank};
5539cba3	542	try {
fdb37581	543	$newrdg = $collation->duplicate_reading( $reading_id, @witlist );
5539cba3	544	} catch( Text::Tradition::Error $e ) {
	545	$c->response->status( '403' );
	546	$errmsg = $e->message;
	547	} catch {
	548	# Something else went wrong, probably a Moose error
	549	$c->response->status( '403' );
	550	$errmsg = 'Something went wrong with the request';
	551	}
	552	if( $newrdg ) {
ea77ecb8	553	my $data = _reading_struct( $newrdg );
	554	$data->{'orig_rdg'} = $reading_id;
	555	$response->{"$newrdg"} = $data;
5539cba3	556	}
fdb37581	557	}
	558	if( $errmsg ) {
	559	$c->stash->{'result'} = { 'error' => $errmsg };
5539cba3	560	} else {
fdb37581	561	$m->save( $collation );
fdb37581	562	$c->stash->{'result'} = $response;
5539cba3	563	}
5539cba3	564	}
	565	$c->forward('View::JSON');
	566	}
	567
	568
	569
20198e59	570	sub _check_permission {
	571	my( $c, $tradition ) = @_;
	572	my $user = $c->user_exists ? $c->user->get_object : undef;
b0524272	573	# Does this user have access?
20198e59	574	if( $user ) {
b0524272	575	if( $user->is_admin \|\|
	576	( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
	577	$c->stash->{'permission'} = 'full';
	578	return 1;
	579	}
080f8a02	580	}
	581	# Is it public?
	582	if( $tradition->public ) {
20198e59	583	$c->stash->{'permission'} = 'readonly';
20198e59	584	return 1;
080f8a02	585	}
	586	# Forbidden!
	587	$c->response->status( 403 );
	588	$c->response->body( 'You do not have permission to view this tradition.' );
	589	$c->detach( 'View::Plain' );
	590	return 0;
20198e59	591	}
20198e59	592
997ebe92	593	sub _clean_booleans {
	594	my( $rdg, $param, $val ) = @_;
	595	if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
	596	$val = 1 if $val eq 'true';
	597	$val = undef if $val eq 'false';
	598	}
	599	return $val;
	600	}
	601
b8a92065	602	=head2 end
	603
	604	Attempt to render a view, if needed.
	605
	606	=cut
	607
	608	sub end : ActionClass('RenderView') {}
	609
	610	=head1 AUTHOR
	611
	612	Tara L Andrews
	613
	614	=head1 LICENSE
	615
	616	This library is free software. You can redistribute it and/or modify
	617	it under the same terms as Perl itself.
	618
	619	=cut
	620
	621	__PACKAGE__->meta->make_immutable;
	622
	623	1;