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