lib/stemmaweb/Controller/Root.pm

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