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 $direction = $c->request->param('direction') || 'LR';
 127
 128         my( $ext ) = $upload->filename =~ /\.(\w+)$/;
 129         my %newopts = (
 130                 'name' => $name,
 131                 'language' => $lang,
 132                 'public' => $public,
 133                 'file' => $upload->tempname,
 134                 'direction' => $direction,
 135                 );
 136
 137         my $tradition;
 138         my $errmsg;
 139         if( $ext eq 'xml' ) {
 140                 my $type;
 141                 # Parse the XML to see which flavor it is.
 142                 my $parser = XML::LibXML->new();
 143                 my $doc;
 144                 try {
 145                         $doc = $parser->parse_file( $newopts{'file'} );
 146                 } catch( $err ) {
 147                         $errmsg = "XML file parsing error: $err";
 148                 }
 149                 if( $doc ) {
 150                         if( $doc->documentElement->nodeName eq 'graphml' ) {
 151                                 $type = 'CollateX';
 152                         } elsif( $doc->documentElement->nodeName ne 'TEI' ) {
 153                                 $errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
 154                         } else {
 155                                 my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
 156                                 my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' );
 157                                 if( $venc && $venc eq 'double-end-point' ) {
 158                                         $type = 'CTE';
 159                                 } else {
 160                                         $type = 'TEI';
 161                                 }
 162                         }
 163                 }
 164                 # Try the relevant XML parsing option.
 165                 if( $type ) {
 166                         delete $newopts{'file'};
 167                         $newopts{'xmlobj'} = $doc;
 168                         try {
 169                                 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
 170                         } catch ( Text::Tradition::Error $e ) {
 171                                 $errmsg = $e->message;
 172                         } catch ( $e ) {
 173                                 $errmsg = "Unexpected parsing error: $e";
 174                         }
 175                 }
 176         } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
 177                 # If it's Excel we need to pass excel => $ext;
 178                 # otherwise we need to pass sep_char => [record separator].
 179                 if( $ext =~ /xls/ ) {
 180                         $newopts{'excel'} = $ext;
 181                 } else {
 182                         $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
 183                 }
 184                 try {
 185                         $tradition = Text::Tradition->new(
 186                                 %newopts,
 187                                 'input' => 'Tabular',
 188                                 );
 189                 } catch ( Text::Tradition::Error $e ) {
 190                         $errmsg = $e->message;
 191                 } catch ( $e ) {
 192                         $errmsg = "Unexpected parsing error: $e";
 193                 }
 194         } else {
 195                 # Error unless we have a recognized filename extension
 196                 return _json_error( $c, 403, "Unrecognized file type extension $ext" );
 197         }
 198
 199         # Save the tradition if we have it, and return its data or else the
 200         # error that occurred trying to make it.
 201         if( $errmsg ) {
 202                 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
 203         } elsif( !$tradition ) {
 204                 return _json_error( $c, 500, "No error caught but tradition not created" );
 205         }
 206
 207         my $m = $c->model('Directory');
 208         $user->add_tradition( $tradition );
 209         my $id = $c->model('Directory')->store( $tradition );
 210         $c->model('Directory')->store( $user );
 211         $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
 212         $c->forward('View::JSON');
 213 }
 214
 215 =head2 textinfo
 216
 217  GET /textinfo/$textid
 218  POST /textinfo/$textid,
 219         { name: $new_name,
 220           language: $new_language,
 221           public: $is_public,
 222           owner: $new_userid } # only admin users can update the owner
 223
 224 Returns information about a particular text.
 225
 226 =cut
 227
 228 sub textinfo :Local :Args(1) {
 229         my( $self, $c, $textid ) = @_;
 230         my $tradition = $c->model('Directory')->tradition( $textid );
 231         ## Have to keep users in the same scope as tradition
 232         my $newuser;
 233         my $olduser;
 234         unless( $tradition ) {
 235                 return _json_error( $c, 404, "No tradition with ID $textid" );
 236         }
 237         my $ok = _check_permission( $c, $tradition );
 238         return unless $ok;
 239         if( $c->req->method eq 'POST' ) {
 240                 return _json_error( $c, 403,
 241                         'You do not have permission to update this tradition' )
 242                         unless $ok eq 'full';
 243                 my $params = $c->request->parameters;
 244                 # Handle changes to owner-accessible parameters
 245                 my $m = $c->model('Directory');
 246                 my $changed;
 247                 # Handle name param - easy
 248                 if( exists $params->{name} ) {
 249                         my $newname = delete $params->{name};
 250                         unless( $tradition->name eq $newname ) {
 251                                 try {
 252                                         $tradition->name( $newname );
 253                                         $changed = 1;
 254                                 } catch {
 255                                         return _json_error( $c, 500, "Error setting name to $newname: $@" );
 256                                 }
 257                         }
 258                 }
 259                 # Handle language param, making Default => null
 260                 my $langval = delete $params->{language} || 'Default';
 261
 262                 unless( $tradition->language eq $langval || !$tradition->can('language') ) {
 263                         try {
 264                                 $tradition->language( $langval );
 265                                 $changed = 1;
 266                         } catch {
 267                                 return _json_error( $c, 500, "Error setting language to $langval: $@" );
 268                         }
 269                 }
 270
 271                 # Handle our boolean
 272                 my $ispublic = $tradition->public;
 273                 if( delete $params->{'public'} ) {  # if it's any true value...
 274                         $tradition->public( 1 );
 275                         $changed = 1 unless $ispublic;
 276                 } else {  # the checkbox was unchecked, ergo it should not be public
 277                         $tradition->public( 0 );
 278                         $changed = 1 if $ispublic;
 279                 }
 280
 281                 # Handle text direction
 282                 my $tdval = delete $params->{direction} || 'LR';
 283
 284                 unless( $tradition->collation->direction
 285                                 && $tradition->collation->direction eq $tdval ) {
 286                         try {
 287                                 $tradition->collation->change_direction( $tdval );
 288                                 $changed = 1;
 289                         } catch {
 290                                 return _json_error( $c, 500, "Error setting direction to $tdval: $@" );
 291                         }
 292                 }
 293
 294
 295                 # Handle ownership change
 296                 if( exists $params->{'owner'} ) {
 297                         # Only admins can update user / owner
 298                         my $newownerid = delete $params->{'owner'};
 299                         if( $tradition->has_user && !$tradition->user ) {
 300                                 $tradition->clear_user;
 301                         }
 302                         unless( !$newownerid ||
 303                                 ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) {
 304                                 unless( $c->user->get_object->is_admin ) {
 305                                         return _json_error( $c, 403,
 306                                                 "Only admin users can change tradition ownership" );
 307                                 }
 308                                 $newuser = $m->find_user({ email => $newownerid });
 309                                 unless( $newuser ) {
 310                                         return _json_error( $c, 500, "No such user " . $newownerid );
 311                                 }
 312                                 if( $tradition->has_user ) {
 313                                         $olduser = $tradition->user;
 314                                         $olduser->remove_tradition( $tradition );
 315                                 }
 316                                 $newuser->add_tradition( $tradition );
 317                                 $changed = 1;
 318                         }
 319                 }
 320                 # TODO check for rogue parameters
 321                 if( scalar keys %$params ) {
 322                         my $rogueparams = join( ', ', keys %$params );
 323                         return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
 324                 }
 325                 # If we safely got to the end, then write to the database.
 326                 $m->save( $tradition ) if $changed;
 327                 $m->save( $newuser ) if $newuser;
 328         }
 329
 330         # Now return the current textinfo, whether GET or successful POST.
 331         my $textinfo = {
 332                 textid => $textid,
 333                 name => $tradition->name,
 334                 direction => $tradition->collation->direction || 'LR',
 335                 public => $tradition->public || 0,
 336                 owner => $tradition->user ? $tradition->user->email : undef,
 337                 witnesses => [ map { $_->sigil } $tradition->witnesses ],
 338                 # TODO Send them all with appropriate parameters so that the
 339                 # client side can choose what to display.
 340                 reltypes => [ map { $_->name } grep { !$_->is_weak && $_->is_colocation }
 341                         $tradition->collation->relationship_types ]
 342         };
 343         ## TODO Make these into callbacks in the other controllers maybe?
 344         if( $tradition->can('language') ) {
 345                 $textinfo->{'language'} = $tradition->language;
 346         }
 347         if( $tradition->can('stemweb_jobid') ) {
 348                 $textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
 349         }
 350         my @stemmasvg = map { _stemma_info( $_ ) } $tradition->stemmata;
 351         $textinfo->{stemmata} = \@stemmasvg;
 352         $c->stash->{'result'} = $textinfo;
 353         $c->forward('View::JSON');
 354 }
 355
 356 =head2 variantgraph
 357
 358  GET /variantgraph/$textid
 359
 360 Returns the variant graph for the text specified at $textid, in SVG form.
 361
 362 =cut
 363
 364 sub variantgraph :Local :Args(1) {
 365         my( $self, $c, $textid ) = @_;
 366         my $tradition = $c->model('Directory')->tradition( $textid );
 367         unless( $tradition ) {
 368                 return _json_error( $c, 404, "No tradition with ID $textid" );
 369         }
 370         my $ok = _check_permission( $c, $tradition );
 371         return unless $ok;
 372
 373         my $collation = $tradition->collation;
 374         $c->stash->{'result'} = $collation->as_svg;
 375         $c->forward('View::SVG');
 376 }
 377
 378 sub _stemma_info {
 379         my( $stemma, $sid ) = @_;
 380         my $ssvg = $stemma->as_svg();
 381         $ssvg =~ s/\n/ /mg;
 382         my $sinfo = {
 383                 name => $stemma->identifier,
 384                 directed => _json_bool( !$stemma->is_undirected ),
 385                 svg => $ssvg };
 386         if( $sid ) {
 387                 $sinfo->{stemmaid} = $sid;
 388         }
 389         return $sinfo;
 390 }
 391
 392 ## TODO Separate stemma manipulation functionality into its own controller.
 393
 394 =head2 stemma
 395
 396  GET /stemma/$textid/$stemmaseq
 397  POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
 398
 399 Returns an SVG representation of the given stemma hypothesis for the text.
 400 If the URL is called with POST, the stemma at $stemmaseq will be altered
 401 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
 402 stemma will be added.
 403
 404 =cut
 405
 406 sub stemma :Local :Args(2) {
 407         my( $self, $c, $textid, $stemmaid ) = @_;
 408         my $m = $c->model('Directory');
 409         my $tradition = $m->tradition( $textid );
 410         unless( $tradition ) {
 411                 return _json_error( $c, 404, "No tradition with ID $textid" );
 412         }
 413         my $ok = _check_permission( $c, $tradition );
 414         return unless $ok;
 415
 416         $c->stash->{'result'} = '';
 417         my $stemma;
 418         if( $c->req->method eq 'POST' ) {
 419                 if( $ok eq 'full' ) {
 420                         my $dot = $c->request->body_params->{'dot'};
 421                         try {
 422                                 if( $stemmaid eq 'n' ) {
 423                                         # We are adding a new stemma.
 424                                         $stemmaid = $tradition->stemma_count;
 425                                         $stemma = $tradition->add_stemma( 'dot' => $dot );
 426                                 } elsif( $stemmaid !~ /^\d+$/ ) {
 427                                         return _json_error( $c, 403, "Invalid stemma ID specification $stemmaid" );
 428                                 } elsif( $stemmaid < $tradition->stemma_count ) {
 429                                         # We are updating an existing stemma.
 430                                         $stemma = $tradition->stemma( $stemmaid );
 431                                         $stemma->alter_graph( $dot );
 432                                 } else {
 433                                         # Unrecognized stemma ID
 434                                         return _json_error( $c, 404, "No stemma at index $stemmaid, cannot update" );
 435                                 }
 436                         } catch ( Text::Tradition::Error $e ) {
 437                                 return _json_error( $c, 500, $e->message );
 438                         }
 439                         $m->store( $tradition );
 440                 } else {
 441                         # No permissions to update the stemma
 442                         return _json_error( $c, 403,
 443                                 'You do not have permission to update stemmata for this tradition' );
 444                 }
 445         }
 446
 447         # For a GET or a successful POST request, return the SVG representation
 448         # of the stemma in question, if any.
 449         if( !$stemma && $tradition->stemma_count > $stemmaid ) {
 450                 $stemma = $tradition->stemma( $stemmaid );
 451         }
 452         # What was requested, XML or JSON?
 453         my $return_view = 'SVG';
 454         if( my $accept_header = $c->req->header('Accept') ) {
 455                 $c->log->debug( "Received Accept header: $accept_header" );
 456                 foreach my $type ( split( /,\s*/, $accept_header ) ) {
 457                         # If we were first asked for XML, return SVG
 458                         last if $type =~ /^(application|text)\/xml$/;
 459                         # If we were first asked for JSON, return JSON
 460                         if( $type eq 'application/json' ) {
 461                                 $return_view = 'JSON';
 462                                 last;
 463                         }
 464                 }
 465         }
 466         if( $return_view eq 'SVG' ) {
 467                 $c->stash->{'result'} = $stemma->as_svg();
 468                 $c->forward('View::SVG');
 469         } else { # JSON
 470                 $c->stash->{'result'} = _stemma_info( $stemma, $stemmaid );
 471                 $c->forward('View::JSON');
 472         }
 473 }
 474
 475 =head2 stemmadot
 476
 477  GET /stemmadot/$textid/$stemmaseq
 478
 479 Returns the 'dot' format representation of the current stemma hypothesis.
 480
 481 =cut
 482
 483 sub stemmadot :Local :Args(2) {
 484         my( $self, $c, $textid, $stemmaid ) = @_;
 485         my $m = $c->model('Directory');
 486         my $tradition = $m->tradition( $textid );
 487         unless( $tradition ) {
 488                 return _json_error( $c, 404, "No tradition with ID $textid" );
 489         }
 490         my $ok = _check_permission( $c, $tradition );
 491         return unless $ok;
 492         my $stemma = $tradition->stemma( $stemmaid );
 493         unless( $stemma ) {
 494                 return _json_error( $c, 404, "Tradition $textid has no stemma ID $stemmaid" );
 495         }
 496         # Get the dot and transmute its line breaks to literal '|n'
 497         $c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
 498         $c->forward('View::JSON');
 499 }
 500
 501 =head2 stemmaroot
 502
 503  POST /stemmaroot/$textid/$stemmaseq, { root: <root node ID> }
 504
 505 Orients the given stemma so that the given node is the root (archetype). Returns the
 506 information structure for the new stemma.
 507
 508 =cut
 509
 510 sub stemmaroot :Local :Args(2) {
 511         my( $self, $c, $textid, $stemmaid ) = @_;
 512         my $m = $c->model('Directory');
 513         my $tradition = $m->tradition( $textid );
 514         unless( $tradition ) {
 515                 return _json_error( $c, 404, "No tradition with ID $textid" );
 516         }
 517         my $ok = _check_permission( $c, $tradition );
 518         if( $ok eq 'full' ) {
 519                 my $stemma = $tradition->stemma( $stemmaid );
 520                 try {
 521                         $stemma->root_graph( $c->req->param('root') );
 522                         $m->save( $tradition );
 523                 } catch( Text::Tradition::Error $e ) {
 524                         return _json_error( $c, 400, $e->message );
 525                 } catch {
 526                         return _json_error( $c, 500, "Error re-rooting stemma: $@" );
 527                 }
 528                 $c->stash->{'result'} = _stemma_info( $stemma );
 529                 $c->forward('View::JSON');
 530         } else {
 531                 return _json_error( $c, 403,
 532                                 'You do not have permission to update stemmata for this tradition' );
 533         }
 534 }
 535
 536 =head2 download
 537
 538  GET /download/$textid/$format
 539
 540 Returns a file for download of the tradition in the requested format.
 541
 542 =cut
 543
 544 sub download :Local :Args(2) {
 545         my( $self, $c, $textid, $format ) = @_;
 546         my $tradition = $c->model('Directory')->tradition( $textid );
 547         unless( $tradition ) {
 548                 return _json_error( $c, 404, "No tradition with ID $textid" );
 549         }
 550         my $ok = _check_permission( $c, $tradition );
 551         return unless $ok;
 552
 553         my $outmethod = "as_" . lc( $format );
 554         my $view = "View::$format";
 555         $c->stash->{'name'} = $tradition->name();
 556         $c->stash->{'download'} = 1;
 557         my @outputargs;
 558         if( $format eq 'SVG' ) {
 559                 # Send the list of colors through to the backend.
 560                 # TODO Think of some way not to hard-code this.
 561                 push( @outputargs, { 'show_relations' => 'all',
 562                         'graphcolors' => [ "#5CCCCC", "#67E667", "#F9FE72", "#6B90D4",
 563                                 "#FF7673", "#E467B3", "#AA67D5", "#8370D8", "#FFC173" ] } );
 564         }
 565         try {
 566                 $c->stash->{'result'} = $tradition->collation->$outmethod( @outputargs );
 567         } catch( Text::Tradition::Error $e ) {
 568                 return _json_error( $c, 500, $e->message );
 569         }
 570         $c->forward( $view );
 571 }
 572
 573 ####################
 574 ### Helper functions
 575 ####################
 576
 577 # Helper to check what permission, if any, the active user has for
 578 # the given tradition
 579 sub _check_permission {
 580         my( $c, $tradition ) = @_;
 581     my $user = $c->user_exists ? $c->user->get_object : undef;
 582     if( $user ) {
 583         return 'full' if ( $user->is_admin ||
 584                 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
 585     }
 586         # Text doesn't belong to us, so maybe it's public?
 587         return 'readonly' if $tradition->public;
 588
 589         # ...nope. Forbidden!
 590         return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
 591 }
 592
 593 # Helper to throw a JSON exception
 594 sub _json_error {
 595         my( $c, $code, $errmsg ) = @_;
 596         $c->response->status( $code );
 597         $c->stash->{'result'} = { 'error' => $errmsg };
 598         $c->forward('View::JSON');
 599         return 0;
 600 }
 601
 602 sub _json_bool {
 603         return $_[0] ? JSON::true : JSON::false;
 604 }
 605
 606 =head2 default
 607
 608 Standard 404 error page
 609
 610 =cut
 611
 612 sub default :Path {
 613     my ( $self, $c ) = @_;
 614     $c->response->body( 'Page not found' );
 615     $c->response->status(404);
 616 }
 617
 618 =head2 end
 619
 620 Attempt to render a view, if needed.
 621
 622 =cut
 623
 624 sub end : ActionClass('RenderView') {}
 625
 626 =head1 AUTHOR
 627
 628 Tara L Andrews
 629
 630 =head1 LICENSE
 631
 632 This library is free software. You can redistribute it and/or modify
 633 it under the same terms as Perl itself.
 634
 635 =cut
 636
 637 __PACKAGE__->meta->make_immutable;
 638
 639 1;