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

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

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