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