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