[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 $direction = $c->request->param('direction') || 'LR';

	my( $ext ) = $upload->filename =~ /\.(\w+)$/;
	my %newopts = (
		'name' => $name,
		'language' => $lang,
		'public' => $public,
		'file' => $upload->tempname,
		'direction' => $direction,
		);

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