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