lib/stemmaweb/Controller/Root.pm

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