lib/stemmaweb/Controller/Root.pm

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