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

package stemmaweb::Controller::Root;
use Moose;
use namespace::autoclean;
use JSON qw ();
use TryCatch;
use XML::LibXML;
use XML::LibXML::XPathContext;


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' ) {
		my $type;
		# Parse the XML to see which flavor it is.
		my $parser = XML::LibXML->new();
		my $doc;
		try {
			$doc = $parser->parse_file( $newopts{'file'} );
		} catch( $err ) {
			$errmsg = "XML file parsing error: $err";
		}
		if( $doc ) {
			if( $doc->documentElement->nodeName eq 'graphml' ) {
				$type = 'CollateX';
			} elsif( $doc->documentElement->nodeName ne 'TEI' ) {
				$errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
			} else {
				my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
				my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' );
				if( $venc && $venc eq 'double-end-point' ) {
					$type = 'CTE';
				} else {
					$type = 'TEI';
				}
			}
		}
		# Try the relevant XML parsing option.
		if( $type ) {
			delete $newopts{'file'};
			$newopts{'xmlobj'} = $doc;
			try {
				$tradition = Text::Tradition->new( %newopts, 'input' => $type );
			} catch ( Text::Tradition::Error $e ) {
				$errmsg = $e->message;
			} catch ( $e ) {
				$errmsg = "Unexpected parsing error: $e";
			}
		}
	} 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 ( $e ) {
			$errmsg = "Unexpected parsing error: $e";
		}
	} 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'};
			if( $tradition->has_user && !$tradition->user ) {
				$tradition->clear_user;
			}
			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,
		public => $tradition->public || 0,
		owner => $tradition->user ? $tradition->user->email : undef,
		witnesses => [ map { $_->sigil } $tradition->witnesses ],
		# TODO Send them all with appropriate parameters so that the
		# client side can choose what to display.
		reltypes => [ map { $_->name } grep { !$_->is_weak && $_->is_colocation }
			$tradition->collation->relationship_types ]
	};
	## TODO Make these into callbacks in the other controllers maybe?
	if( $tradition->can('language') ) {
		$textinfo->{'language'} = $tradition->language;
	}
	if( $tradition->can('stemweb_jobid') ) {
		$textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
	}
	my @stemmasvg = map { _stemma_info( $_ ) } $tradition->stemmata;
	$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');
}

sub _stemma_info {
	my( $stemma, $sid ) = @_;
	my $ssvg = $stemma->as_svg();
	$ssvg =~ s/\n/ /mg;
	my $sinfo = {
		name => $stemma->identifier, 
		directed => _json_bool( !$stemma->is_undirected ),
		svg => $ssvg }; 
	if( $sid ) {
		$sinfo->{stemmaid} = $sid;
	}
	return $sinfo;
}

## TODO Separate stemma manipulation functionality into its own controller.
	
=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 );
	}
	# 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->as_svg();
		$c->forward('View::SVG');
	} else { # JSON
		$c->stash->{'result'} = _stemma_info( $stemma, $stemmaid );
		$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 stemmaroot

 POST /stemmaroot/$textid/$stemmaseq, { root: <root node ID> }

Orients the given stemma so that the given node is the root (archetype). Returns the 
information structure for the new stemma.

=cut 

sub stemmaroot :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 );
	if( $ok eq 'full' ) {
		my $stemma = $tradition->stemma( $stemmaid );
		try {
			$stemma->root_graph( $c->req->param('root') );
			$m->save( $tradition );
		} catch( Text::Tradition::Error $e ) {
			return _json_error( $c, 400, $e->message );
		} catch {
			return _json_error( $c, 500, "Error re-rooting stemma: $@" );
		}
		$c->stash->{'result'} = _stemma_info( $stemma );
		$c->forward('View::JSON');
	} else {
		return _json_error( $c, 403,  
				'You do not have permission to update stemmata for this tradition' );
	}
}

=head2 download

 GET /download/$textid/$format
 
Returns a file for download of the tradition in the requested format.
 
=cut

sub download :Local :Args(2) {
	my( $self, $c, $textid, $format ) = @_;
	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 $outmethod = "as_" . lc( $format );
	my $view = "View::$format";
	$c->stash->{'name'} = $tradition->name();
	$c->stash->{'download'} = 1;
	my @outputargs;
	if( $format eq 'SVG' ) {
		# Send the list of colors through to the backend.
		# TODO Think of some way not to hard-code this.
		push( @outputargs, { 'show_relations' => 'all',
			'graphcolors' => [ "#5CCCCC", "#67E667", "#F9FE72", "#6B90D4", 
				"#FF7673", "#E467B3", "#AA67D5", "#8370D8", "#FFC173" ] } );
	}
	try {
		$c->stash->{'result'} = $tradition->collation->$outmethod( @outputargs );
	} catch( Text::Tradition::Error $e ) {
		return _json_error( $c, 500, $e->message );
	}
	$c->forward( $view );
}

####################
### 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;
}

sub _json_bool {
	return $_[0] ? JSON::true : JSON::false;
}

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