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

=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');
}

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