lib/stemmaweb/Controller/Root.pm

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