[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 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};
			}
			if( $numwits > 0 && $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
5539cba3	391	=head2 duplicate
5539cba3	392
fdb37581	393	POST relation/$textid/duplicate { data }
5539cba3	394
fdb37581	395	Duplicates the requested readings, detaching the witnesses specified in
	396	the list to use the new reading(s) instead of the old. The data to be
	397	passed should be a JSON structure:
	398
	399	{ readings: rid1,rid2,rid3,...
	400	witnesses: [ wit1, ... ] }
5539cba3	401
	402	=cut
	403
fdb37581	404	sub duplicate :Chained('text') :PathPart :Args(0) {
fdb37581	405	my( $self, $c ) = @_;
5539cba3	406	my $tradition = delete $c->stash->{'tradition'};
5539cba3	407	my $collation = $tradition->collation;
5539cba3	408	my $m = $c->model('Directory');
	409	if( $c->request->method eq 'POST' ) {
	410	if( $c->stash->{'permission'} ne 'full' ) {
	411	$c->response->status( '403' );
	412	$c->stash->{'result'} = {
	413	'error' => 'You do not have permission to modify this tradition.' };
	414	$c->detach('View::JSON');
	415	return;
	416	}
	417	my $errmsg;
	418	my $response = {};
fdb37581	419	# Sort out which readings need to be duplicated from the set given, and
	420	# ensure that all the given wits bear each relevant reading.
	421
	422	my %wits = ();
	423	map { $wits{$_} = 1 } $c->request->param('witnesses[]');
	424	my %rdgranks = ();
	425	foreach my $rid ( $c->request->param('readings[]') ) {
	426	my $numwits = 0;
	427	my $rdg = $collation->reading( $rid );
	428	foreach my $rwit ( $rdg->witnesses( $rid ) ) {
	429	$numwits++ if exists $wits{$rwit};
	430	}
	431	if( $numwits > 0 && $numwits < keys( %wits ) ) {
	432	$errmsg = "Reading $rid contains some but not all of the specified witnesses.";
	433	last;
	434	} elsif( exists $rdgranks{ $rdg->rank } ) {
	435	$errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
	436	last;
	437	} else {
	438	$rdgranks{ $rdg->rank } = $rid;
	439	}
	440	}
	441
	442	# Now check that the readings make a single sequence.
	443	unless( $errmsg ) {
	444	my $prior;
	445	foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
	446	my $rid = $rdgranks{$rank};
	447	if( $prior ) {
	448	# Check that there is only one path between $prior and $rdg.
	449	foreach my $wit ( keys %wits ) {
	450	unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
	451	$errmsg = "Diverging witness paths from $prior to $rid at $wit";
	452	last;
	453	}
	454	}
	455	}
	456	$prior = $rid;
	457	}
	458	}
	459
	460	# Abort if we've run into a problem.
	461	if( $errmsg ) {
	462	$c->stash->{'result'} = { 'error' => $errmsg };
	463	$c->response->status( '403' );
	464	$c->forward('View::JSON');
	465	return;
	466	}
	467
	468	# Otherwise, do the dirty work.
	469	my @witlist = keys %wits;
	470	foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
5539cba3	471	my $newrdg;
fdb37581	472	my $reading_id = $rdgranks{$rank};
5539cba3	473	try {
fdb37581	474	$newrdg = $collation->duplicate_reading( $reading_id, @witlist );
5539cba3	475	} catch( Text::Tradition::Error $e ) {
	476	$c->response->status( '403' );
	477	$errmsg = $e->message;
	478	} catch {
	479	# Something else went wrong, probably a Moose error
	480	$c->response->status( '403' );
	481	$errmsg = 'Something went wrong with the request';
	482	}
	483	if( $newrdg ) {
ea77ecb8	484	my $data = _reading_struct( $newrdg );
	485	$data->{'orig_rdg'} = $reading_id;
	486	$response->{"$newrdg"} = $data;
5539cba3	487	}
fdb37581	488	}
	489	if( $errmsg ) {
	490	$c->stash->{'result'} = { 'error' => $errmsg };
5539cba3	491	} else {
fdb37581	492	$m->save( $collation );
fdb37581	493	$c->stash->{'result'} = $response;
5539cba3	494	}
5539cba3	495	}
	496	$c->forward('View::JSON');
	497	}
	498
	499
	500
20198e59	501	sub _check_permission {
	502	my( $c, $tradition ) = @_;
	503	my $user = $c->user_exists ? $c->user->get_object : undef;
b0524272	504	# Does this user have access?
20198e59	505	if( $user ) {
b0524272	506	if( $user->is_admin \|\|
	507	( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
	508	$c->stash->{'permission'} = 'full';
	509	return 1;
	510	}
080f8a02	511	}
	512	# Is it public?
	513	if( $tradition->public ) {
20198e59	514	$c->stash->{'permission'} = 'readonly';
20198e59	515	return 1;
080f8a02	516	}
	517	# Forbidden!
	518	$c->response->status( 403 );
	519	$c->response->body( 'You do not have permission to view this tradition.' );
	520	$c->detach( 'View::Plain' );
	521	return 0;
20198e59	522	}
20198e59	523
997ebe92	524	sub _clean_booleans {
	525	my( $rdg, $param, $val ) = @_;
	526	if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
	527	$val = 1 if $val eq 'true';
	528	$val = undef if $val eq 'false';
	529	}
	530	return $val;
	531	}
	532
b8a92065	533	=head2 end
	534
	535	Attempt to render a view, if needed.
	536
	537	=cut
	538
	539	sub end : ActionClass('RenderView') {}
	540
	541	=head1 AUTHOR
	542
	543	Tara L Andrews
	544
	545	=head1 LICENSE
	546
	547	This library is free software. You can redistribute it and/or modify
	548	it under the same terms as Perl itself.
	549
	550	=cut
	551
	552	__PACKAGE__->meta->make_immutable;
	553
	554	1;