stemmaweb/lib/stemmaweb/Controller/Root.pm

   1 package stemmaweb::Controller::Root;
   2 use Moose;
   3 use namespace::autoclean;
   4 use Text::Tradition::Analysis qw/ run_analysis /;
   5 use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
   6 use TryCatch;
   7
   8
   9 BEGIN { extends 'Catalyst::Controller' }
  10
  11 #
  12 # Sets the actions in this controller to be registered with no prefix
  13 # so they function identically to actions created in MyApp.pm
  14 #
  15 __PACKAGE__->config(namespace => '');
  16
  17 =head1 NAME
  18
  19 stemmaweb::Controller::Root - Root Controller for stemmaweb
  20
  21 =head1 DESCRIPTION
  22
  23 Serves up the main container pages.
  24
  25 =head1 URLs
  26
  27 =head2 index
  28
  29 The root page (/).  Serves the main container page, from which the various
  30 components will be loaded.
  31
  32 =cut
  33
  34 sub index :Path :Args(0) {
  35     my ( $self, $c ) = @_;
  36
  37         # Are we being asked to load a text immediately? If so
  38         if( $c->req->param('withtradition') ) {
  39                 $c->stash->{'withtradition'} = $c->req->param('withtradition');
  40         }
  41     $c->stash->{template} = 'index.tt';
  42 }
  43
  44 =head2 about
  45
  46 A general overview/documentation page for the site.
  47
  48 =cut
  49
  50 sub about :Local :Args(0) {
  51         my( $self, $c ) = @_;
  52         $c->stash->{template} = 'about.tt';
  53 }
  54
  55 =head1 Elements of index page
  56
  57 =head2 directory
  58
  59  GET /directory
  60
  61 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.
  62
  63 =cut
  64
  65 sub directory :Local :Args(0) {
  66         my( $self, $c ) = @_;
  67     my $m = $c->model('Directory');
  68     # Is someone logged in?
  69     my %usertexts;
  70     if( $c->user_exists ) {
  71         my $user = $c->user->get_object;
  72         my @list = $m->traditionlist( $user );
  73         map { $usertexts{$_->{id}} = 1 } @list;
  74                 $c->stash->{usertexts} = \@list;
  75                 $c->stash->{is_admin} = 1 if $user->is_admin;
  76         }
  77         # List public (i.e. readonly) texts separately from any user (i.e.
  78         # full access) texts that exist. Admin users therefore have nothing
  79         # in this list.
  80         my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
  81         $c->stash->{publictexts} = \@plist;
  82         $c->stash->{template} = 'directory.tt';
  83 }
  84
  85 =head1 AJAX methods for traditions and their properties
  86
  87 =head2 newtradition
  88
  89  POST /newtradition,
  90         { name: <name>,
  91           language: <language>,
  92           public: <is_public>,
  93           file: <fileupload> }
  94
  95 Creates a new tradition belonging to the logged-in user, with the given name
  96 and the collation given in the uploaded file. The file type is indicated via
  97 the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and
  98 name of the new tradition.
  99
 100 =cut
 101
 102 sub newtradition :Local :Args(0) {
 103         my( $self, $c ) = @_;
 104         return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
 105                 unless $c->user_exists;
 106
 107         my $user = $c->user->get_object;
 108         # Grab the file upload, check its name/extension, and call the
 109         # appropriate parser(s).
 110         my $upload = $c->request->upload('file');
 111         my $name = $c->request->param('name') || 'Uploaded tradition';
 112         my $lang = $c->request->param( 'language' ) || 'Default';
 113         my $public = $c->request->param( 'public' ) ? 1 : undef;
 114         my( $ext ) = $upload->filename =~ /\.(\w+)$/;
 115         my %newopts = (
 116                 'name' => $name,
 117                 'language' => $lang,
 118                 'public' => $public,
 119                 'file' => $upload->tempname
 120                 );
 121
 122         my $tradition;
 123         my $errmsg;
 124         if( $ext eq 'xml' ) {
 125                 # Try the different XML parsing options to see if one works.
 126                 foreach my $type ( qw/ CollateX CTE TEI / ) {
 127                         try {
 128                                 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
 129                         } catch ( Text::Tradition::Error $e ) {
 130                                 $errmsg = $e->message;
 131                         } catch {
 132                                 $errmsg = "Unexpected parsing error";
 133                         }
 134                         last if $tradition;
 135                 }
 136         } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
 137                 # If it's Excel we need to pass excel => $ext;
 138                 # otherwise we need to pass sep_char => [record separator].
 139                 if( $ext =~ /xls/ ) {
 140                         $newopts{'excel'} = $ext;
 141                 } else {
 142                         $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
 143                 }
 144                 try {
 145                         $tradition = Text::Tradition->new(
 146                                 %newopts,
 147                                 'input' => 'Tabular',
 148                                 );
 149                 } catch ( Text::Tradition::Error $e ) {
 150                         $errmsg = $e->message;
 151                 } catch {
 152                         $errmsg = "Unexpected parsing error";
 153                 }
 154         } else {
 155                 # Error unless we have a recognized filename extension
 156                 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
 157         }
 158
 159         # Save the tradition if we have it, and return its data or else the
 160         # error that occurred trying to make it.
 161         if( $errmsg ) {
 162                 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
 163         } elsif( !$tradition ) {
 164                 return _json_error( $c, 500, "No error caught but tradition not created" );
 165         }
 166
 167         my $m = $c->model('Directory');
 168         $user->add_tradition( $tradition );
 169         my $id = $c->model('Directory')->store( $tradition );
 170         $c->model('Directory')->store( $user );
 171         $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
 172         $c->forward('View::JSON');
 173 }
 174
 175 =head2 textinfo
 176
 177  GET /textinfo/$textid
 178  POST /textinfo/$textid,
 179         { name: $new_name,
 180           language: $new_language,
 181           public: $is_public,
 182           owner: $new_userid } # only admin users can update the owner
 183
 184 Returns information about a particular text.
 185
 186 =cut
 187
 188 sub textinfo :Local :Args(1) {
 189         my( $self, $c, $textid ) = @_;
 190         my $tradition = $c->model('Directory')->tradition( $textid );
 191         unless( $tradition ) {
 192                 return _json_error( $c, 404, "No tradition with ID $textid" );
 193         }
 194         my $ok = _check_permission( $c, $tradition );
 195         return unless $ok;
 196         if( $c->req->method eq 'POST' ) {
 197                 return _json_error( $c, 403,
 198                         'You do not have permission to update this tradition' )
 199                         unless $ok eq 'full';
 200                 my $params = $c->request->parameters;
 201                 # Handle changes to owner-accessible parameters
 202                 my $m = $c->model('Directory');
 203                 my $changed;
 204                 # Handle name param - easy
 205                 if( exists $params->{name} ) {
 206                         my $newname = delete $params->{name};
 207                         unless( $tradition->name eq $newname ) {
 208                                 try {
 209                                         $tradition->name( $newname );
 210                                         $changed = 1;
 211                                 } catch {
 212                                         return _json_error( $c, 500, "Error setting name to $newname" );
 213                                 }
 214                         }
 215                 }
 216                 # Handle language param, making Default => null
 217                 my $langval = delete $params->{language} || 'Default';
 218                 unless( $tradition->language eq $langval ) {
 219                         try {
 220                                 $tradition->language( $langval );
 221                                 $changed = 1;
 222                         } catch {
 223                                 return _json_error( $c, 500, "Error setting language to $langval" );
 224                         }
 225                 }
 226
 227                 # Handle our boolean
 228                 my $ispublic = $tradition->public;
 229                 if( delete $params->{'public'} ) {  # if it's any true value...
 230                         $tradition->public( 1 );
 231                         $changed = 1 unless $ispublic;
 232                 } else {  # the checkbox was unchecked, ergo it should not be public
 233                         $tradition->public( 0 );
 234                         $changed = 1 if $ispublic;
 235                 }
 236
 237                 # Handle ownership change
 238                 my $newuser;
 239                 if( exists $params->{'owner'} ) {
 240                         # Only admins can update user / owner
 241                         my $newownerid = delete $params->{'owner'};
 242                         unless( !$newownerid ||
 243                                 ( $tradition->has_user && $tradition->user->id eq $newownerid ) ) {
 244                                 unless( $c->user->get_object->is_admin ) {
 245                                         return _json_error( $c, 403,
 246                                                 "Only admin users can change tradition ownership" );
 247                                 }
 248                                 $newuser = $m->find_user({ username => $newownerid });
 249                                 unless( $newuser ) {
 250                                         return _json_error( $c, 500, "No such user " . $newownerid );
 251                                 }
 252                                 $newuser->add_tradition( $tradition );
 253                                 $changed = 1;
 254                         }
 255                 }
 256                 # TODO check for rogue parameters
 257                 if( scalar keys %$params ) {
 258                         my $rogueparams = join( ', ', keys %$params );
 259                         return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
 260                 }
 261                 # If we safely got to the end, then write to the database.
 262                 $m->save( $tradition ) if $changed;
 263                 $m->save( $newuser ) if $newuser;
 264         }
 265
 266         # Now return the current textinfo, whether GET or successful POST.
 267         my $textinfo = {
 268                 textid => $textid,
 269                 name => $tradition->name,
 270                 language => $tradition->language,
 271                 public => $tradition->public,
 272                 owner => $tradition->user ? $tradition->user->id : undef,
 273                 witnesses => [ map { $_->sigil } $tradition->witnesses ],
 274         };
 275         my @stemmasvg = map { $_->as_svg({ size => [ 500, 375 ] }) } $tradition->stemmata;
 276         map { $_ =~ s/\n/ /mg } @stemmasvg;
 277         $textinfo->{stemmata} = \@stemmasvg;
 278         $c->stash->{'result'} = $textinfo;
 279         $c->forward('View::JSON');
 280 }
 281
 282 =head2 variantgraph
 283
 284  GET /variantgraph/$textid
 285
 286 Returns the variant graph for the text specified at $textid, in SVG form.
 287
 288 =cut
 289
 290 sub variantgraph :Local :Args(1) {
 291         my( $self, $c, $textid ) = @_;
 292         my $tradition = $c->model('Directory')->tradition( $textid );
 293         unless( $tradition ) {
 294                 return _json_error( $c, 404, "No tradition with ID $textid" );
 295         }
 296         my $ok = _check_permission( $c, $tradition );
 297         return unless $ok;
 298
 299         my $collation = $tradition->collation;
 300         $c->stash->{'result'} = $collation->as_svg;
 301         $c->forward('View::SVG');
 302 }
 303
 304 =head2 stemma
 305
 306  GET /stemma/$textid/$stemmaseq
 307  POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
 308
 309 Returns an SVG representation of the given stemma hypothesis for the text.
 310 If the URL is called with POST, the stemma at $stemmaseq will be altered
 311 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
 312 stemma will be added.
 313
 314 =cut
 315
 316 sub stemma :Local :Args(2) {
 317         my( $self, $c, $textid, $stemmaid ) = @_;
 318         my $m = $c->model('Directory');
 319         my $tradition = $m->tradition( $textid );
 320         unless( $tradition ) {
 321                 return _json_error( $c, 404, "No tradition with ID $textid" );
 322         }
 323         my $ok = _check_permission( $c, $tradition );
 324         return unless $ok;
 325
 326         $c->stash->{'result'} = '';
 327         my $stemma;
 328         if( $c->req->method eq 'POST' ) {
 329                 if( $ok eq 'full' ) {
 330                         my $dot = $c->request->body_params->{'dot'};
 331                         try {
 332                                 if( $stemmaid eq 'n' ) {
 333                                         # We are adding a new stemma.
 334                                         $stemmaid = $tradition->stemma_count;
 335                                         $stemma = $tradition->add_stemma( 'dot' => $dot );
 336                                 } elsif( $stemmaid !~ /^\d+$/ ) {
 337                                         return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
 338                                 } elsif( $stemmaid < $tradition->stemma_count ) {
 339                                         # We are updating an existing stemma.
 340                                         $stemma = $tradition->stemma( $stemmaid );
 341                                         $stemma->alter_graph( $dot );
 342                                 } else {
 343                                         # Unrecognized stemma ID
 344                                         return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
 345                                 }
 346                         } catch ( Text::Tradition::Error $e ) {
 347                                 return _json_error( $c, 500, $e->message );
 348                         }
 349                         $m->store( $tradition );
 350                 } else {
 351                         # No permissions to update the stemma
 352                         return _json_error( $c, 403,
 353                                 'You do not have permission to update stemmata for this tradition' );
 354                 }
 355         }
 356
 357         # For a GET or a successful POST request, return the SVG representation
 358         # of the stemma in question, if any.
 359         if( !$stemma && $tradition->stemma_count > $stemmaid ) {
 360                 $stemma = $tradition->stemma( $stemmaid );
 361         }
 362         my $stemma_xml = $stemma ? $stemma->as_svg( { size => [ 500, 375 ] } ) : '';
 363         # What was requested, XML or JSON?
 364         my $return_view = 'SVG';
 365         if( my $accept_header = $c->req->header('Accept') ) {
 366                 $c->log->debug( "Received Accept header: $accept_header" );
 367                 foreach my $type ( split( /,\s*/, $accept_header ) ) {
 368                         # If we were first asked for XML, return SVG
 369                         last if $type =~ /^(application|text)\/xml$/;
 370                         # If we were first asked for JSON, return JSON
 371                         if( $type eq 'application/json' ) {
 372                                 $return_view = 'JSON';
 373                                 last;
 374                         }
 375                 }
 376         }
 377         if( $return_view eq 'SVG' ) {
 378                 $c->stash->{'result'} = $stemma_xml;
 379                 $c->forward('View::SVG');
 380         } else { # JSON
 381                 $stemma_xml =~ s/\n/ /mg;
 382                 $c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml };
 383                 $c->forward('View::JSON');
 384         }
 385 }
 386
 387 =head2 stemmadot
 388
 389  GET /stemmadot/$textid/$stemmaseq
 390
 391 Returns the 'dot' format representation of the current stemma hypothesis.
 392
 393 =cut
 394
 395 sub stemmadot :Local :Args(2) {
 396         my( $self, $c, $textid, $stemmaid ) = @_;
 397         my $m = $c->model('Directory');
 398         my $tradition = $m->tradition( $textid );
 399         unless( $tradition ) {
 400                 return _json_error( $c, 404, "No tradition with ID $textid" );
 401         }
 402         my $ok = _check_permission( $c, $tradition );
 403         return unless $ok;
 404         my $stemma = $tradition->stemma( $stemmaid );
 405         unless( $stemma ) {
 406                 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
 407         }
 408         # Get the dot and transmute its line breaks to literal '|n'
 409         $c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
 410         $c->forward('View::JSON');
 411 }
 412
 413 =head2 phylotrees
 414
 415  GET /phylotrees/$textid
 416
 417  Calculates the phylogenetic tree(s) from the given text variants, and returns a
 418  set of the results. The user may then select a tree, choose a root node, and add
 419  that to the stemmata for the tradition (if s/he has edit rights to the tradition.)
 420
 421 =cut
 422
 423 sub phylotrees :Local :Args(1) {
 424         my( $self, $c, $textid ) = @_;
 425         my $tradition = $c->model('Directory')->tradition( $textid );
 426         unless( $tradition ) {
 427                 return _json_error( $c, 500, "No tradition with ID $textid" );
 428         }
 429         my $ok = _check_permission( $c, $tradition );
 430         return unless $ok;
 431
 432         ## Make the character matrix and run pars
 433         ## TODO normalization options
 434         my $charmatrix = character_input( $tradition );
 435         my $newick;
 436         try {
 437                 $newick = phylip_pars( $charmatrix );
 438         } catch ( Text::Tradition::Error $e ) {
 439                 return _json_error( $c, 500, $e->message );
 440         }
 441         ## If we got a result, stash it
 442         $c->stash->{'stemmadot'} = [];
 443         $c->stash->{'stemmasvg'} = [];
 444         if( $newick ) {
 445                 my $stemmata = parse_newick( $newick );
 446                 foreach my $st ( @$stemmata ) {
 447                         push( @{$c->stash->{'stemmadot'}}, $st->editable({ linesep => ' ' }) );
 448                         my $svgstr = $st->as_svg( {size => [ 800, 600 ] });
 449                         $svgstr =~ s/\n//mg;
 450                         push( @{$c->stash->{'stemmasvg'}}, $svgstr );
 451                 }
 452         }
 453         $c->stash->{'template'} = 'phylotrees.tt';
 454 }
 455
 456 ####################
 457 ### Helper functions
 458 ####################
 459
 460 # Helper to check what permission, if any, the active user has for
 461 # the given tradition
 462 sub _check_permission {
 463         my( $c, $tradition ) = @_;
 464     my $user = $c->user_exists ? $c->user->get_object : undef;
 465     if( $user ) {
 466         return 'full' if ( $user->is_admin ||
 467                 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
 468     }
 469         # Text doesn't belong to us, so maybe it's public?
 470         return 'readonly' if $tradition->public;
 471
 472         # ...nope. Forbidden!
 473         return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
 474 }
 475
 476 # Helper to throw a JSON exception
 477 sub _json_error {
 478         my( $c, $code, $errmsg ) = @_;
 479         $c->response->status( $code );
 480         $c->stash->{'result'} = { 'error' => $errmsg };
 481         $c->forward('View::JSON');
 482         return 0;
 483 }
 484
 485 =head2 default
 486
 487 Standard 404 error page
 488
 489 =cut
 490
 491 sub default :Path {
 492     my ( $self, $c ) = @_;
 493     $c->response->body( 'Page not found' );
 494     $c->response->status(404);
 495 }
 496
 497 =head2 end
 498
 499 Attempt to render a view, if needed.
 500
 501 =cut
 502
 503 sub end : ActionClass('RenderView') {}
 504
 505 =head1 AUTHOR
 506
 507 Tara L Andrews
 508
 509 =head1 LICENSE
 510
 511 This library is free software. You can redistribute it and/or modify
 512 it under the same terms as Perl itself.
 513
 514 =cut
 515
 516 __PACKAGE__->meta->make_immutable;
 517
 518 1;