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