lib/stemmaweb/Controller/Root.pm

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