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                 # TODO Send them all with appropriate parameters so that the
 321                 # client side can choose what to display.
 322                 reltypes => [ map { $_->name } grep { !$_->is_weak && $_->is_colocation }
 323                         $tradition->collation->relationship_types ]
 324         };
 325         ## TODO Make these into callbacks in the other controllers maybe?
 326         if( $tradition->can('language') ) {
 327                 $textinfo->{'language'} = $tradition->language;
 328         }
 329         if( $tradition->can('stemweb_jobid') ) {
 330                 $textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
 331         }
 332         my @stemmasvg = map { _stemma_info( $_ ) } $tradition->stemmata;
 333         $textinfo->{stemmata} = \@stemmasvg;
 334         $c->stash->{'result'} = $textinfo;
 335         $c->forward('View::JSON');
 336 }
 337
 338 =head2 variantgraph
 339
 340  GET /variantgraph/$textid
 341
 342 Returns the variant graph for the text specified at $textid, in SVG form.
 343
 344 =cut
 345
 346 sub variantgraph :Local :Args(1) {
 347         my( $self, $c, $textid ) = @_;
 348         my $tradition = $c->model('Directory')->tradition( $textid );
 349         unless( $tradition ) {
 350                 return _json_error( $c, 404, "No tradition with ID $textid" );
 351         }
 352         my $ok = _check_permission( $c, $tradition );
 353         return unless $ok;
 354
 355         my $collation = $tradition->collation;
 356         $c->stash->{'result'} = $collation->as_svg;
 357         $c->forward('View::SVG');
 358 }
 359
 360 sub _stemma_info {
 361         my( $stemma, $sid ) = @_;
 362         my $ssvg = $stemma->as_svg();
 363         $ssvg =~ s/\n/ /mg;
 364         my $sinfo = {
 365                 name => $stemma->identifier,
 366                 directed => _json_bool( !$stemma->is_undirected ),
 367                 svg => $ssvg };
 368         if( $sid ) {
 369                 $sinfo->{stemmaid} = $sid;
 370         }
 371         return $sinfo;
 372 }
 373
 374 ## TODO Separate stemma manipulation functionality into its own controller.
 375
 376 =head2 stemma
 377
 378  GET /stemma/$textid/$stemmaseq
 379  POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
 380
 381 Returns an SVG representation of the given stemma hypothesis for the text.
 382 If the URL is called with POST, the stemma at $stemmaseq will be altered
 383 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
 384 stemma will be added.
 385
 386 =cut
 387
 388 sub stemma :Local :Args(2) {
 389         my( $self, $c, $textid, $stemmaid ) = @_;
 390         my $m = $c->model('Directory');
 391         my $tradition = $m->tradition( $textid );
 392         unless( $tradition ) {
 393                 return _json_error( $c, 404, "No tradition with ID $textid" );
 394         }
 395         my $ok = _check_permission( $c, $tradition );
 396         return unless $ok;
 397
 398         $c->stash->{'result'} = '';
 399         my $stemma;
 400         if( $c->req->method eq 'POST' ) {
 401                 if( $ok eq 'full' ) {
 402                         my $dot = $c->request->body_params->{'dot'};
 403                         try {
 404                                 if( $stemmaid eq 'n' ) {
 405                                         # We are adding a new stemma.
 406                                         $stemmaid = $tradition->stemma_count;
 407                                         $stemma = $tradition->add_stemma( 'dot' => $dot );
 408                                 } elsif( $stemmaid !~ /^\d+$/ ) {
 409                                         return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
 410                                 } elsif( $stemmaid < $tradition->stemma_count ) {
 411                                         # We are updating an existing stemma.
 412                                         $stemma = $tradition->stemma( $stemmaid );
 413                                         $stemma->alter_graph( $dot );
 414                                 } else {
 415                                         # Unrecognized stemma ID
 416                                         return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
 417                                 }
 418                         } catch ( Text::Tradition::Error $e ) {
 419                                 return _json_error( $c, 500, $e->message );
 420                         }
 421                         $m->store( $tradition );
 422                 } else {
 423                         # No permissions to update the stemma
 424                         return _json_error( $c, 403,
 425                                 'You do not have permission to update stemmata for this tradition' );
 426                 }
 427         }
 428
 429         # For a GET or a successful POST request, return the SVG representation
 430         # of the stemma in question, if any.
 431         if( !$stemma && $tradition->stemma_count > $stemmaid ) {
 432                 $stemma = $tradition->stemma( $stemmaid );
 433         }
 434         # What was requested, XML or JSON?
 435         my $return_view = 'SVG';
 436         if( my $accept_header = $c->req->header('Accept') ) {
 437                 $c->log->debug( "Received Accept header: $accept_header" );
 438                 foreach my $type ( split( /,\s*/, $accept_header ) ) {
 439                         # If we were first asked for XML, return SVG
 440                         last if $type =~ /^(application|text)\/xml$/;
 441                         # If we were first asked for JSON, return JSON
 442                         if( $type eq 'application/json' ) {
 443                                 $return_view = 'JSON';
 444                                 last;
 445                         }
 446                 }
 447         }
 448         if( $return_view eq 'SVG' ) {
 449                 $c->stash->{'result'} = $stemma->as_svg();
 450                 $c->forward('View::SVG');
 451         } else { # JSON
 452                 $c->stash->{'result'} = _stemma_info( $stemma, $stemmaid );
 453                 $c->forward('View::JSON');
 454         }
 455 }
 456
 457 =head2 stemmadot
 458
 459  GET /stemmadot/$textid/$stemmaseq
 460
 461 Returns the 'dot' format representation of the current stemma hypothesis.
 462
 463 =cut
 464
 465 sub stemmadot :Local :Args(2) {
 466         my( $self, $c, $textid, $stemmaid ) = @_;
 467         my $m = $c->model('Directory');
 468         my $tradition = $m->tradition( $textid );
 469         unless( $tradition ) {
 470                 return _json_error( $c, 404, "No tradition with ID $textid" );
 471         }
 472         my $ok = _check_permission( $c, $tradition );
 473         return unless $ok;
 474         my $stemma = $tradition->stemma( $stemmaid );
 475         unless( $stemma ) {
 476                 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
 477         }
 478         # Get the dot and transmute its line breaks to literal '|n'
 479         $c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
 480         $c->forward('View::JSON');
 481 }
 482
 483 =head2 stemmaroot
 484
 485  POST /stemmaroot/$textid/$stemmaseq, { root: <root node ID> }
 486
 487 Orients the given stemma so that the given node is the root (archetype). Returns the
 488 information structure for the new stemma.
 489
 490 =cut
 491
 492 sub stemmaroot :Local :Args(2) {
 493         my( $self, $c, $textid, $stemmaid ) = @_;
 494         my $m = $c->model('Directory');
 495         my $tradition = $m->tradition( $textid );
 496         unless( $tradition ) {
 497                 return _json_error( $c, 404, "No tradition with ID $textid" );
 498         }
 499         my $ok = _check_permission( $c, $tradition );
 500         if( $ok eq 'full' ) {
 501                 my $stemma = $tradition->stemma( $stemmaid );
 502                 try {
 503                         $stemma->root_graph( $c->req->param('root') );
 504                         $m->save( $tradition );
 505                 } catch( Text::Tradition::Error $e ) {
 506                         return _json_error( $c, 400, $e->message );
 507                 } catch {
 508                         return _json_error( $c, 500, "Error re-rooting stemma: $@" );
 509                 }
 510                 $c->stash->{'result'} = _stemma_info( $stemma );
 511                 $c->forward('View::JSON');
 512         } else {
 513                 return _json_error( $c, 403,
 514                                 'You do not have permission to update stemmata for this tradition' );
 515         }
 516 }
 517
 518 =head2 download
 519
 520  GET /download/$textid/$format
 521
 522 Returns a file for download of the tradition in the requested format.
 523
 524 =cut
 525
 526 sub download :Local :Args(2) {
 527         my( $self, $c, $textid, $format ) = @_;
 528         my $tradition = $c->model('Directory')->tradition( $textid );
 529         unless( $tradition ) {
 530                 return _json_error( $c, 404, "No tradition with ID $textid" );
 531         }
 532         my $ok = _check_permission( $c, $tradition );
 533         return unless $ok;
 534
 535         my $outmethod = "as_" . lc( $format );
 536         my $view = "View::$format";
 537         $c->stash->{'name'} = $tradition->name();
 538         $c->stash->{'download'} = 1;
 539         my @outputargs;
 540         if( $format eq 'SVG' ) {
 541                 # Send the list of colors through to the backend.
 542                 # TODO Think of some way not to hard-code this.
 543                 push( @outputargs, { 'show_relations' => 'all',
 544                         'graphcolors' => [ "#5CCCCC", "#67E667", "#F9FE72", "#6B90D4",
 545                                 "#FF7673", "#E467B3", "#AA67D5", "#8370D8", "#FFC173" ] } );
 546         }
 547         try {
 548                 $c->stash->{'result'} = $tradition->collation->$outmethod( @outputargs );
 549         } catch( Text::Tradition::Error $e ) {
 550                 return _json_error( $c, 500, $e->message );
 551         }
 552         $c->forward( $view );
 553 }
 554
 555 ####################
 556 ### Helper functions
 557 ####################
 558
 559 # Helper to check what permission, if any, the active user has for
 560 # the given tradition
 561 sub _check_permission {
 562         my( $c, $tradition ) = @_;
 563     my $user = $c->user_exists ? $c->user->get_object : undef;
 564     if( $user ) {
 565         return 'full' if ( $user->is_admin ||
 566                 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
 567     }
 568         # Text doesn't belong to us, so maybe it's public?
 569         return 'readonly' if $tradition->public;
 570
 571         # ...nope. Forbidden!
 572         return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
 573 }
 574
 575 # Helper to throw a JSON exception
 576 sub _json_error {
 577         my( $c, $code, $errmsg ) = @_;
 578         $c->response->status( $code );
 579         $c->stash->{'result'} = { 'error' => $errmsg };
 580         $c->forward('View::JSON');
 581         return 0;
 582 }
 583
 584 sub _json_bool {
 585         return $_[0] ? JSON::true : JSON::false;
 586 }
 587
 588 =head2 default
 589
 590 Standard 404 error page
 591
 592 =cut
 593
 594 sub default :Path {
 595     my ( $self, $c ) = @_;
 596     $c->response->body( 'Page not found' );
 597     $c->response->status(404);
 598 }
 599
 600 =head2 end
 601
 602 Attempt to render a view, if needed.
 603
 604 =cut
 605
 606 sub end : ActionClass('RenderView') {}
 607
 608 =head1 AUTHOR
 609
 610 Tara L Andrews
 611
 612 =head1 LICENSE
 613
 614 This library is free software. You can redistribute it and/or modify
 615 it under the same terms as Perl itself.
 616
 617 =cut
 618
 619 __PACKAGE__->meta->make_immutable;
 620
 621 1;