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

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