[scpubgit/stemmatology.git] / stemmaweb / lib / stemmaweb / Controller / Root.pm

package stemmaweb::Controller::Root;
use Moose;
use namespace::autoclean;
use Text::Tradition::Analysis qw/ run_analysis /;
use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
use TryCatch;


BEGIN { extends 'Catalyst::Controller' }

#
# Sets the actions in this controller to be registered with no prefix
# so they function identically to actions created in MyApp.pm
#
__PACKAGE__->config(namespace => '');

=head1 NAME

stemmaweb::Controller::Root - Root Controller for stemmaweb

=head1 DESCRIPTION

Serves up the main container pages.

=head1 URLs

=head2 index

The root page (/).  Serves the main container page, from which the various
components will be loaded.

=cut

sub index :Path :Args(0) {
    my ( $self, $c ) = @_;

	# Are we being asked to load a text immediately? If so 
	if( $c->req->param('withtradition') ) {
		$c->stash->{'withtradition'} = $c->req->param('withtradition');
	}
    $c->stash->{template} = 'index.tt';
}

=head1 Elements of index page

=head2 directory

 GET /directory

Serves a snippet of HTML that lists the available texts.  This returns texts belonging to the logged-in user if any, otherwise it returns all public texts.

=cut

sub directory :Local :Args(0) {
	my( $self, $c ) = @_;
    my $m = $c->model('Directory');
    # Is someone logged in?
    my %usertexts;
    if( $c->user_exists ) {
    	my $user = $c->user->get_object;
    	my @list = $m->traditionlist( $user );
    	map { $usertexts{$_->{id}} = 1 } @list;
		$c->stash->{usertexts} = \@list;
		$c->stash->{is_admin} = 1 if $user->is_admin;
	}
	# List public (i.e. readonly) texts separately from any user (i.e.
	# full access) texts that exist. Admin users therefore have nothing
	# in this list.
	my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
	$c->stash->{publictexts} = \@plist;
	$c->stash->{template} = 'directory.tt';
}

=head1 AJAX methods for traditions and their properties

=head2 newtradition

 POST /newtradition,
 	{ name: <name>,
 	  language: <language>,
 	  public: <is_public>,
 	  file: <fileupload> }
 
Creates a new tradition belonging to the logged-in user, with the given name
and the collation given in the uploaded file. The file type is indicated via
the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and 
name of the new tradition.
 
=cut

sub newtradition :Local :Args(0) {
	my( $self, $c ) = @_;
	return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
		unless $c->user_exists;

	my $user = $c->user->get_object;
	# Grab the file upload, check its name/extension, and call the
	# appropriate parser(s).
	my $upload = $c->request->upload('file');
	my $name = $c->request->param('name') || 'Uploaded tradition';
	my $lang = $c->request->param( 'language' ) || 'Default';
	my $public = $c->request->param( 'public' ) ? 1 : undef;
	my( $ext ) = $upload->filename =~ /\.(\w+)$/;
	my %newopts = (
		'name' => $name,
		'language' => $lang,
		'public' => $public,
		'file' => $upload->tempname
		);

	my $tradition;
	my $errmsg;
	if( $ext eq 'xml' ) {
		# Try the different XML parsing options to see if one works.
		foreach my $type ( qw/ CollateX CTE TEI / ) {
			try {
				$tradition = Text::Tradition->new( %newopts, 'input' => $type );
			} catch ( Text::Tradition::Error $e ) {
				$errmsg = $e->message;
			} catch {
				$errmsg = "Unexpected parsing error";
			}
			last if $tradition;
		}
	} elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
		# If it's Excel we need to pass excel => $ext;
		# otherwise we need to pass sep_char => [record separator].
		if( $ext =~ /xls/ ) {
			$newopts{'excel'} = $ext;
		} else {
			$newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
		}
		try {
			$tradition = Text::Tradition->new( 
				%newopts,
				'input' => 'Tabular',
				);
		} catch ( Text::Tradition::Error $e ) {
			$errmsg = $e->message;
		} catch {
			$errmsg = "Unexpected parsing error";
		}
	} else {
		# Error unless we have a recognized filename extension
		return _json_error( $c, 500, "Unrecognized file type extension $ext" );
	}
	
	# Save the tradition if we have it, and return its data or else the
	# error that occurred trying to make it.
	if( $errmsg ) {
		return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
	} elsif( !$tradition ) {
		return _json_error( $c, 500, "No error caught but tradition not created" );
	}

	my $m = $c->model('Directory');
	$user->add_tradition( $tradition );
	my $id = $c->model('Directory')->store( $tradition );
	$c->model('Directory')->store( $user );
	$c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
	$c->forward('View::JSON');
}

=head2 textinfo

 GET /textinfo/$textid
 POST /textinfo/$textid, 
 	{ name: $new_name, 
 	  language: $new_language,
 	  public: $is_public, 
 	  owner: $new_userid } # only admin users can update the owner
 
Returns information about a particular text.

=cut

sub textinfo :Local :Args(1) {
	my( $self, $c, $textid ) = @_;
	my $tradition = $c->model('Directory')->tradition( $textid );
	unless( $tradition ) {
		return _json_error( $c, 500, "No tradition with ID $textid" );
	}	
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;
	if( $c->req->method eq 'POST' ) {
		return _json_error( $c, 403, 
			'You do not have permission to update this tradition' ) 
			unless $ok eq 'full';
		my $params = $c->request->parameters;
		# Handle changes to owner-accessible parameters
		my $m = $c->model('Directory');
		my $changed;
		# Handle name param - easy
		if( exists $params->{name} ) {
			my $newname = delete $params->{name};
			unless( $tradition->name eq $newname ) {
				try {
					$tradition->name( $newname );
					$changed = 1;
				} catch {
					return _json_error( $c, 500, "Error setting name to $newname" );
				}
			}
		}
		# Handle language param, making Default => null
		my $langval = delete $params->{language} || 'Default';
		unless( $tradition->language eq $langval ) {
			try {
				$tradition->language( $langval );
				$changed = 1;
			} catch {
				return _json_error( $c, 500, "Error setting language to $langval" );
			}
		}

		# Handle our boolean
		my $ispublic = $tradition->public;
		if( delete $params->{'public'} ) {  # if it's any true value...
			$tradition->public( 1 );
			$changed = 1 unless $ispublic;
		} else {  # the checkbox was unchecked, ergo it should not be public
			$tradition->public( 0 );
			$changed = 1 if $ispublic;
		}
		
		# Handle ownership change
		my $newuser;
		if( exists $params->{'owner'} ) {
			# Only admins can update user / owner
			my $newownerid = delete $params->{'owner'};
			unless( !$newownerid || 
				( $tradition->has_user && $tradition->user->id eq $newownerid ) ) {
				unless( $c->user->get_object->is_admin ) {
					return _json_error( $c, 403, 
						"Only admin users can change tradition ownership" );
				}
				$newuser = $m->find_user({ username => $newownerid });
				unless( $newuser ) {
					return _json_error( $c, 500, "No such user " . $newownerid );
				}
				$newuser->add_tradition( $tradition );
				$changed = 1;
			}
		}
		# TODO check for rogue parameters
		if( scalar keys %$params ) {
			my $rogueparams = join( ', ', keys %$params );
			return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
		}
		# If we safely got to the end, then write to the database.
		$m->save( $tradition ) if $changed;
		$m->save( $newuser ) if $newuser;		
	}

	# Now return the current textinfo, whether GET or successful POST.
	my $textinfo = {
		textid => $textid,
		name => $tradition->name,
		language => $tradition->language,
		public => $tradition->public,
		owner => $tradition->user ? $tradition->user->id : undef,
		witnesses => [ map { $_->sigil } $tradition->witnesses ],
	};
	my @stemmasvg = map { $_->as_svg({ size => [ 500, 375 ] }) } $tradition->stemmata;
	map { $_ =~ s/\n/ /mg } @stemmasvg;
	$textinfo->{stemmata} = \@stemmasvg;
	$c->stash->{'result'} = $textinfo;
	$c->forward('View::JSON');
}

=head2 variantgraph

 GET /variantgraph/$textid
 
Returns the variant graph for the text specified at $textid, in SVG form.

=cut

sub variantgraph :Local :Args(1) {
	my( $self, $c, $textid ) = @_;
	my $tradition = $c->model('Directory')->tradition( $textid );
	unless( $tradition ) {
		return _json_error( $c, 500, "No tradition with ID $textid" );
	}	
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;

	my $collation = $tradition->collation;
	$c->stash->{'result'} = $collation->as_svg;
	$c->forward('View::SVG');
}
	
=head2 stemma

 GET /stemma/$textid/$stemmaseq
 POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }

Returns an SVG representation of the given stemma hypothesis for the text.  
If the URL is called with POST, the stemma at $stemmaseq will be altered
to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
stemma will be added.

=cut

sub stemma :Local :Args(2) {
	my( $self, $c, $textid, $stemmaid ) = @_;
	my $m = $c->model('Directory');
	my $tradition = $m->tradition( $textid );
	unless( $tradition ) {
		return _json_error( $c, 500, "No tradition with ID $textid" );
	}	
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;

	$c->stash->{'result'} = '';
	my $stemma;
	if( $c->req->method eq 'POST' ) {
		if( $ok eq 'full' ) {
			my $dot = $c->request->body_params->{'dot'};
			try {
				if( $stemmaid eq 'n' ) {
					# We are adding a new stemma.
					$stemma = $tradition->add_stemma( 'dot' => $dot );
					$stemmaid = $tradition->stemma_count - 1;
				} elsif( $stemmaid < $tradition->stemma_count ) {
					# We are updating an existing stemma.
					$stemma = $tradition->stemma( $stemmaid );
					$stemma->alter_graph( $dot );
				} else {
					# Unrecognized stemma ID
					return _json_error( $c, 500, "No stemma at index $stemmaid, cannot update" );
				}
			} catch ( Text::Tradition::Error $e ) {
				return _json_error( $c, 500, $e->message );
			}
			$m->store( $tradition );
		} else {
			# No permissions to update the stemma
			return _json_error( $c, 403, 
				'You do not have permission to update stemmata for this tradition' );
		}
	}
	
	# For a GET or a successful POST request, return the SVG representation
	# of the stemma in question, if any.
	if( !$stemma && $tradition->stemma_count > $stemmaid ) {
		$stemma = $tradition->stemma( $stemmaid );
	}
	my $stemma_xml = $stemma ? $stemma->as_svg( { size => [ 500, 375 ] } ) : '';
	# What was requested, XML or JSON?
	my $return_view = 'SVG';
	if( my $accept_header = $c->req->header('Accept') ) {
		$c->log->debug( "Received Accept header: $accept_header" );
		foreach my $type ( split( /,\s*/, $accept_header ) ) {
			# If we were first asked for XML, return SVG
			last if $type =~ /^(application|text)\/xml$/;
			# If we were first asked for JSON, return JSON
			if( $type eq 'application/json' ) {
				$return_view = 'JSON';
				last;
			}
		}
	}
	if( $return_view eq 'SVG' ) {
		$c->stash->{'result'} = $stemma_xml;
		$c->forward('View::SVG');
	} else { # JSON
		$stemma_xml =~ s/\n/ /mg;
		$c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml };
		$c->forward('View::JSON');
	}
}

=head2 stemmadot

 GET /stemmadot/$textid/$stemmaseq
 
Returns the 'dot' format representation of the current stemma hypothesis.

=cut

sub stemmadot :Local :Args(2) {
	my( $self, $c, $textid, $stemmaid ) = @_;
	my $m = $c->model('Directory');
	my $tradition = $m->tradition( $textid );
	unless( $tradition ) {
		return _json_error( $c, 500, "No tradition with ID $textid" );
	}	
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;
	my $stemma = $tradition->stemma( $stemmaid );
	unless( $stemma ) {
		return _json_error( $c, 500, "Tradition $textid has no stemma ID $stemmaid" );
	}
	# Get the dot and transmute its line breaks to literal '|n'
	$c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
	$c->forward('View::JSON');
}

=head2 phylotrees

 GET /phylotrees/$textid
 
 Calculates the phylogenetic tree(s) from the given text variants, and returns a 
 set of the results. The user may then select a tree, choose a root node, and add 
 that to the stemmata for the tradition (if s/he has edit rights to the tradition.)
 
=cut

sub phylotrees :Local :Args(1) {
	my( $self, $c, $textid ) = @_;
	my $tradition = $c->model('Directory')->tradition( $textid );
	unless( $tradition ) {
		return _json_error( $c, 500, "No tradition with ID $textid" );
	}	
	my $ok = _check_permission( $c, $tradition );
	return unless $ok;
	
	## Make the character matrix and run pars
	## TODO normalization options
	my $charmatrix = character_input( $tradition );
	my $newick;
	try {
		$newick = phylip_pars( $charmatrix );
	} catch ( Text::Tradition::Error $e ) {
		return _json_error( $c, 500, $e->message );
	}
	## If we got a result, stash it
	$c->stash->{'stemmadot'} = [];
	$c->stash->{'stemmasvg'} = [];
	if( $newick ) {
		my $stemmata = parse_newick( $newick );
		foreach my $st ( @$stemmata ) {
			push( @{$c->stash->{'stemmadot'}}, $st->editable({ linesep => ' ' }) );
			my $svgstr = $st->as_svg( {size => [ 800, 600 ] });
			$svgstr =~ s/\n//mg;
			push( @{$c->stash->{'stemmasvg'}}, $svgstr );
		}
	}
	$c->stash->{'template'} = 'phylotrees.tt';
}

####################
### Helper functions
####################

# Helper to check what permission, if any, the active user has for
# the given tradition
sub _check_permission {
	my( $c, $tradition ) = @_;
    my $user = $c->user_exists ? $c->user->get_object : undef;
    if( $user ) {
    	return 'full' if ( $user->is_admin || 
    		( $tradition->has_user && $tradition->user->id eq $user->id ) );
    }
	# Text doesn't belong to us, so maybe it's public?
	return 'readonly' if $tradition->public;

	# ...nope. Forbidden!
	return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
}

# Helper to throw a JSON exception
sub _json_error {
	my( $c, $code, $errmsg ) = @_;
	$c->response->status( $code );
	$c->stash->{'result'} = { 'error' => $errmsg };
	$c->forward('View::JSON');
	return 0;
}

=head2 default

Standard 404 error page

=cut

sub default :Path {
    my ( $self, $c ) = @_;
    $c->response->body( 'Page not found' );
    $c->response->status(404);
}

=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
5c9ecf66	1	package stemmaweb::Controller::Root;
dbcf12a6	2	use Moose;
dbcf12a6	3	use namespace::autoclean;
3837c155	4	use Text::Tradition::Analysis qw/ run_analysis /;
ea45d2a6	5	use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
852190b9	6	use TryCatch;
3837c155	7
dbcf12a6	8
	9	BEGIN { extends 'Catalyst::Controller' }
	10
	11	#
	12	# Sets the actions in this controller to be registered with no prefix
	13	# so they function identically to actions created in MyApp.pm
	14	#
	15	__PACKAGE__->config(namespace => '');
	16
	17	=head1 NAME
	18
5c9ecf66	19	stemmaweb::Controller::Root - Root Controller for stemmaweb
dbcf12a6	20
	21	=head1 DESCRIPTION
	22
6b70c348	23	Serves up the main container pages.
dbcf12a6	24
6b70c348	25	=head1 URLs
dbcf12a6	26
	27	=head2 index
	28
6b70c348	29	The root page (/). Serves the main container page, from which the various
6b70c348	30	components will be loaded.
dbcf12a6	31
	32	=cut
	33
	34	sub index :Path :Args(0) {
	35	my ( $self, $c ) = @_;
	36
5d9fd8da	37	# Are we being asked to load a text immediately? If so
	38	if( $c->req->param('withtradition') ) {
	39	$c->stash->{'withtradition'} = $c->req->param('withtradition');
	40	}
6b70c348	41	$c->stash->{template} = 'index.tt';
	42	}
	43
	44	=head1 Elements of index page
	45
	46	=head2 directory
	47
	48	GET /directory
	49
7c256818	50	Serves a snippet of HTML that lists the available texts. This returns texts belonging to the logged-in user if any, otherwise it returns all public texts.
6b70c348	51
6b70c348	52	=cut
7c256818	53
2376359f	54	sub directory :Local :Args(0) {
6b70c348	55	my( $self, $c ) = @_;
3837c155	56	my $m = $c->model('Directory');
27a20fbe	57	# Is someone logged in?
3524c08f	58	my %usertexts;
27a20fbe	59	if( $c->user_exists ) {
27a20fbe	60	my $user = $c->user->get_object;
3524c08f	61	my @list = $m->traditionlist( $user );
	62	map { $usertexts{$_->{id}} = 1 } @list;
	63	$c->stash->{usertexts} = \@list;
27a20fbe	64	$c->stash->{is_admin} = 1 if $user->is_admin;
27a20fbe	65	}
3524c08f	66	# List public (i.e. readonly) texts separately from any user (i.e.
	67	# full access) texts that exist. Admin users therefore have nothing
	68	# in this list.
	69	my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
	70	$c->stash->{publictexts} = \@plist;
6b70c348	71	$c->stash->{template} = 'directory.tt';
	72	}
	73
0bded693	74	=head1 AJAX methods for traditions and their properties
cf9626aa	75
0bded693	76	=head2 newtradition
	77
	78	POST /newtradition,
	79	{ name: <name>,
	80	language: <language>,
	81	public: <is_public>,
	82	file: <fileupload> }
cf9626aa	83
0bded693	84	Creates a new tradition belonging to the logged-in user, with the given name
	85	and the collation given in the uploaded file. The file type is indicated via
	86	the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and
	87	name of the new tradition.
	88
	89	=cut
	90
	91	sub newtradition :Local :Args(0) {
	92	my( $self, $c ) = @_;
	93	return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
	94	unless $c->user_exists;
	95
	96	my $user = $c->user->get_object;
	97	# Grab the file upload, check its name/extension, and call the
	98	# appropriate parser(s).
	99	my $upload = $c->request->upload('file');
	100	my $name = $c->request->param('name') \|\| 'Uploaded tradition';
	101	my $lang = $c->request->param( 'language' ) \|\| 'Default';
	102	my $public = $c->request->param( 'public' ) ? 1 : undef;
	103	my( $ext ) = $upload->filename =~ /\.(\w+)$/;
	104	my %newopts = (
	105	'name' => $name,
	106	'language' => $lang,
	107	'public' => $public,
	108	'file' => $upload->tempname
	109	);
	110
	111	my $tradition;
	112	my $errmsg;
	113	if( $ext eq 'xml' ) {
	114	# Try the different XML parsing options to see if one works.
	115	foreach my $type ( qw/ CollateX CTE TEI / ) {
	116	try {
	117	$tradition = Text::Tradition->new( %newopts, 'input' => $type );
	118	} catch ( Text::Tradition::Error $e ) {
	119	$errmsg = $e->message;
	120	} catch {
	121	$errmsg = "Unexpected parsing error";
	122	}
	123	last if $tradition;
	124	}
	125	} elsif( $ext =~ /^(txt\|csv\|xls(x)?)$/ ) {
	126	# If it's Excel we need to pass excel => $ext;
	127	# otherwise we need to pass sep_char => [record separator].
	128	if( $ext =~ /xls/ ) {
	129	$newopts{'excel'} = $ext;
	130	} else {
	131	$newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
	132	}
	133	try {
	134	$tradition = Text::Tradition->new(
	135	%newopts,
	136	'input' => 'Tabular',
	137	);
	138	} catch ( Text::Tradition::Error $e ) {
	139	$errmsg = $e->message;
	140	} catch {
	141	$errmsg = "Unexpected parsing error";
	142	}
	143	} else {
	144	# Error unless we have a recognized filename extension
	145	return _json_error( $c, 500, "Unrecognized file type extension $ext" );
	146	}
	147
148	# Save the tradition if we have it, and return its data or else the
149	# error that occurred trying to make it.
150	if( $errmsg ) {
151	return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
152	} elsif( !$tradition ) {
153	return _json_error( $c, 500, "No error caught but tradition not created" );
154	}
155
156	my $m = $c->model('Directory');
157	$user->add_tradition( $tradition );
158	my $id = $c->model('Directory')->store( $tradition );
159	$c->model('Directory')->store( $user );
160	$c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
161	$c->forward('View::JSON');
162	}
163
164	=head2 textinfo
165
166	GET /textinfo/$textid
167	POST /textinfo/$textid,
168	{ name: $new_name,
169	language: $new_language,
170	public: $is_public,
171	owner: $new_userid } # only admin users can update the owner
172
173	Returns information about a particular text.
cf9626aa	174
	175	=cut
	176
0bded693	177	sub textinfo :Local :Args(1) {
cf9626aa	178	my( $self, $c, $textid ) = @_;
3524c08f	179	my $tradition = $c->model('Directory')->tradition( $textid );
0bded693	180	unless( $tradition ) {
	181	return _json_error( $c, 500, "No tradition with ID $textid" );
	182	}
852190b9	183	my $ok = _check_permission( $c, $tradition );
852190b9	184	return unless $ok;
0bded693	185	if( $c->req->method eq 'POST' ) {
	186	return _json_error( $c, 403,
	187	'You do not have permission to update this tradition' )
	188	unless $ok eq 'full';
	189	my $params = $c->request->parameters;
	190	# Handle changes to owner-accessible parameters
	191	my $m = $c->model('Directory');
	192	my $changed;
789cbe47	193	# Handle name param - easy
	194	if( exists $params->{name} ) {
	195	my $newname = delete $params->{name};
	196	unless( $tradition->name eq $newname ) {
	197	try {
	198	$tradition->name( $newname );
0bded693	199	$changed = 1;
789cbe47	200	} catch {
789cbe47	201	return _json_error( $c, 500, "Error setting name to $newname" );
0bded693	202	}
	203	}
	204	}
789cbe47	205	# Handle language param, making Default => null
	206	my $langval = delete $params->{language} \|\| 'Default';
	207	unless( $tradition->language eq $langval ) {
	208	try {
	209	$tradition->language( $langval );
	210	$changed = 1;
	211	} catch {
	212	return _json_error( $c, 500, "Error setting language to $langval" );
	213	}
	214	}
	215
0bded693	216	# Handle our boolean
789cbe47	217	my $ispublic = $tradition->public;
0bded693	218	if( delete $params->{'public'} ) { # if it's any true value...
0bded693	219	$tradition->public( 1 );
789cbe47	220	$changed = 1 unless $ispublic;
	221	} else { # the checkbox was unchecked, ergo it should not be public
	222	$tradition->public( 0 );
	223	$changed = 1 if $ispublic;
0bded693	224	}
789cbe47	225
789cbe47	226	# Handle ownership change
0bded693	227	my $newuser;
	228	if( exists $params->{'owner'} ) {
	229	# Only admins can update user / owner
	230	my $newownerid = delete $params->{'owner'};
38093cb0	231	unless( !$newownerid \|\|
38093cb0	232	( $tradition->has_user && $tradition->user->id eq $newownerid ) ) {
0bded693	233	unless( $c->user->get_object->is_admin ) {
	234	return _json_error( $c, 403,
	235	"Only admin users can change tradition ownership" );
	236	}
789cbe47	237	$newuser = $m->find_user({ username => $newownerid });
0bded693	238	unless( $newuser ) {
789cbe47	239	return _json_error( $c, 500, "No such user " . $newownerid );
0bded693	240	}
	241	$newuser->add_tradition( $tradition );
	242	$changed = 1;
	243	}
	244	}
	245	# TODO check for rogue parameters
	246	if( scalar keys %$params ) {
	247	my $rogueparams = join( ', ', keys %$params );
	248	return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
	249	}
	250	# If we safely got to the end, then write to the database.
	251	$m->save( $tradition ) if $changed;
	252	$m->save( $newuser ) if $newuser;
	253	}
852190b9	254
0bded693	255	# Now return the current textinfo, whether GET or successful POST.
	256	my $textinfo = {
	257	textid => $textid,
	258	name => $tradition->name,
	259	language => $tradition->language,
	260	public => $tradition->public,
	261	owner => $tradition->user ? $tradition->user->id : undef,
	262	witnesses => [ map { $_->sigil } $tradition->witnesses ],
	263	};
	264	my @stemmasvg = map { $_->as_svg({ size => [ 500, 375 ] }) } $tradition->stemmata;
	265	map { $_ =~ s/\n/ /mg } @stemmasvg;
	266	$textinfo->{stemmata} = \@stemmasvg;
	267	$c->stash->{'result'} = $textinfo;
	268	$c->forward('View::JSON');
cf9626aa	269	}
6b70c348	270
0bded693	271	=head2 variantgraph
6b70c348	272
0bded693	273	GET /variantgraph/$textid
	274
	275	Returns the variant graph for the text specified at $textid, in SVG form.
6b70c348	276
	277	=cut
	278
0bded693	279	sub variantgraph :Local :Args(1) {
6b70c348	280	my( $self, $c, $textid ) = @_;
3524c08f	281	my $tradition = $c->model('Directory')->tradition( $textid );
0bded693	282	unless( $tradition ) {
	283	return _json_error( $c, 500, "No tradition with ID $textid" );
	284	}
852190b9	285	my $ok = _check_permission( $c, $tradition );
	286	return unless $ok;
	287
3524c08f	288	my $collation = $tradition->collation;
0bded693	289	$c->stash->{'result'} = $collation->as_svg;
0bded693	290	$c->forward('View::SVG');
6b70c348	291	}
0bded693	292
6b70c348	293	=head2 stemma
6b70c348	294
0bded693	295	GET /stemma/$textid/$stemmaseq
0bded693	296	POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
6b70c348	297
0bded693	298	Returns an SVG representation of the given stemma hypothesis for the text.
	299	If the URL is called with POST, the stemma at $stemmaseq will be altered
	300	to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
	301	stemma will be added.
6b70c348	302
	303	=cut
	304
0bded693	305	sub stemma :Local :Args(2) {
852190b9	306	my( $self, $c, $textid, $stemmaid ) = @_;
6b70c348	307	my $m = $c->model('Directory');
6b70c348	308	my $tradition = $m->tradition( $textid );
0bded693	309	unless( $tradition ) {
	310	return _json_error( $c, 500, "No tradition with ID $textid" );
	311	}
852190b9	312	my $ok = _check_permission( $c, $tradition );
	313	return unless $ok;
	314
852190b9	315	$c->stash->{'result'} = '';
0bded693	316	my $stemma;
	317	if( $c->req->method eq 'POST' ) {
	318	if( $ok eq 'full' ) {
852190b9	319	my $dot = $c->request->body_params->{'dot'};
0bded693	320	try {
	321	if( $stemmaid eq 'n' ) {
	322	# We are adding a new stemma.
	323	$stemma = $tradition->add_stemma( 'dot' => $dot );
789cbe47	324	$stemmaid = $tradition->stemma_count - 1;
0bded693	325	} elsif( $stemmaid < $tradition->stemma_count ) {
	326	# We are updating an existing stemma.
	327	$stemma = $tradition->stemma( $stemmaid );
	328	$stemma->alter_graph( $dot );
	329	} else {
	330	# Unrecognized stemma ID
	331	return _json_error( $c, 500, "No stemma at index $stemmaid, cannot update" );
	332	}
	333	} catch ( Text::Tradition::Error $e ) {
	334	return _json_error( $c, 500, $e->message );
	335	}
852190b9	336	$m->store( $tradition );
0bded693	337	} else {
	338	# No permissions to update the stemma
	339	return _json_error( $c, 403,
	340	'You do not have permission to update stemmata for this tradition' );
852190b9	341	}
6b70c348	342	}
0bded693	343
	344	# For a GET or a successful POST request, return the SVG representation
	345	# of the stemma in question, if any.
0bded693	346	if( !$stemma && $tradition->stemma_count > $stemmaid ) {
	347	$stemma = $tradition->stemma( $stemmaid );
	348	}
789cbe47	349	my $stemma_xml = $stemma ? $stemma->as_svg( { size => [ 500, 375 ] } ) : '';
	350	# What was requested, XML or JSON?
	351	my $return_view = 'SVG';
	352	if( my $accept_header = $c->req->header('Accept') ) {
	353	$c->log->debug( "Received Accept header: $accept_header" );
	354	foreach my $type ( split( /,\s*/, $accept_header ) ) {
	355	# If we were first asked for XML, return SVG
	356	last if $type =~ /^(application\|text)\/xml$/;
	357	# If we were first asked for JSON, return JSON
	358	if( $type eq 'application/json' ) {
	359	$return_view = 'JSON';
	360	last;
	361	}
	362	}
	363	}
	364	if( $return_view eq 'SVG' ) {
	365	$c->stash->{'result'} = $stemma_xml;
	366	$c->forward('View::SVG');
	367	} else { # JSON
	368	$stemma_xml =~ s/\n/ /mg;
	369	$c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml };
	370	$c->forward('View::JSON');
	371	}
dbcf12a6	372	}
dbcf12a6	373
6b70c348	374	=head2 stemmadot
12720144	375
0bded693	376	GET /stemmadot/$textid/$stemmaseq
6b70c348	377
	378	Returns the 'dot' format representation of the current stemma hypothesis.
	379
	380	=cut
	381
0bded693	382	sub stemmadot :Local :Args(2) {
0bded693	383	my( $self, $c, $textid, $stemmaid ) = @_;
6b70c348	384	my $m = $c->model('Directory');
6b70c348	385	my $tradition = $m->tradition( $textid );
0bded693	386	unless( $tradition ) {
	387	return _json_error( $c, 500, "No tradition with ID $textid" );
	388	}
852190b9	389	my $ok = _check_permission( $c, $tradition );
852190b9	390	return unless $ok;
0bded693	391	my $stemma = $tradition->stemma( $stemmaid );
	392	unless( $stemma ) {
	393	return _json_error( $c, 500, "Tradition $textid has no stemma ID $stemmaid" );
	394	}
	395	# Get the dot and transmute its line breaks to literal '\|n'
	396	$c->stash->{'result'} = { 'dot' => $stemma->editable( { linesep => '\|n' } ) };
852190b9	397	$c->forward('View::JSON');
	398	}
	399
ea45d2a6	400	=head2 phylotrees
	401
	402	GET /phylotrees/$textid
	403
	404	Calculates the phylogenetic tree(s) from the given text variants, and returns a
	405	set of the results. The user may then select a tree, choose a root node, and add
	406	that to the stemmata for the tradition (if s/he has edit rights to the tradition.)
	407
	408	=cut
	409
	410	sub phylotrees :Local :Args(1) {
	411	my( $self, $c, $textid ) = @_;
	412	my $tradition = $c->model('Directory')->tradition( $textid );
	413	unless( $tradition ) {
	414	return _json_error( $c, 500, "No tradition with ID $textid" );
	415	}
	416	my $ok = _check_permission( $c, $tradition );
	417	return unless $ok;
	418
	419	## Make the character matrix and run pars
	420	## TODO normalization options
	421	my $charmatrix = character_input( $tradition );
	422	my $newick;
	423	try {
	424	$newick = phylip_pars( $charmatrix );
	425	} catch ( Text::Tradition::Error $e ) {
	426	return _json_error( $c, 500, $e->message );
	427	}
	428	## If we got a result, stash it
	429	$c->stash->{'stemmadot'} = [];
	430	$c->stash->{'stemmasvg'} = [];
	431	if( $newick ) {
	432	my $stemmata = parse_newick( $newick );
	433	foreach my $st ( @$stemmata ) {
	434	push( @{$c->stash->{'stemmadot'}}, $st->editable({ linesep => ' ' }) );
	435	my $svgstr = $st->as_svg( {size => [ 800, 600 ] });
	436	$svgstr =~ s/\n//mg;
	437	push( @{$c->stash->{'stemmasvg'}}, $svgstr );
	438	}
	439	}
	440	$c->stash->{'template'} = 'phylotrees.tt';
	441	}
	442
0bded693	443	####################
	444	### Helper functions
	445	####################
852190b9	446
0bded693	447	# Helper to check what permission, if any, the active user has for
0bded693	448	# the given tradition
852190b9	449	sub _check_permission {
	450	my( $c, $tradition ) = @_;
	451	my $user = $c->user_exists ? $c->user->get_object : undef;
	452	if( $user ) {
2b4baccc	453	return 'full' if ( $user->is_admin \|\|
2b4baccc	454	( $tradition->has_user && $tradition->user->id eq $user->id ) );
75ce4f7a	455	}
	456	# Text doesn't belong to us, so maybe it's public?
	457	return 'readonly' if $tradition->public;
	458
	459	# ...nope. Forbidden!
0bded693	460	return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
	461	}
	462
	463	# Helper to throw a JSON exception
	464	sub _json_error {
	465	my( $c, $code, $errmsg ) = @_;
	466	$c->response->status( $code );
	467	$c->stash->{'result'} = { 'error' => $errmsg };
	468	$c->forward('View::JSON');
2b4baccc	469	return 0;
852190b9	470	}
852190b9	471
dbcf12a6	472	=head2 default
	473
	474	Standard 404 error page
	475
	476	=cut
	477
	478	sub default :Path {
	479	my ( $self, $c ) = @_;
	480	$c->response->body( 'Page not found' );
	481	$c->response->status(404);
	482	}
	483
	484	=head2 end
	485
	486	Attempt to render a view, if needed.
	487
	488	=cut
	489
	490	sub end : ActionClass('RenderView') {}
	491
	492	=head1 AUTHOR
	493
	494	Tara L Andrews
	495
	496	=head1 LICENSE
	497
	498	This library is free software. You can redistribute it and/or modify
	499	it under the same terms as Perl itself.
	500
	501	=cut
	502
	503	__PACKAGE__->meta->make_immutable;
	504
	505	1;