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

package stemmaweb::Controller::Root;
use Moose;
use namespace::autoclean;
use JSON qw ();
use LWP::UserAgent;
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 => '');

my $STEMWEB_BASE_URL = 'http://slinkola.users.cs.helsinki.fi';

=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');
	}
	# Get the current list of Stemweb algorithms
	my $ua = LWP::UserAgent->new();
	my $resp = $ua->get( $STEMWEB_BASE_URL . '/algorithms/available' );
	if( $resp->is_success ) {
		$c->stash->{'stemweb_algorithms'} = $resp->content;
	} else {
		$c->stash->{'stemweb_algorithms'} = '{}';
	}
    $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 ],
	};
	if( $tradition->can('language') ) {
		$textinfo->{'language'} = $tradition->language;
	}
	if( $tradition->can('stemweb_jobid') ) {
		$textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
	}
	my @stemmasvg = map { { 
			name => $_->identifier, 
			directed => _json_bool( !$_->is_undirected ),
			svg => $_->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, as long as they aren't already
			# wrapped, and as long as they aren't the initial '(di)?graph .*'.
			# Horrible HACK.
			my @dlines = split( "\n", $dot );
			my $wdot = '';
			foreach( @dlines ) {
				unless( /^(di)?graph/ ) { # Skip the first line
					s/(?<!")\b(\w+)\b(?!")/"$1"/g;
				}
				$wdot .= "$_\n";
			}
			# $dot =~ s/(?<!")\b(?!(?:digraph|stemma)\b)(\w+)\b(?!")/"$1"/g;
			$dot = $wdot;
			print STDERR "$dot\n";
			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, 
			'name' => $stemma->identifier,
			'directed' => _json_bool( !$stemma->is_undirected ),
			'svg' => $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;
}

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