[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';
}

=head2 about

A general overview/documentation page for the site.

=cut

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