[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'};
			# Graph::Reader::Dot does not handle bare unicode. We get around this
			# by wrapping all words in double quotes, but then we have to undo it
			# for the initial 'digraph stemma' statement. Horrible hack.
			$dot =~ s/\b(\w+)\b/"$1"/g;
			$dot =~ s/"(digraph|stemma)"/$1/g;
			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'};
174e78df	354	# Graph::Reader::Dot does not handle bare unicode. We get around this
	355	# by wrapping all words in double quotes, but then we have to undo it
	356	# for the initial 'digraph stemma' statement. Horrible hack.
	357	$dot =~ s/\b(\w+)\b/"$1"/g;
	358	$dot =~ s/"(digraph\|stemma)"/$1/g;
75354c3a	359	try {
	360	if( $stemmaid eq 'n' ) {
	361	# We are adding a new stemma.
3f7346b1	362	$stemmaid = $tradition->stemma_count;
75354c3a	363	$stemma = $tradition->add_stemma( 'dot' => $dot );
2bfac197	364	} elsif( $stemmaid !~ /^\d+$/ ) {
2bfac197	365	return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
75354c3a	366	} elsif( $stemmaid < $tradition->stemma_count ) {
	367	# We are updating an existing stemma.
	368	$stemma = $tradition->stemma( $stemmaid );
	369	$stemma->alter_graph( $dot );
	370	} else {
	371	# Unrecognized stemma ID
2bfac197	372	return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
75354c3a	373	}
	374	} catch ( Text::Tradition::Error $e ) {
	375	return _json_error( $c, 500, $e->message );
	376	}
41279a86	377	$m->store( $tradition );
75354c3a	378	} else {
	379	# No permissions to update the stemma
	380	return _json_error( $c, 403,
	381	'You do not have permission to update stemmata for this tradition' );
41279a86	382	}
b8a92065	383	}
75354c3a	384
	385	# For a GET or a successful POST request, return the SVG representation
	386	# of the stemma in question, if any.
75354c3a	387	if( !$stemma && $tradition->stemma_count > $stemmaid ) {
	388	$stemma = $tradition->stemma( $stemmaid );
	389	}
2923ebb1	390	my $stemma_xml = $stemma ? $stemma->as_svg() : '';
ce1c5863	391	# What was requested, XML or JSON?
	392	my $return_view = 'SVG';
	393	if( my $accept_header = $c->req->header('Accept') ) {
	394	$c->log->debug( "Received Accept header: $accept_header" );
	395	foreach my $type ( split( /,\s*/, $accept_header ) ) {
	396	# If we were first asked for XML, return SVG
	397	last if $type =~ /^(application\|text)\/xml$/;
	398	# If we were first asked for JSON, return JSON
	399	if( $type eq 'application/json' ) {
	400	$return_view = 'JSON';
	401	last;
	402	}
	403	}
	404	}
	405	if( $return_view eq 'SVG' ) {
	406	$c->stash->{'result'} = $stemma_xml;
	407	$c->forward('View::SVG');
	408	} else { # JSON
	409	$stemma_xml =~ s/\n/ /mg;
	410	$c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml };
	411	$c->forward('View::JSON');
	412	}
b8a92065	413	}
	414
	415	=head2 stemmadot
	416
75354c3a	417	GET /stemmadot/$textid/$stemmaseq
b8a92065	418
	419	Returns the 'dot' format representation of the current stemma hypothesis.
	420
	421	=cut
	422
75354c3a	423	sub stemmadot :Local :Args(2) {
75354c3a	424	my( $self, $c, $textid, $stemmaid ) = @_;
b8a92065	425	my $m = $c->model('Directory');
b8a92065	426	my $tradition = $m->tradition( $textid );
75354c3a	427	unless( $tradition ) {
2bfac197	428	return _json_error( $c, 404, "No tradition with ID $textid" );
75354c3a	429	}
41279a86	430	my $ok = _check_permission( $c, $tradition );
41279a86	431	return unless $ok;
75354c3a	432	my $stemma = $tradition->stemma( $stemmaid );
75354c3a	433	unless( $stemma ) {
2bfac197	434	return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
75354c3a	435	}
	436	# Get the dot and transmute its line breaks to literal '\|n'
	437	$c->stash->{'result'} = { 'dot' => $stemma->editable( { linesep => '\|n' } ) };
41279a86	438	$c->forward('View::JSON');
	439	}
	440
38627d20	441	=head2 download
	442
	443	GET /download/$textid
	444
	445	Returns the full XML definition of the tradition and its stemmata, if any.
	446
	447	=cut
	448
	449	sub download :Local :Args(1) {
	450	my( $self, $c, $textid ) = @_;
	451	my $tradition = $c->model('Directory')->tradition( $textid );
	452	unless( $tradition ) {
	453	return _json_error( $c, 404, "No tradition with ID $textid" );
	454	}
	455	my $ok = _check_permission( $c, $tradition );
	456	return unless $ok;
	457	try {
	458	$c->stash->{'result'} = $tradition->collation->as_graphml();
	459	} catch( Text::Tradition::Error $e ) {
	460	return _json_error( $c, 500, $e->message );
	461	}
	462	$c->forward('View::GraphML');
	463	}
	464
75354c3a	465	####################
	466	### Helper functions
	467	####################
41279a86	468
75354c3a	469	# Helper to check what permission, if any, the active user has for
75354c3a	470	# the given tradition
41279a86	471	sub _check_permission {
	472	my( $c, $tradition ) = @_;
	473	my $user = $c->user_exists ? $c->user->get_object : undef;
	474	if( $user ) {
929ba7c8	475	return 'full' if ( $user->is_admin \|\|
929ba7c8	476	( $tradition->has_user && $tradition->user->id eq $user->id ) );
080f8a02	477	}
	478	# Text doesn't belong to us, so maybe it's public?
	479	return 'readonly' if $tradition->public;
	480
	481	# ...nope. Forbidden!
75354c3a	482	return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
	483	}
	484
	485	# Helper to throw a JSON exception
	486	sub _json_error {
	487	my( $c, $code, $errmsg ) = @_;
	488	$c->response->status( $code );
	489	$c->stash->{'result'} = { 'error' => $errmsg };
	490	$c->forward('View::JSON');
929ba7c8	491	return 0;
41279a86	492	}
41279a86	493
b8a92065	494	=head2 default
	495
	496	Standard 404 error page
	497
	498	=cut
	499
	500	sub default :Path {
	501	my ( $self, $c ) = @_;
	502	$c->response->body( 'Page not found' );
	503	$c->response->status(404);
	504	}
	505
	506	=head2 end
	507
	508	Attempt to render a view, if needed.
	509
	510	=cut
	511
	512	sub end : ActionClass('RenderView') {}
	513
	514	=head1 AUTHOR
	515
	516	Tara L Andrews
	517
	518	=head1 LICENSE
	519
	520	This library is free software. You can redistribute it and/or modify
	521	it under the same terms as Perl itself.
	522
	523	=cut
	524
	525	__PACKAGE__->meta->make_immutable;
	526
	527	1;