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

package stemmaweb::Controller::Root;
use Moose;
use namespace::autoclean;
use Text::Tradition::Analysis qw/ run_analysis /;
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';
}

=head2 help/*

A dispatcher for documentation of various aspects of the application.

=cut

sub help :Local :Args(1) {
	my( $self, $c, $topic ) = @_;
	$c->stash->{template} = "$topic.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";
			}
			if( $tradition ) {
				$errmsg = undef;
				last;
			}
		}
	} 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 );
	## Have to keep users in the same scope as tradition
	my $newuser;
	my $olduser;
	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 || !$tradition->can('language') ) {
			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
		if( exists $params->{'owner'} ) {
			# Only admins can update user / owner
			my $newownerid = delete $params->{'owner'};
			unless( !$newownerid || 
				( $tradition->has_user && $tradition->user->email 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({ email => $newownerid });
				unless( $newuser ) {
					return _json_error( $c, 500, "No such user " . $newownerid );
				}
				if( $tradition->has_user ) {
					$olduser = $tradition->user;
					$olduser->remove_tradition( $tradition );
				}
				$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 || 0,
		owner => $tradition->user ? $tradition->user->email : undef,
		witnesses => [ map { $_->sigil } $tradition->witnesses ],
	};
	if( $tradition->can('language') ) {
		$textinfo->{'language'} = $tradition->language;
	}
	my @stemmasvg = map { $_->as_svg() } $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() : '';
	# 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 download

 GET /download/$textid
 
Returns the full XML definition of the tradition and its stemmata, if any.
 
=cut

sub download :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;
	try {
		$c->stash->{'result'} = $tradition->collation->as_graphml();
	} catch( Text::Tradition::Error $e ) {
		return _json_error( $c, 500, $e->message );
	}
	$c->forward('View::GraphML');
}

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