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