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